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