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/bear/grizzly
90 touch animal/vertebrate/mammal/mythical/mermaid
91 touch animal/vertebrate/mammal/mythical/unicorn
92 touch animal/vertebrate/mammal/rodent/beaver
93 touch animal/vertebrate/mammal/rodent/mouse
94 touch animal/vertebrate/mammal/rodent/rabbit
95 touch animal/vertebrate/mammal/rodent/rat
96 touch animal/vertebrate/mammal/ruminant/cow
97 touch animal/vertebrate/snake/python
98 touch plant/kingsfoil plant/pipeweed
100 (in-package :cl-user)
101 (defun absolutify (pathname)
102 "Convert a possibly-relative pathname to absolute."
103 (merge-pathnames pathname
104 (make-pathname :directory
106 *default-pathname-defaults*))))
107 (defun sorted-truenamestrings (pathname-designators)
108 "Convert a collection of pathname designators into canonical form
109 using TRUENAME, NAMESTRING, and SORT."
110 (sort (mapcar #'namestring
112 pathname-designators))
114 (defun need-match-1 (directory-pathname result-sorted-truenamestrings)
116 (let ((directory-sorted-truenamestrings (sorted-truenamestrings
117 (directory directory-pathname))))
118 (unless (equal directory-sorted-truenamestrings
119 result-sorted-truenamestrings)
120 (format t "~&~@<DIRECTORY argument = ~_~2I~S~:>~%"
122 (format t "~&~@<DIRECTORY result = ~_~2I~S~:>~%"
123 directory-sorted-truenamestrings)
124 (format t "~&~@<expected result = ~_~2I~S.~:>~%"
125 result-sorted-truenamestrings)
126 (error "mismatch between DIRECTORY and expected result"))))
127 (defun need-match (directory-pathname result-pathnames)
128 "Require that (DIRECTORY DIRECTORY-PATHNAME) return RESULT-PATHNAMES
129 (modulo TRUENAME and NAMESTRING applied to each RESULT-PATHNAME for
130 convenience in e.g. converting Unix filename syntax idiosyncrasies to
131 Lisp filename syntax idiosyncrasies)."
132 (let ((sorted-result-truenamestrings (sorted-truenamestrings
134 ;; Relative and absolute pathnames should give the same result.
135 (need-match-1 directory-pathname
136 sorted-result-truenamestrings)
137 (need-match-1 (absolutify directory-pathname)
138 sorted-result-truenamestrings)))
139 (defun need-matches ()
140 "lotso calls to NEED-MATCH"
141 ;; FIXME: As discussed on sbcl-devel ca. 2001-01-01, DIRECTORY should
142 ;; report Unix directory files contained within its output as e.g.
143 ;; "/usr/bin" instead of the CMU-CL-style "/usr/bin/". In that case,
144 ;; s:/":": in most or all the NEED-MATCHes here.
145 (need-match "./*.*" '("animal/" "dirt" "plant/" "water"))
146 (need-match "*.*" '("animal/" "dirt" "plant/" "water"))
147 (need-match "animal" '("animal/"))
148 (need-match "./animal" '("animal/"))
149 (need-match "animal/*.*" '("animal/invertebrate/" "animal/vertebrate/"))
150 (need-match "animal/*/*.*"
151 '("animal/vertebrate/bird/"
152 "animal/vertebrate/mammal/"
153 "animal/vertebrate/snake/"))
154 (need-match "plant/*.*" '("plant/kingsfoil" "plant/pipeweed"))
155 (need-match "plant/**/*.*" '("plant/kingsfoil" "plant/pipeweed"))
156 (need-match "plant/**/**/*.*" '("plant/kingsfoil" "plant/pipeweed"))
157 (let ((vertebrates (mapcar (lambda (stem)
163 "mammal/bear/" "mammal/bear/grizzly"
164 "mammal/mythical/" "mammal/mythical/mermaid"
165 "mammal/mythical/unicorn"
167 "mammal/rodent/" "mammal/rodent/beaver"
168 "mammal/rodent/mouse" "mammal/rodent/rabbit"
170 "mammal/ruminant/" "mammal/ruminant/cow"
172 "snake/" "snake/python"))))
173 (need-match "animal/vertebrate/**/*.*" vertebrates)
174 (need-match "animal/vertebrate/mammal/../**/*.*" vertebrates)
175 (need-match "animal/vertebrate/mammal/../**/**/*.*" vertebrates)
176 (need-match "animal/vertebrate/mammal/mythical/../**/../**/*.*"
178 (need-match "animal/vertebrate/**/robot.*" nil)
179 (need-match "animal/vertebrate/mammal/../**/*.robot" nil)
180 (need-match "animal/vertebrate/mammal/../**/robot/*.*" nil)
181 (need-match "animal/vertebrate/mammal/robot/../**/../**/*.*" nil))
187 # success convention for script