-
Notifications
You must be signed in to change notification settings - Fork 0
/
filesys.test.sh
executable file
·372 lines (342 loc) · 13.2 KB
/
filesys.test.sh
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
#!/bin/sh
# This software is part of the SBCL system. See the README file for
# more information.
#
# While most of SBCL is derived from the CMU CL system, the test
# files (like this one) were written from scratch after the fork
# from CMU CL.
#
# This software is in the public domain and is provided with
# absolutely no warranty. See the COPYING and CREDITS files for
# more information.
. ./subr.sh
use_test_subdirectory
testdir="`pwd -P`" # resolve symbolic links in the directory.
set -f # disable filename expansion in the shell.
# Test DIRECTORY and TRUENAME.
echo this is a test > test-1.tmp
echo this is a test > test-2.tmp
echo this is a test > wild?test.tmp
ln -s "$testdir" dirlinktest
ln -s test-1.tmp link-1
ln -s "$testdir/test-2.tmp" link-2
ln -s i-do-not-exist link-3
ln -s link-4 link-4
ln -s link-5 link-6
ln -s "$testdir/link-6" link-5
expected_truenames=`cat<<EOF
(list #p"$testdir/"
#p"$testdir/link-3"
#p"$testdir/link-4"
#p"$testdir/link-5"
#p"$testdir/link-6"
#p"$testdir/test-1.tmp"
#p"$testdir/test-2.tmp"
#p"$testdir/wild\\\\\?test.tmp")
EOF
`
# FIXME: the following tests probably can't succeed at all if the
# testdir name contains wildcard characters or quotes.
run_sbcl <<EOF
(in-package :cl-user)
(let* ((directory (directory "./*.*"))
(truenames (sort directory #'string< :key #'pathname-name)))
;(format t "~&TRUENAMES=~S~%" truenames)
(finish-output)
(assert (equal truenames $expected_truenames)))
(assert (equal (truename "dirlinktest") #p"$testdir/"))
(assert (equal (truename "dirlinktest/") #p"$testdir/"))
(assert (equal (truename "test-1.tmp") #p"$testdir/test-1.tmp"))
(assert (equal (truename "link-1") #p"$testdir/test-1.tmp"))
(assert (equal (truename "link-2") #p"$testdir/test-2.tmp"))
(assert (equal (truename "link-3") #p"$testdir/link-3"))
(assert (equal (truename "link-3/") #p"$testdir/link-3"))
(assert (equal (truename "link-4") #p"$testdir/link-4"))
(assert (equal (truename "link-5") #p"$testdir/link-5"))
(assert (equal (truename "link-6") #p"$testdir/link-6"))
(sb-ext:exit :code $EXIT_LISP_WIN)
EOF
check_status_maybe_lose "DIRECTORY/TRUENAME part 1" $?
cd "$SBCL_PWD"
run_sbcl <<EOF
(in-package :cl-user)
(let* ((directory (directory "$testdir/*.*"))
(truenames (sort directory #'string< :key #'pathname-name)))
;(format t "~&TRUENAMES=~S~%" truenames)
(finish-output)
(assert (equal truenames $expected_truenames)))
(assert (equal (truename "$testdir/test-1.tmp") #p"$testdir/test-1.tmp"))
(assert (equal (truename "$testdir/link-1") #p"$testdir/test-1.tmp"))
(assert (equal (truename "$testdir/link-2") #p"$testdir/test-2.tmp"))
(assert (equal (truename "$testdir/link-3") #p"$testdir/link-3"))
(assert (equal (truename "$testdir/link-4") #p"$testdir/link-4"))
(assert (equal (truename "$testdir/link-5") #p"$testdir/link-5"))
(assert (equal (truename "$testdir/link-6") #p"$testdir/link-6"))
(sb-ext:exit :code $EXIT_LISP_WIN)
EOF
check_status_maybe_lose "DIRECTORY/TRUENAME part 2" $?
cleanup_test_subdirectory
# Test DIRECTORY on a tree structure of directories.
use_test_subdirectory
touch water dirt
mkdir animal plant
mkdir animal/vertebrate animal/invertebrate
mkdir animal/vertebrate/mammal
mkdir animal/vertebrate/snake
mkdir animal/vertebrate/bird
mkdir animal/vertebrate/mammal/bear
mkdir animal/vertebrate/mammal/mythical
mkdir animal/vertebrate/mammal/rodent
mkdir animal/vertebrate/mammal/ruminant
touch animal/vertebrate/mammal/platypus
touch animal/vertebrate/mammal/walrus
touch animal/vertebrate/mammal/bear/grizzly
touch animal/vertebrate/mammal/mythical/mermaid
touch animal/vertebrate/mammal/mythical/unicorn
touch animal/vertebrate/mammal/rodent/beaver
touch animal/vertebrate/mammal/rodent/mouse
touch animal/vertebrate/mammal/rodent/rabbit
touch animal/vertebrate/mammal/rodent/rat
touch animal/vertebrate/mammal/ruminant/cow
touch animal/vertebrate/snake/python
touch plant/kingsfoil plant/pipeweed
run_sbcl <<EOF
(in-package :cl-user)
(defun absolutify (pathname)
"Convert a possibly-relative pathname to absolute."
(merge-pathnames pathname
(make-pathname :directory
(pathname-directory
*default-pathname-defaults*))))
(defun sorted-truenamestrings (pathname-designators)
"Convert a collection of pathname designators into canonical form
using TRUENAME, NAMESTRING, and SORT."
(sort (mapcar #'namestring
(mapcar #'truename
pathname-designators))
#'string<))
(defun need-match-1 (directory-pathname result-sorted-truenamestrings)
"guts of NEED-MATCH"
(let ((directory-sorted-truenamestrings (sorted-truenamestrings
(directory directory-pathname))))
(unless (equal directory-sorted-truenamestrings
result-sorted-truenamestrings)
(format t "~&~@<DIRECTORY argument = ~_~2I~S~:>~%"
directory-pathname)
(format t "~&~@<DIRECTORY result = ~_~2I~S~:>~%"
directory-sorted-truenamestrings)
(format t "~&~@<expected result = ~_~2I~S.~:>~%"
result-sorted-truenamestrings)
(error "mismatch between DIRECTORY and expected result"))))
(defun need-match (directory-pathname result-pathnames)
"Require that (DIRECTORY DIRECTORY-PATHNAME) return RESULT-PATHNAMES
(modulo TRUENAME and NAMESTRING applied to each RESULT-PATHNAME for
convenience in e.g. converting Unix filename syntax idiosyncrasies to
Lisp filename syntax idiosyncrasies)."
(let ((sorted-result-truenamestrings (sorted-truenamestrings
result-pathnames)))
;; Relative and absolute pathnames should give the same result.
(need-match-1 directory-pathname
sorted-result-truenamestrings)
(need-match-1 (absolutify directory-pathname)
sorted-result-truenamestrings)))
(defun need-matches ()
"lotso calls to NEED-MATCH"
;; FIXME: As discussed on sbcl-devel ca. 2001-01-01, DIRECTORY should
;; report Unix directory files contained within its output as e.g.
;; "/usr/bin" instead of the CMU-CL-style "/usr/bin/". In that case,
;; s:/":": in most or all the NEED-MATCHes here.
(need-match "./*.*" '("animal/" "dirt" "plant/" "water"))
(need-match "*.*" '("animal/" "dirt" "plant/" "water"))
(need-match "animal" '("animal/"))
(need-match "./animal" '("animal/"))
(need-match "animal/*.*" '("animal/invertebrate/" "animal/vertebrate/"))
(need-match "animal/*/*.*"
'("animal/vertebrate/bird/"
"animal/vertebrate/mammal/"
"animal/vertebrate/snake/"))
(need-match "plant/*.*" '("plant/kingsfoil" "plant/pipeweed"))
(need-match "plant/**/*.*" '("plant/kingsfoil" "plant/pipeweed"))
(need-match "plant/**/**/*.*" '("plant/kingsfoil" "plant/pipeweed"))
(let ((vertebrates (mapcar (lambda (stem)
(concatenate 'string
"animal/vertebrate/"
stem))
'("bird/"
"mammal/"
"mammal/bear/" "mammal/bear/grizzly"
"mammal/mythical/" "mammal/mythical/mermaid"
"mammal/mythical/unicorn"
"mammal/platypus"
"mammal/rodent/" "mammal/rodent/beaver"
"mammal/rodent/mouse" "mammal/rodent/rabbit"
"mammal/rodent/rat"
"mammal/ruminant/" "mammal/ruminant/cow"
"mammal/walrus"
"snake/" "snake/python"))))
(need-match "animal/vertebrate/**/*.*" vertebrates)
(need-match "animal/vertebrate/mammal/../**/*.*" vertebrates)
(need-match "animal/vertebrate/mammal/../**/**/*.*" vertebrates)
#+nil
(need-match "animal/vertebrate/mammal/mythical/../**/../**/*.*"
vertebrates))
(need-match "animal/vertebrate/**/robot.*" nil)
(need-match "animal/vertebrate/mammal/../**/*.robot" nil)
(need-match "animal/vertebrate/mammal/../**/robot/*.*" nil)
#+nil
(need-match "animal/vertebrate/mammal/robot/../**/../**/*.*" nil))
(need-matches)
(sb-ext:exit :code $EXIT_LISP_WIN)
EOF
check_status_maybe_lose "DIRECTORY/TRUENAME part 3" $?
cleanup_test_subdirectory
# DIRECTORY pattern matching
use_test_subdirectory
mkdir foo
touch foo/aa.txt
touch foo/aa.tmp
mkdir foo/x
mkdir far
touch far/ab.txt
touch far/ab.tmp
mkdir far/x
mkdir far/y
mkdir far/y/x
mkdir far/x/x
mkdir qar
touch qar/ac.txt
touch qar/ac.tmp
mkdir foo.moose
touch foo.bar
mkdir -p a/z c
touch a/z/foo.bar
touch a/z/foo.dummy
ln -s ../a/z c/z
run_sbcl <<EOF
(setf (logical-pathname-translations "foo")
(list (list "**;*.txt.*" (merge-pathnames "foo/**/*.txt"))
(list "**;*.*.*" (merge-pathnames "**/*.*"))))
(defun test (pattern &rest expected)
(let ((wanted (sort (mapcar #'truename expected) #'string< :key #'namestring))
(got (sort (directory pattern) #'string< :key #'namestring)))
(unless (equal wanted got)
(error "wanted:~% ~S~%got:~% ~S" wanted got))))
(test "*/a*.txt" "foo/aa.txt" "far/ab.txt" "qar/ac.txt")
(test "fo*/a*.t*" "foo/aa.txt" "foo/aa.tmp")
(test "*/*b.*" "far/ab.txt" "far/ab.tmp")
(test "*a*/*.txt" "far/ab.txt" "qar/ac.txt")
(test "*ar/*.txt" "far/ab.txt" "qar/ac.txt")
(test "f*.*" "far/" "foo/" "foo.moose/" "foo.bar")
(test "f*" "far/" "foo/")
(test "*r" "far/" "qar/")
(test "*r.*" "far/" "qar/")
(test "f*.[mb]*" "foo.moose/" "foo.bar")
(test "f*.m*.*")
(test "f*.b*.*")
(test "*/x" "foo/x/" "far/x/")
(test "far/*/x" "far/y/x/" "far/x/x/")
(test "**/x/" "foo/x/" "far/x/" "far/x/x" "far/y/x/")
(test "foo:*.txt" "foo/aa.txt")
(test "foo:far;*.txt" "far/ab.txt")
(test "foo:foo;*.txt" "foo/aa.txt")
(test "foo:**;*.tmp" "foo/aa.tmp" "far/ab.tmp" "qar/ac.tmp")
(test "foo:foo;*.tmp" "foo/aa.tmp")
(test "c/*/*.bar" "a/z/foo.bar")
(exit :code $EXIT_LISP_WIN)
EOF
check_status_maybe_lose "DIRECTORY/PATTERNS" $?
# Test whether ENSURE-DIRECTORIES-EXIST can create a directory whose
# name contains a wildcard character (it used to get itself confused
# internally).
run_sbcl --eval '(ensure-directories-exist "foo\\*bar/baz.txt")' --eval '(sb-ext:exit)'
test -d foo*bar
check_status_maybe_lose "ENSURE-DIRECTORIES-EXIST part 1" $? \
0 "(directory exists)"
run_sbcl --eval '(ensure-directories-exist "foo\\?bar/baz.txt")' --eval '(sb-ext:exit)'
test -d foo?bar
check_status_maybe_lose "ENSURE-DIRECTORIES-EXIST part 2" $? \
0 "(directory exists)"
# DELETE-FILE
use_test_subdirectory
mkdir sub
touch deltest
touch sub/deltest
run_sbcl --eval '(let ((*default-pathname-defaults* (truename "sub")))
(delete-file "deltest")
(sb-ext:exit))'
test -f deltest && test ! -f sub/deltest
check_status_maybe_lose "delete-file via d-p-d" $? \
0 "ok"
# RENAME-FILE
use_test_subdirectory
touch one
mkdir sub
touch sub/one
touch foo
ln -s foo link
run_sbcl --eval '(let ((*default-pathname-defaults* (truename "sub")))
(rename-file "one" "two"))' \
--eval '(rename-file "one" "three")' \
--eval '(rename-file "link" "bar")'
test -f three
check_status_maybe_lose "rename-file" $? \
0 "ok"
test -f sub/two
check_status_maybe_lose "rename-file via d-p-d" $? \
0 "ok"
test -f foo && test -L bar
check_status_maybe_lose "rename-file + symlink" $? \
0 "ok"
# DELETE-DIRECTORY
use_test_subdirectory
mkdir dont_delete_me
touch me_neither
mkdir simple_test_subdir1
mkdir simple_test_subdir2
mkdir -p deep/1/2/
touch deep/a
touch deep/b
touch deep/1/c
touch deep/1/d
touch deep/1/2/e
touch deep/1/2/f
ln -s `pwd`/dont_delete_me deep/linky
ln -s `pwd`/me_neither deep/1/another_linky
mkdir -p one/one
touch one/one/two
touch one/two
ln -s dont_delete_me will_fail
run_sbcl --eval '(sb-ext:delete-directory "simple_test_subdir1")' \
--eval '(sb-ext:delete-directory "simple_test_subdir2/")' \
--eval '(sb-ext:delete-directory "deep" :recursive t)' \
--eval '(let ((*default-pathname-defaults* (truename "one")))
(delete-directory "one" :recursive t))' \
--eval '(handler-case (delete-directory "will_fail")
(file-error ())
(:no-error (x) (declare (ignore x)) (sb-ext:exit :code 1)))' \
--eval '(sb-ext:exit)'
check_status_maybe_lose "delete-directory symlink" $? \
0 "ok"
test -L will_fail && test -d dont_delete_me
check_status_maybe_lose "delete-directory symlink 2" $? \
0 "ok"
test -d simple_test_subdir1
check_status_maybe_lose "delete-directory 1" $? \
1 "deleted"
test -d simple_test_subdir2
check_status_maybe_lose "delete-directory 2" $? \
1 "deleted"
test -d deep
check_status_maybe_lose "delete-directory 3" $? \
1 "deleted"
test -d dont_delete_me
check_status_maybe_lose "delete-directory 4" $? \
0 "didn't follow link"
test -f me_neither
check_status_maybe_lose "delete-directory 5" $? \
0 "didn't follow link"
test -f one/two && test -d one && test ! -d one/one
check_status_maybe_lose "delete-directory via d-p-d" $? \
0 "ok"
# success convention for script
exit $EXIT_TEST_WIN