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 "tests/filesys.pure.lisp"
  36                              (namestring pathname)))
  37                    dir)))
  38 ;;; In sbcl-0.9.7 DIRECTORY failed on pathnames with character-set
  39 ;;; components.
  40 (let ((dir (directory "[f]*.*")))
  41   ;; We know a little bit about the structure of this result;
  42   ;; let's test to make sure that this test file is in it.
  43   (assert (find-if (lambda (pathname)
  44                      (search "filesys.pure.lisp"
  45                              (namestring pathname)))
  46                    dir)))
  47
  48 ;;; Set *default-pathname-defaults* to something other than the unix
  49 ;;; cwd, to catch functions which access the filesystem without
  50 ;;; merging properly.  We should test more functions than just OPEN
  51 ;;; here, of course
  52
  53 (let ((*default-pathname-defaults*
  54        (make-pathname :directory
  55                       (butlast
  56                        (pathname-directory *default-pathname-defaults*))
  57                       :defaults *default-pathname-defaults*)))
  58   ;; SBCL 0.7.1.2 failed to merge on OPEN
  59   (with-open-file (i "tests/filesys.pure.lisp")
  60       (assert i)))
  61
  62 ;;; OPEN, LOAD and friends should signal an error of type FILE-ERROR
  63 ;;; if they are fed wild pathname designators; firstly, with wild
  64 ;;; pathnames that don't correspond to any files:
  65 (assert (typep (nth-value 1 (ignore-errors (open "non-existent*.lisp")))
  66                'file-error))
  67 (assert (typep (nth-value 1 (ignore-errors (load "non-existent*.lisp")))
  68                'file-error))
  69 ;;; then for pathnames that correspond to precisely one:
  70 (assert (typep (nth-value 1 (ignore-errors (open "filesys.pur*.lisp")))
  71                'file-error))
  72 (assert (typep (nth-value 1 (ignore-errors (load "filesys.pur*.lisp")))
  73                'file-error))
  74 ;;; then for pathnames corresponding to many:
  75 (assert (typep (nth-value 1 (ignore-errors (open "*.lisp")))
  76                'file-error))
  77 (assert (typep (nth-value 1 (ignore-errors (load "*.lisp")))
  78                'file-error))
  79
  80 ;;; ANSI: FILE-LENGTH should signal an error of type TYPE-ERROR if
  81 ;;; STREAM is not a stream associated with a file.
  82 ;;;
  83 ;;; (Peter Van Eynde's ansi-test suite caught this, and Eric Marsden
  84 ;;; reported a fix for CMU CL, which was ported to sbcl-0.6.12.35.)
  85 (assert (typep (nth-value 1 (ignore-errors (file-length *terminal-io*)))
  86                'type-error))
  87
  88 ;;; A few cases Windows does have enough marbles to pass right now
  89 #+win32
  90 (progn
  91   (assert (equal "C:\\FOO" (native-namestring "C:\\FOO")))
  92   (assert (equal "C:\\FOO" (native-namestring "C:/FOO")))
  93   (assert (equal "C:\\FOO\\BAR" (native-namestring "C:\\FOO\\BAR")))
  94   (assert (equal "C:\\FOO\\BAR" (native-namestring "C:\\FOO\\BAR\\" :as-file t))))
  95
  96 (with-test (:name (:parse-native-pathname :as-directory :junk-allowed))
  97   (assert
  98    (equal
  99     (parse-native-namestring "foo.lisp" nil *default-pathname-defaults*
 100                              :as-directory t)
 101     (parse-native-namestring "foo.lisp" nil *default-pathname-defaults*
 102                              :as-directory t
 103                              :junk-allowed t))))
 104
 105 ;;; Test for NATIVE-PATHNAME / NATIVE-NAMESTRING stuff
 106 ;;;
 107 ;;; given only safe characters in the namestring, NATIVE-PATHNAME will
 108 ;;; never error, and NATIVE-NAMESTRING on the result will return the
 109 ;;; original namestring.
 110 (with-test (:name :random-native-namestrings)
 111   (let ((safe-chars
 112          (coerce
 113           (cons #\Newline
 114                 (loop for x from 32 to 127 collect (code-char x)))
 115           'simple-base-string))
 116         (tricky-sequences #("/../" "../" "/.." "." "/." "./" "/./"
 117                             "[]" "*" "**" "/**" "**/" "/**/" "?"
 118                             "\\*" "\\[]" "\\?" "\\*\\*" "*\\*")))
 119     (loop repeat 1000
 120           for length = (random 32)
 121           for native-namestring = (coerce
 122                                    (loop repeat length
 123                                          collect
 124                                          (char safe-chars
 125                                                (random (length safe-chars))))
 126                                    'simple-base-string)
 127           for pathname = (native-pathname native-namestring)
 128           for nnn = (native-namestring pathname)
 129           do #+win32
 130              ;; We canonicalize to \ as the directory separator
 131              ;; on windows -- though both \ and / are legal.
 132              (setf native-namestring (substitute #\\ #\/ native-namestring))
 133              (unless (string= nnn native-namestring)
 134                (error "1: wanted ~S, got ~S" native-namestring nnn)))
 135     (loop repeat 1000
 136           for native-namestring = (with-output-to-string (s)
 137                                     (write-string "mu" s)
 138                                     (loop
 139                                       (let ((r (random 1.0)))
 140                                         (cond
 141                                           ((< r 1/20) (return))
 142                                           ((< r 1/2)
 143                                            (write-char
 144                                             (char safe-chars
 145                                                   (random (length safe-chars)))
 146                                             s))
 147                                           (t (write-string
 148                                               (aref tricky-sequences
 149                                                     (random
 150                                                      (length tricky-sequences)))
 151                                               s))))))
 152           for pathname = (native-pathname native-namestring)
 153           for tricky-nnn = (native-namestring pathname)
 154           do #+win32
 155              ;; We canonicalize to \ as the directory separator
 156              ;; on windows -- though both \ and / are legal.
 157              (setf native-namestring (substitute #\\ #\/ native-namestring))
 158              (unless (string= tricky-nnn native-namestring)
 159                (error "2: wanted ~S, got ~S" native-namestring tricky-nnn)))))
 160
 161 ;;; USER-HOMEDIR-PATHNAME and the extension SBCL-HOMEDIR-PATHNAME both
 162 ;;; used to call PARSE-NATIVE-NAMESTRING without supplying a HOST
 163 ;;; argument, and so would lose when *DEFAULT-PATHNAME-DEFAULTS* was a
 164 ;;; logical pathname.
 165 (with-test (:name :user-homedir-pathname-robustness)
 166   (let ((*default-pathname-defaults* (pathname "SYS:")))
 167     (assert (not (typep (user-homedir-pathname)
 168                         'logical-pathname)))))
 169
 170 (with-test (:name :sbcl-homedir-pathname-robustness)
 171   (let ((*default-pathname-defaults* (pathname "SYS:")))
 172     (assert (not (typep (sb-impl::sbcl-homedir-pathname)
 173                         'logical-pathname)))))
 174
 175 (with-test (:name :file-author-stringp)
 176   #-win32
 177   (assert (stringp (file-author (user-homedir-pathname))))
 178   #+win32
 179   (assert (not (file-author (user-homedir-pathname)))))
 180 (with-test (:name :file-write-date-integerp)
 181   (assert (integerp (file-write-date (user-homedir-pathname)))))
 182
 183 ;;; Canonicalization of pathnames for DIRECTORY
 184 (with-test (:name :directory-/.)
 185   (assert (equal (directory #p".") (directory #p"./")))
 186   (assert (equal (directory #p".") (directory #p""))))
 187 (with-test (:name :directory-/..)
 188   (assert (equal (directory #p"..") (directory #p"../"))))
 189 (with-test (:name :directory-unspecific)
 190   (assert (equal (directory #p".")
 191                  (directory (make-pathname
 192                              :name :unspecific
 193                              :type :unspecific)))))
 194
 195 ;;; Generated with
 196 ;;; (loop for exist in '(nil t)
 197 ;;;       append
 198 ;;;       (loop for (if-exists if-does-not-exist) in '((nil :error)
 199 ;;;                                                    (:error nil)
 200 ;;;                                                    (nil nil)
 201 ;;;                                                    (:error :error))
 202 ;;;             collect (list 'do-open exist if-exists if-does-not-exist)))
 203 (with-test (:name :open-never-openning)
 204   (flet ((do-open (existing if-exists if-does-not-exist
 205                    &optional (direction :output))
 206            (open (if existing
 207                      #.(or *compile-file-truename* *load-truename*)
 208                      "a-really-non-existing-file")
 209                  :direction direction
 210                  :if-exists if-exists :if-does-not-exist if-does-not-exist)))
 211     (assert (raises-error?
 212              (do-open nil nil :error)))
 213     (assert (not
 214              (do-open nil :error nil)))
 215     (assert (not
 216              (do-open t nil :error)))
 217     (assert (raises-error?
 218              (do-open t :error nil)))
 219     (assert (not
 220              (do-open nil nil nil)))
 221     (assert (raises-error?
 222              (do-open nil :error :error)))
 223     (assert (not
 224              (do-open t nil nil)))
 225     (assert (raises-error? (do-open t :error :error)))
 226
 227     (assert (raises-error?
 228              (do-open nil nil :error :io)))
 229     (assert (not
 230              (do-open nil :error nil :io)))
 231     (assert (not
 232              (do-open t nil :error :io)))
 233     (assert (raises-error?
 234              (do-open t :error nil :io)))
 235     (assert (not
 236              (do-open nil nil nil :io)))
 237     (assert (raises-error?
 238              (do-open nil :error :error :io)))
 239     (assert (not
 240              (do-open t nil nil :io)))
 241     (assert (raises-error? (do-open t :error :error :io)))))
 242
 243 (with-test (:name :open-new-version)
 244   (multiple-value-bind (value error)
 245       (ignore-errors (open #.(or *compile-file-truename* *load-truename*)
 246                            :direction :output
 247                            :if-exists :new-version))
 248     (assert (not value))
 249     (assert error)
 250     (assert (equal (simple-condition-format-control error)
 251                    "OPEN :IF-EXISTS :NEW-VERSION is not supported ~
 252                             when a new version must be created."))))