tests/filesys.pure.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; While most of SBCL is derived from the CMU CL system, the test
   5 ;;;; files (like this one) were written from scratch after the fork
   6 ;;;; from CMU CL.
   7 ;;;;
   8 ;;;; This software is in the public domain and is provided with
   9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  10 ;;;; more information.
  11
  12 (in-package "CL-USER")
  13
  14 ;;; In sbcl-0.6.9 FOO-NAMESTRING functions  returned "" instead of NIL.
  15 (let ((pathname0 (make-pathname :host nil
  16                                 :directory
  17                                 (pathname-directory
  18                                  *default-pathname-defaults*)
  19                                 :name "getty"))
  20       (pathname1 (make-pathname :host nil
  21                                 :directory nil
  22                                 :name nil)))
  23   (assert (equal (file-namestring pathname0) "getty"))
  24   (assert (equal (directory-namestring pathname0)
  25                  (directory-namestring *default-pathname-defaults*)))
  26   (assert (equal (file-namestring pathname1) ""))
  27   (assert (equal (directory-namestring pathname1) "")))
  28
  29 ;;; In sbcl-0.6.9 DIRECTORY failed on paths with :WILD or
  30 ;;; :WILD-INFERIORS in their directory components.
  31 (let ((dir (directory "../**/*.*")))
  32   ;; We know a little bit about the structure of this result;
  33   ;; let's test to make sure that this test file is in it.
  34   (assert (find-if (lambda (pathname)
  35                      (search #-win32 "tests/filesys.pure.lisp"
  36                              #+win32 "tests\\filesys.pure.lisp"
  37                              (namestring pathname)))
  38                    dir)))
  39 ;;; In sbcl-0.9.7 DIRECTORY failed on pathnames with character-set
  40 ;;; components.
  41 (let ((dir (directory "[f]*.*")))
  42   ;; We know a little bit about the structure of this result;
  43   ;; let's test to make sure that this test file is in it.
  44   (assert (find-if (lambda (pathname)
  45                      (search "filesys.pure.lisp"
  46                              (namestring pathname)))
  47                    dir)))
  48
  49 ;;; Set *default-pathname-defaults* to something other than the unix
  50 ;;; cwd, to catch functions which access the filesystem without
  51 ;;; merging properly.  We should test more functions than just OPEN
  52 ;;; here, of course
  53
  54 (let ((*default-pathname-defaults*
  55        (make-pathname :directory
  56                       (butlast
  57                        (pathname-directory *default-pathname-defaults*))
  58                       :defaults *default-pathname-defaults*)))
  59   ;; SBCL 0.7.1.2 failed to merge on OPEN
  60   (with-open-file (i "tests/filesys.pure.lisp")
  61       (assert i)))
  62
  63 ;;; OPEN, LOAD and friends should signal an error of type FILE-ERROR
  64 ;;; if they are fed wild pathname designators; firstly, with wild
  65 ;;; pathnames that don't correspond to any files:
  66 (assert (typep (nth-value 1 (ignore-errors (open "non-existent*.lisp")))
  67                'file-error))
  68 (assert (typep (nth-value 1 (ignore-errors (load "non-existent*.lisp")))
  69                'file-error))
  70 ;;; then for pathnames that correspond to precisely one:
  71 (assert (typep (nth-value 1 (ignore-errors (open "filesys.pur*.lisp")))
  72                'file-error))
  73 (assert (typep (nth-value 1 (ignore-errors (load "filesys.pur*.lisp")))
  74                'file-error))
  75 ;;; then for pathnames corresponding to many:
  76 (assert (typep (nth-value 1 (ignore-errors (open "*.lisp")))
  77                'file-error))
  78 (assert (typep (nth-value 1 (ignore-errors (load "*.lisp")))
  79                'file-error))
  80
  81 ;;; ANSI: FILE-LENGTH should signal an error of type TYPE-ERROR if
  82 ;;; STREAM is not a stream associated with a file.
  83 ;;;
  84 ;;; (Peter Van Eynde's ansi-test suite caught this, and Eric Marsden
  85 ;;; reported a fix for CMU CL, which was ported to sbcl-0.6.12.35.)
  86 (assert (typep (nth-value 1 (ignore-errors (file-length *terminal-io*)))
  87                'type-error))
  88
  89 ;;; A few cases Windows does have enough marbles to pass right now
  90 #+win32
  91 (progn
  92   (assert (equal "C:\\FOO" (native-namestring "C:\\FOO")))
  93   (assert (equal "C:\\FOO" (native-namestring "C:/FOO")))
  94   (assert (equal "C:\\FOO\\BAR" (native-namestring "C:\\FOO\\BAR")))
  95   (assert (equal "C:\\FOO\\BAR" (native-namestring "C:\\FOO\\BAR\\" :as-file t))))
  96
  97 ;;; Test for NATIVE-PATHNAME / NATIVE-NAMESTRING stuff
  98 ;;;
  99 ;;; given only safe characters in the namestring, NATIVE-PATHNAME will
 100 ;;; never error, and NATIVE-NAMESTRING on the result will return the
 101 ;;; original namestring.
 102 (with-test (:name :random-native-namestrings)
 103   (let ((safe-chars
 104          (coerce
 105           (cons #\Newline
 106                 (loop for x from 32 to 127 collect (code-char x)))
 107           'simple-base-string))
 108         (tricky-sequences #("/../" "../" "/.." "." "/." "./" "/./"
 109                             "[]" "*" "**" "/**" "**/" "/**/" "?"
 110                             "\\*" "\\[]" "\\?" "\\*\\*" "*\\*")))
 111     (loop repeat 1000
 112           for length = (random 32)
 113           for native-namestring = (coerce
 114                                    (loop repeat length
 115                                          collect
 116                                          (char safe-chars
 117                                                (random (length safe-chars))))
 118                                    'simple-base-string)
 119           for pathname = (native-pathname native-namestring)
 120           for nnn = (native-namestring pathname)
 121           do #+win32
 122              ;; We canonicalize to \ as the directory separator
 123              ;; on windows -- though both \ and / are legal.
 124              (setf native-namestring (substitute #\\ #\/ native-namestring))
 125              (unless (string= nnn native-namestring)
 126                (error "1: wanted ~S, got ~S" native-namestring nnn)))
 127     (loop repeat 1000
 128           for native-namestring = (with-output-to-string (s)
 129                                     (write-string "mu" s)
 130                                     (loop
 131                                       (let ((r (random 1.0)))
 132                                         (cond
 133                                           ((< r 1/20) (return))
 134                                           ((< r 1/2)
 135                                            (write-char
 136                                             (char safe-chars
 137                                                   (random (length safe-chars)))
 138                                             s))
 139                                           (t (write-string
 140                                               (aref tricky-sequences
 141                                                     (random
 142                                                      (length tricky-sequences)))
 143                                               s))))))
 144           for pathname = (native-pathname native-namestring)
 145           for tricky-nnn = (native-namestring pathname)
 146           do #+win32
 147              ;; We canonicalize to \ as the directory separator
 148              ;; on windows -- though both \ and / are legal.
 149              (setf native-namestring (substitute #\\ #\/ native-namestring))
 150              (unless (string= tricky-nnn native-namestring)
 151                (error "2: wanted ~S, got ~S" native-namestring tricky-nnn)))))
 152
 153 ;;; USER-HOMEDIR-PATHNAME and the extension SBCL-HOMEDIR-PATHNAME both
 154 ;;; used to call PARSE-NATIVE-NAMESTRING without supplying a HOST
 155 ;;; argument, and so would lose when *DEFAULT-PATHNAME-DEFAULTS* was a
 156 ;;; logical pathname.
 157 (with-test (:name :user-homedir-pathname-robustness)
 158   (let ((*default-pathname-defaults* (pathname "SYS:")))
 159     (assert (not (typep (user-homedir-pathname)
 160                         'logical-pathname)))))
 161
 162 (with-test (:name :sbcl-homedir-pathname-robustness)
 163   (let ((*default-pathname-defaults* (pathname "SYS:")))
 164     (assert (not (typep (sb-impl::sbcl-homedir-pathname)
 165                         'logical-pathname)))))
 166
 167 (with-test (:name :file-author-stringp)
 168   #-win32
 169   (assert (stringp (file-author (user-homedir-pathname))))
 170   #+win32
 171   (assert (not (file-author (user-homedir-pathname)))))
 172 (with-test (:name :file-write-date-integerp)
 173   (assert (integerp (file-write-date (user-homedir-pathname)))))
 174
 175 ;;; Canonicalization of pathnames for DIRECTORY
 176 (with-test (:name :directory-/.)
 177   (assert (equal (directory #p".") (directory #p"./")))
 178   (assert (equal (directory #p".") (directory #p""))))
 179 (with-test (:name :directory-/..)
 180   (assert (equal (directory #p"..") (directory #p"../"))))
 181 (with-test (:name :directory-unspecific)
 182   (assert (equal (directory #p".")
 183                  (directory (make-pathname
 184                              :name :unspecific
 185                              :type :unspecific)))))