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