3 # This software is part of the SBCL system. See the README file for
6 # While most of SBCL is derived from the CMU CL system, the test
7 # files (like this one) were written from scratch after the fork
10 # This software is in the public domain and is provided with
11 # absolutely no warranty. See the COPYING and CREDITS files for
14 # Test DIRECTORY and TRUENAME.
15 testdir=`pwd`"/filesys-test-$$"
17 echo this is a test > $testdir/test-1.tmp
18 echo this is a test > $testdir/test-2.tmp
20 ln -s test-1.tmp link-1
21 ln -s `pwd`/test-2.tmp link-2
22 ln -s i-do-not-exist link-3
25 ln -s `pwd`/link-6 link-5
27 "'(#p\"$testdir/link-3\"\
28 #p\"$testdir/link-4\"\
29 #p\"$testdir/link-5\"\
30 #p\"$testdir/link-6\"\
31 #p\"$testdir/test-1.tmp\"\
32 #p\"$testdir/test-2.tmp\")"
35 (let* ((directory (directory "./*.*"))
36 (truenames (sort directory #'string< :key #'pathname-name)))
37 (format t "~&TRUENAMES=~S~%" truenames)
39 (assert (equal truenames $expected_truenames)))
40 (assert (equal (truename "test-1.tmp") #p"$testdir/test-1.tmp"))
41 (assert (equal (truename "link-1") #p"$testdir/test-1.tmp"))
42 (assert (equal (truename "link-2") #p"$testdir/test-2.tmp"))
43 (assert (equal (truename "link-3") #p"$testdir/link-3"))
44 (assert (equal (truename "link-4") #p"$testdir/link-4"))
45 (assert (equal (truename "link-5") #p"$testdir/link-5"))
46 (assert (equal (truename "link-6") #p"$testdir/link-6"))
47 (sb-ext:quit :unix-status 52)
50 echo DIRECTORY/TRUENAME test part 1 failed, unexpected SBCL return code=$?
56 (let* ((directory (directory "$testdir/*.*"))
57 (truenames (sort directory #'string< :key #'pathname-name)))
58 (format t "~&TRUENAMES=~S~%" truenames)
60 (assert (equal truenames $expected_truenames)))
61 (assert (equal (truename "$testdir/test-1.tmp") #p"$testdir/test-1.tmp"))
62 (assert (equal (truename "$testdir/link-1") #p"$testdir/test-1.tmp"))
63 (assert (equal (truename "$testdir/link-2") #p"$testdir/test-2.tmp"))
64 (assert (equal (truename "$testdir/link-3") #p"$testdir/link-3"))
65 (assert (equal (truename "$testdir/link-4") #p"$testdir/link-4"))
66 (assert (equal (truename "$testdir/link-5") #p"$testdir/link-5"))
67 (assert (equal (truename "$testdir/link-6") #p"$testdir/link-6"))
68 (sb-ext:quit :unix-status 52)
71 echo DIRECTORY/TRUENAME test part 2 failed, unexpected SBCL return code=$?
76 # Test DIRECTORY on a tree structure of directories.
81 mkdir animal/vertebrate animal/invertebrate
82 mkdir animal/vertebrate/mammal
83 mkdir animal/vertebrate/snake
84 mkdir animal/vertebrate/bird
85 mkdir animal/vertebrate/mammal/bear
86 mkdir animal/vertebrate/mammal/mythical
87 mkdir animal/vertebrate/mammal/rodent
88 mkdir animal/vertebrate/mammal/ruminant
89 touch animal/vertebrate/mammal/platypus
90 touch animal/vertebrate/mammal/walrus
91 touch animal/vertebrate/mammal/bear/grizzly
92 touch animal/vertebrate/mammal/mythical/mermaid
93 touch animal/vertebrate/mammal/mythical/unicorn
94 touch animal/vertebrate/mammal/rodent/beaver
95 touch animal/vertebrate/mammal/rodent/mouse
96 touch animal/vertebrate/mammal/rodent/rabbit
97 touch animal/vertebrate/mammal/rodent/rat
98 touch animal/vertebrate/mammal/ruminant/cow
99 touch animal/vertebrate/snake/python
100 touch plant/kingsfoil plant/pipeweed
102 (in-package :cl-user)
103 (defun absolutify (pathname)
104 "Convert a possibly-relative pathname to absolute."
105 (merge-pathnames pathname
106 (make-pathname :directory
108 *default-pathname-defaults*))))
109 (defun sorted-truenamestrings (pathname-designators)
110 "Convert a collection of pathname designators into canonical form
111 using TRUENAME, NAMESTRING, and SORT."
112 (sort (mapcar #'namestring
114 pathname-designators))
116 (defun need-match-1 (directory-pathname result-sorted-truenamestrings)
118 (let ((directory-sorted-truenamestrings (sorted-truenamestrings
119 (directory directory-pathname))))
120 (unless (equal directory-sorted-truenamestrings
121 result-sorted-truenamestrings)
122 (format t "~&~@<DIRECTORY argument = ~_~2I~S~:>~%"
124 (format t "~&~@<DIRECTORY result = ~_~2I~S~:>~%"
125 directory-sorted-truenamestrings)
126 (format t "~&~@<expected result = ~_~2I~S.~:>~%"
127 result-sorted-truenamestrings)
128 (error "mismatch between DIRECTORY and expected result"))))
129 (defun need-match (directory-pathname result-pathnames)
130 "Require that (DIRECTORY DIRECTORY-PATHNAME) return RESULT-PATHNAMES
131 (modulo TRUENAME and NAMESTRING applied to each RESULT-PATHNAME for
132 convenience in e.g. converting Unix filename syntax idiosyncrasies to
133 Lisp filename syntax idiosyncrasies)."
134 (let ((sorted-result-truenamestrings (sorted-truenamestrings
136 ;; Relative and absolute pathnames should give the same result.
137 (need-match-1 directory-pathname
138 sorted-result-truenamestrings)
139 (need-match-1 (absolutify directory-pathname)
140 sorted-result-truenamestrings)))
141 (defun need-matches ()
142 "lotso calls to NEED-MATCH"
143 ;; FIXME: As discussed on sbcl-devel ca. 2001-01-01, DIRECTORY should
144 ;; report Unix directory files contained within its output as e.g.
145 ;; "/usr/bin" instead of the CMU-CL-style "/usr/bin/". In that case,
146 ;; s:/":": in most or all the NEED-MATCHes here.
147 (need-match "./*.*" '("animal/" "dirt" "plant/" "water"))
148 (need-match "*.*" '("animal/" "dirt" "plant/" "water"))
149 (need-match "animal" '("animal/"))
150 (need-match "./animal" '("animal/"))
151 (need-match "animal/*.*" '("animal/invertebrate/" "animal/vertebrate/"))
152 (need-match "animal/*/*.*"
153 '("animal/vertebrate/bird/"
154 "animal/vertebrate/mammal/"
155 "animal/vertebrate/snake/"))
156 (need-match "plant/*.*" '("plant/kingsfoil" "plant/pipeweed"))
157 (need-match "plant/**/*.*" '("plant/kingsfoil" "plant/pipeweed"))
158 (need-match "plant/**/**/*.*" '("plant/kingsfoil" "plant/pipeweed"))
159 (let ((vertebrates (mapcar (lambda (stem)
165 "mammal/bear/" "mammal/bear/grizzly"
166 "mammal/mythical/" "mammal/mythical/mermaid"
167 "mammal/mythical/unicorn"
169 "mammal/rodent/" "mammal/rodent/beaver"
170 "mammal/rodent/mouse" "mammal/rodent/rabbit"
172 "mammal/ruminant/" "mammal/ruminant/cow"
174 "snake/" "snake/python"))))
175 (need-match "animal/vertebrate/**/*.*" vertebrates)
176 (need-match "animal/vertebrate/mammal/../**/*.*" vertebrates)
177 (need-match "animal/vertebrate/mammal/../**/**/*.*" vertebrates)
178 (need-match "animal/vertebrate/mammal/mythical/../**/../**/*.*"
180 (need-match "animal/vertebrate/**/robot.*" nil)
181 (need-match "animal/vertebrate/mammal/../**/*.robot" nil)
182 (need-match "animal/vertebrate/mammal/../**/robot/*.*" nil)
183 (need-match "animal/vertebrate/mammal/robot/../**/../**/*.*" nil))
189 # success convention for script