tests/filesys.test.sh

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