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 # Test DIRECTORY and TRUENAME.
  15 testdir=`pwd`"/filesys-test-$$"
  16 mkdir $testdir
  17 echo this is a test > $testdir/test-1.tmp
  18 echo this is a test > $testdir/test-2.tmp
  19 cd $testdir
  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
  23 ln -s link-4 link-4
  24 ln -s link-5 link-6
  25 ln -s `pwd`/link-6 link-5
  26 expected_truenames=\
  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\")"
  33 $SBCL <<EOF
  34   (in-package :cl-user)
  35   (let* ((directory (directory "./*.*"))
  36          (truenames (sort directory #'string< :key #'pathname-name)))
  37     (format t "~&TRUENAMES=~S~%" truenames)
  38     (finish-output)
  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)
  48 EOF
  49 if [ $? != 52 ]; then
  50     echo DIRECTORY/TRUENAME test part 1 failed, unexpected SBCL return code=$?
  51     exit 1
  52 fi
  53 cd ..
  54 $SBCL <<EOF
  55   (in-package :cl-user)
  56   (let* ((directory (directory "$testdir/*.*"))
  57          (truenames (sort directory #'string< :key #'pathname-name)))
  58     (format t "~&TRUENAMES=~S~%" truenames)
  59     (finish-output)
  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)
  69 EOF
  70 if [ $? != 52 ]; then
  71     echo DIRECTORY/TRUENAME test part 2 failed, unexpected SBCL return code=$?
  72     exit 1
  73 fi
  74 rm -r $testdir
  75
  76 # Test DIRECTORY on a tree structure of directories.
  77 mkdir $testdir
  78 cd $testdir
  79 touch water dirt
  80 mkdir animal plant
  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/platypus
  90 touch animal/vertebrate/mammal/walrus
  91 touch animal/vertebrate/mammal/bear/grizzly
  92 touch animal/vertebrate/mammal/mythical/mermaid
  93 touch animal/vertebrate/mammal/mythical/unicorn
  94 touch animal/vertebrate/mammal/rodent/beaver
  95 touch animal/vertebrate/mammal/rodent/mouse
  96 touch animal/vertebrate/mammal/rodent/rabbit
  97 touch animal/vertebrate/mammal/rodent/rat
  98 touch animal/vertebrate/mammal/ruminant/cow
  99 touch animal/vertebrate/snake/python
 100 touch plant/kingsfoil plant/pipeweed
 101 $SBCL <<EOF
 102 (in-package :cl-user)
 103 (defun absolutify (pathname)
 104   "Convert a possibly-relative pathname to absolute."
 105   (merge-pathnames pathname
 106                    (make-pathname :directory
 107                                   (pathname-directory
 108                                    *default-pathname-defaults*))))
 109 (defun sorted-truenamestrings (pathname-designators)
 110   "Convert a collection of pathname designators into canonical form
 111 using TRUENAME, NAMESTRING, and SORT."
 112   (sort (mapcar #'namestring
 113                 (mapcar #'truename
 114                         pathname-designators))
 115         #'string<))
 116 (defun need-match-1 (directory-pathname result-sorted-truenamestrings)
 117   "guts of NEED-MATCH"
 118   (let ((directory-sorted-truenamestrings (sorted-truenamestrings
 119                                            (directory directory-pathname))))
 120     (unless (equal directory-sorted-truenamestrings
 121                    result-sorted-truenamestrings)
 122       (format t "~&~@<DIRECTORY argument = ~_~2I~S~:>~%"
 123               directory-pathname)
 124       (format t "~&~@<DIRECTORY result = ~_~2I~S~:>~%"
 125               directory-sorted-truenamestrings)
 126       (format t "~&~@<expected result = ~_~2I~S.~:>~%"
 127               result-sorted-truenamestrings)
 128       (error "mismatch between DIRECTORY and expected result"))))
 129 (defun need-match (directory-pathname result-pathnames)
 130   "Require that (DIRECTORY DIRECTORY-PATHNAME) return RESULT-PATHNAMES
 131 (modulo TRUENAME and NAMESTRING applied to each RESULT-PATHNAME for
 132 convenience in e.g. converting Unix filename syntax idiosyncrasies to
 133 Lisp filename syntax idiosyncrasies)."
 134   (let ((sorted-result-truenamestrings (sorted-truenamestrings
 135                                         result-pathnames)))
 136   ;; Relative and absolute pathnames should give the same result.
 137   (need-match-1 directory-pathname
 138                 sorted-result-truenamestrings)
 139   (need-match-1 (absolutify directory-pathname)
 140                 sorted-result-truenamestrings)))
 141 (defun need-matches ()
 142   "lotso calls to NEED-MATCH"
 143   ;; FIXME: As discussed on sbcl-devel ca. 2001-01-01, DIRECTORY should
 144   ;; report Unix directory files contained within its output as e.g.
 145   ;; "/usr/bin" instead of the CMU-CL-style "/usr/bin/". In that case,
 146   ;; s:/":": in most or all the NEED-MATCHes here.
 147   (need-match "./*.*" '("animal/" "dirt" "plant/" "water"))
 148   (need-match "*.*" '("animal/" "dirt" "plant/" "water"))
 149   (need-match "animal" '("animal/"))
 150   (need-match "./animal" '("animal/"))
 151   (need-match "animal/*.*" '("animal/invertebrate/" "animal/vertebrate/"))
 152   (need-match "animal/*/*.*"
 153               '("animal/vertebrate/bird/"
 154                 "animal/vertebrate/mammal/"
 155                 "animal/vertebrate/snake/"))
 156   (need-match "plant/*.*" '("plant/kingsfoil" "plant/pipeweed"))
 157   (need-match "plant/**/*.*" '("plant/kingsfoil" "plant/pipeweed"))
 158   (need-match "plant/**/**/*.*" '("plant/kingsfoil" "plant/pipeweed"))
 159   (let ((vertebrates (mapcar (lambda (stem)
 160                                (concatenate 'string
 161                                             "animal/vertebrate/"
 162                                             stem))
 163                              '("bird/"
 164                                "mammal/"
 165                                "mammal/bear/" "mammal/bear/grizzly"
 166                                "mammal/mythical/" "mammal/mythical/mermaid"
 167                                "mammal/mythical/unicorn"
 168                                "mammal/platypus"
 169                                "mammal/rodent/" "mammal/rodent/beaver"
 170                                "mammal/rodent/mouse" "mammal/rodent/rabbit"
 171                                "mammal/rodent/rat"
 172                                "mammal/ruminant/" "mammal/ruminant/cow"
 173                                "mammal/walrus"
 174                                "snake/" "snake/python"))))
 175     (need-match "animal/vertebrate/**/*.*" vertebrates)
 176     (need-match "animal/vertebrate/mammal/../**/*.*" vertebrates)
 177     (need-match "animal/vertebrate/mammal/../**/**/*.*" vertebrates)
 178     (need-match "animal/vertebrate/mammal/mythical/../**/../**/*.*"
 179                 vertebrates))
 180   (need-match "animal/vertebrate/**/robot.*" nil)
 181   (need-match "animal/vertebrate/mammal/../**/*.robot" nil)
 182   (need-match "animal/vertebrate/mammal/../**/robot/*.*" nil)
 183   (need-match "animal/vertebrate/mammal/robot/../**/../**/*.*" nil))
 184 (need-matches)
 185 EOF
 186 cd ..
 187 rm -r $testdir
 188
 189 # success convention for script
 190 exit 104