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:quit :unix-status $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:quit :unix-status $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:quit :unix-status $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 mkdir far
 210 touch far/ab.txt
 211 touch far/ab.tmp
 212 mkdir far/x
 213 mkdir far/y
 214 mkdir far/y/x
 215 mkdir far/x/x
 216 mkdir qar
 217 touch qar/ac.txt
 218 touch qar/ac.tmp
 219 mkdir foo.moose
 220 touch foo.bar
 221 run_sbcl <<EOF
 222 (setf (logical-pathname-translations "foo")
 223       (list (list "**;*.txt.*" (merge-pathnames "foo/**/*.txt"))
 224             (list "**;*.*.*" (merge-pathnames "**/*.*"))))
 225
 226 (defun test (pattern &rest expected)
 227   (let ((wanted (sort (mapcar #'truename expected) #'string< :key #'namestring))
 228         (got (sort (directory pattern) #'string< :key #'namestring)))
 229     (unless (equal wanted got)
 230       (error "wanted:~%  ~S~%got:~%  ~S" wanted got))))
 231 (test "*/a*.txt" "foo/aa.txt" "far/ab.txt" "qar/ac.txt")
 232 (test "fo*/a*.t*" "foo/aa.txt" "foo/aa.tmp")
 233 (test "*/*b.*" "far/ab.txt" "far/ab.tmp")
 234 (test "*a*/*.txt" "far/ab.txt" "qar/ac.txt")
 235 (test "*ar/*.txt" "far/ab.txt" "qar/ac.txt")
 236 (test "f*.*" "far/" "foo/" "foo.moose/" "foo.bar")
 237 (test "f*" "far/" "foo/")
 238 (test "*r" "far/" "qar/")
 239 (test "*r.*" "far/" "qar/")
 240 (test "f*.[mb]*" "foo.moose/" "foo.bar")
 241 (test "f*.m*.*")
 242 (test "f*.b*.*")
 243 (test "*/x" "foo/x/" "far/x/")
 244 (test "far/*/x" "far/y/x/" "far/x/x/")
 245 (test "**/x/" "foo/x/" "far/x/" "far/x/x" "far/y/x/")
 246 (test "foo:*.txt" "foo/aa.txt")
 247 (test "foo:far;*.txt" "far/ab.txt")
 248 (test "foo:foo;*.txt" "foo/aa.txt")
 249 (test "foo:**;*.tmp" "foo/aa.tmp" "far/ab.tmp" "qar/ac.tmp")
 250 (test "foo:foo;*.tmp" "foo/aa.tmp")
 251 (quit :unix-status $EXIT_LISP_WIN)
 252 EOF
 253 check_status_maybe_lose "DIRECTORY/PATTERNS" $?
 254
 255 # Test whether ENSURE-DIRECTORIES-EXIST can create a directory whose
 256 # name contains a wildcard character (it used to get itself confused
 257 # internally).
 258 run_sbcl --eval '(ensure-directories-exist "foo\\*bar/baz.txt")' --eval '(sb-ext:quit)'
 259 test -d foo*bar
 260 check_status_maybe_lose "ENSURE-DIRECTORIES-EXIST part 1" $? \
 261     0 "(directory exists)"
 262
 263 run_sbcl --eval '(ensure-directories-exist "foo\\?bar/baz.txt")' --eval '(sb-ext:quit)'
 264 test -d foo?bar
 265 check_status_maybe_lose "ENSURE-DIRECTORIES-EXIST part 2" $? \
 266     0 "(directory exists)"
 267
 268 # DELETE-DIRECTORY
 269 use_test_subdirectory
 270 mkdir    dont_delete_me
 271 touch    me_neither
 272 mkdir    simple_test_subdir1
 273 mkdir    simple_test_subdir2
 274 mkdir -p deep/1/2/
 275 touch    deep/a
 276 touch    deep/b
 277 touch    deep/1/c
 278 touch    deep/1/d
 279 touch    deep/1/2/e
 280 touch    deep/1/2/f
 281 ln -s    `pwd`/dont_delete_me deep/linky
 282 ln -s    `pwd`/me_neither deep/1/another_linky
 283
 284 run_sbcl --eval '(sb-ext:delete-directory "simple_test_subdir1")' \
 285          --eval '(sb-ext:delete-directory "simple_test_subdir2/")' \
 286          --eval '(sb-ext:delete-directory "deep" :recursive t)' \
 287          --eval '(sb-ext:quit)'
 288
 289 test -d simple_test_subdir1
 290 check_status_maybe_lose "delete-directory 1" $? \
 291   1 "deleted"
 292
 293 test -d simple_test_subdir2
 294 check_status_maybe_lose "delete-directory 2" $? \
 295   1 "deleted"
 296
 297 test -d deep
 298 check_status_maybe_lose "delete-directory 3" $? \
 299   1 "deleted"
 300
 301 test -d dont_delete_me
 302 check_status_maybe_lose "delete-directory 4" $? \
 303   0 "didn't follow link"
 304
 305 test -f me_neither
 306 check_status_maybe_lose "delete-directory 5" $? \
 307   0 "didn't follow link"
 308
 309 # success convention for script
 310 exit $EXIT_TEST_WIN