← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to ansi-tests/make-pathname.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
ansi-tests/make-pathname.lsp
 
1
;-*- Mode:     Lisp -*-
 
2
;;;; Author:   Paul Dietz
 
3
;;;; Created:  Sat Nov 29 05:54:30 2003
 
4
;;;; Contains: Tests of MAKE-PATHNAME
 
5
 
 
6
(in-package :cl-test)
 
7
 
 
8
(defvar *null-pathname*
 
9
    (make-pathname))
 
10
 
 
11
(defun make-pathname-test
 
12
  (&rest args &key (defaults nil)
 
13
         (host (if defaults (pathname-host defaults)
 
14
                 (pathname-host *default-pathname-defaults*)))
 
15
         (device (if defaults (pathname-device defaults)
 
16
                   (pathname-device *null-pathname*)))
 
17
         (directory (if defaults (pathname-directory defaults)
 
18
                      (pathname-directory *null-pathname*)))
 
19
         (name (if defaults (pathname-name defaults)
 
20
                 (pathname-name  *null-pathname*)))
 
21
         (type (if defaults (pathname-type defaults)
 
22
                 (pathname-type *null-pathname*)))
 
23
         (version (if defaults (pathname-version defaults)
 
24
                    (pathname-version *null-pathname*)))
 
25
         case)
 
26
  (declare (ignorable case))
 
27
  (let* ((vals (multiple-value-list (apply #'make-pathname args)))
 
28
         (pn (first vals)))
 
29
    (and (= (length vals) 1)
 
30
         (typep pn 'pathname)
 
31
         (equalp (pathname-host pn) host)
 
32
         (equalp (pathname-device pn) device)
 
33
         ;; (equalp (pathname-directory pn) directory)
 
34
         (let ((pnd (pathname-directory pn)))
 
35
           (if (eq directory :wild)
 
36
               (member pnd '((:absolute :wild-inferiors)
 
37
                             (:absolute :wild))
 
38
                       :test #'equal)
 
39
             (equalp pnd directory)))        
 
40
         (equalp (pathname-name pn) name)
 
41
         (equalp (pathname-type pn) type)
 
42
         (equalp (pathname-version pn) version)
 
43
         t)))
 
44
  
 
45
  
 
46
 
 
47
(deftest make-pathname.1
 
48
  (make-pathname-test)
 
49
  t)
 
50
 
 
51
(deftest make-pathname.2
 
52
  (make-pathname-test :name "foo")
 
53
  t)
 
54
 
 
55
(deftest make-pathname.3
 
56
  (make-pathname-test :name "foo" :type "txt")
 
57
  t)
 
58
 
 
59
(deftest make-pathname.4
 
60
  (make-pathname-test :type "lsp")
 
61
  t)
 
62
 
 
63
(deftest make-pathname.5
 
64
  (make-pathname-test :directory :wild)
 
65
  t)
 
66
 
 
67
(deftest make-pathname.6
 
68
  (make-pathname-test :name :wild)
 
69
  t)
 
70
 
 
71
(deftest make-pathname.7
 
72
  (make-pathname-test :type :wild)
 
73
  t)
 
74
 
 
75
(deftest make-pathname.8
 
76
  (make-pathname-test :version :wild)
 
77
  t)
 
78
 
 
79
(deftest make-pathname.9
 
80
  (make-pathname-test :defaults *default-pathname-defaults*)
 
81
  t)
 
82
 
 
83
(deftest make-pathname.10
 
84
  (make-pathname-test :defaults (make-pathname :name "foo" :type "bar"))
 
85
  t)
 
86
 
 
87
(deftest make-pathname.11
 
88
  (make-pathname-test :version :newest)
 
89
  t)
 
90
 
 
91
(deftest make-pathname.12
 
92
  (make-pathname-test :case :local)
 
93
  t)
 
94
 
 
95
(deftest make-pathname.13
 
96
  (make-pathname-test :case :common)
 
97
  t)
 
98
 
 
99
(deftest make-pathname.14
 
100
  (let ((*default-pathname-defaults*
 
101
         (make-pathname :name "foo" :type "lsp" :version :newest)))
 
102
    (make-pathname-test))
 
103
  t)
 
104
 
 
105
;;; Works on the components of actual pathnames
 
106
(deftest make-pathname.rebuild
 
107
  (loop for p in *pathnames*
 
108
        for host = (pathname-host p)
 
109
        for device = (pathname-device p)
 
110
        for directory = (pathname-directory p)
 
111
        for name = (pathname-name p)
 
112
        for type = (pathname-type p)
 
113
        for version = (pathname-version p)
 
114
        for p2 = (make-pathname
 
115
                  :host host
 
116
                  :device device
 
117
                  :directory directory
 
118
                  :name name
 
119
                  :type type
 
120
                  :version version)
 
121
        unless (equal p p2)
 
122
        collect (list p p2))
 
123
  nil)
 
124
 
 
125
;;; Various constraints on :directory
 
126
 
 
127
(deftest make-pathname-error-absolute-up
 
128
  (signals-error (directory (make-pathname :directory '(:absolute :up)))
 
129
                 file-error)
 
130
  t)
 
131
 
 
132
(deftest make-pathname-error-absolute-back
 
133
  (signals-error (directory (make-pathname :directory '(:absolute :back)))
 
134
                 file-error)
 
135
  t)
 
136
 
 
137
;; The next test is correct, but was causing very large amounts of time to be spent
 
138
;; in buggy implementations
 
139
#|
 
140
(deftest make-pathname-error-absolute-wild-inferiors-up
 
141
  (signals-error (directory (make-pathname :directory '(:absolute :wild-inferiors :up)))
 
142
                 file-error)
 
143
  t)
 
144
|#
 
145
 
 
146
(deftest make-pathname-error-relative-wild-inferiors-up
 
147
  (signals-error (length (directory (make-pathname :directory '(:relative :wild-inferiors :up))))
 
148
                 file-error)
 
149
  t)
 
150
 
 
151
(deftest make-pathname-error-absolute-wild-inferiors-back
 
152
  (signals-error (directory (make-pathname :directory '(:absolute :wild-inferiors :back)))
 
153
                 file-error)
 
154
  t)
 
155
 
 
156
(deftest make-pathname-error-relative-wild-inferiors-back
 
157
  (signals-error (directory (make-pathname :directory '(:relative :wild-inferiors :back)))
 
158
                 file-error)
 
159
  t)