source: trunk/source/tests/ansi-tests/make-pathname.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 4.3 KB
Line 
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.2a
56  (do-special-strings
57   (s "foo")
58   (assert (make-pathname-test :name s)))
59  nil)
60
61(deftest make-pathname.3
62  (make-pathname-test :name "foo" :type "txt")
63  t)
64
65(deftest make-pathname.3a
66  (do-special-strings
67   (s "txt")
68   (assert (make-pathname-test :name "foo" :type s)))
69  nil)
70
71(deftest make-pathname.4
72  (make-pathname-test :type "lsp")
73  t)
74
75(deftest make-pathname.5
76  (make-pathname-test :directory :wild)
77  t)
78
79(deftest make-pathname.6
80  (make-pathname-test :name :wild)
81  t)
82
83(deftest make-pathname.7
84  (make-pathname-test :type :wild)
85  t)
86
87(deftest make-pathname.8
88  (make-pathname-test :version :wild)
89  t)
90
91(deftest make-pathname.9
92  (make-pathname-test :defaults *default-pathname-defaults*)
93  t)
94
95(deftest make-pathname.10
96  (make-pathname-test :defaults (make-pathname :name "foo" :type "bar"))
97  t)
98
99(deftest make-pathname.11
100  (make-pathname-test :version :newest)
101  t)
102
103(deftest make-pathname.12
104  (make-pathname-test :case :local)
105  t)
106
107(deftest make-pathname.13
108  (make-pathname-test :case :common)
109  t)
110
111(deftest make-pathname.14
112  (let ((*default-pathname-defaults*
113         (make-pathname :name "foo" :type "lsp" :version :newest)))
114    (make-pathname-test))
115  t)
116
117;;; Works on the components of actual pathnames
118(deftest make-pathname.rebuild
119  (loop for p in *pathnames*
120        for host = (pathname-host p)
121        for device = (pathname-device p)
122        for directory = (pathname-directory p)
123        for name = (pathname-name p)
124        for type = (pathname-type p)
125        for version = (pathname-version p)
126        for p2 = (make-pathname
127                  :host host
128                  :device device
129                  :directory directory
130                  :name name
131                  :type type
132                  :version version)
133        unless (equal p p2)
134        collect (list p p2))
135  nil)
136
137;;; Various constraints on :directory
138
139(deftest make-pathname-error-absolute-up
140  (signals-error (directory (make-pathname :directory '(:absolute :up)))
141                 file-error)
142  t)
143
144(deftest make-pathname-error-absolute-back
145  (signals-error (directory (make-pathname :directory '(:absolute :back)))
146                 file-error)
147  t)
148
149;; The next test is correct, but was causing very large amounts of time to be spent
150;; in buggy implementations
151#|
152(deftest make-pathname-error-absolute-wild-inferiors-up
153  (signals-error (directory (make-pathname :directory '(:absolute :wild-inferiors :up)))
154                 file-error)
155  t)
156|#
157
158(deftest make-pathname-error-relative-wild-inferiors-up
159  (signals-error (length (directory (make-pathname :directory '(:relative :wild-inferiors :up))))
160                 file-error)
161  t)
162
163(deftest make-pathname-error-absolute-wild-inferiors-back
164  (signals-error (directory (make-pathname :directory '(:absolute :wild-inferiors :back)))
165                 file-error)
166  t)
167
168(deftest make-pathname-error-relative-wild-inferiors-back
169  (signals-error (directory (make-pathname :directory '(:relative :wild-inferiors :back)))
170                 file-error)
171  t)
Note: See TracBrowser for help on using the repository browser.