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 ;;;; DIRECTORY
  13
  14 (defun truename-as-expected-p ()
  15   #.(and (string= (pathname-name *load-pathname*) (pathname-name *load-truename*))
  16          (string= (pathname-type *load-pathname*) (pathname-type *load-truename*))))
  17
  18 ;;; In sbcl-0.6.9 DIRECTORY failed on paths with :WILD or
  19 ;;; :WILD-INFERIORS in their directory components.
  20 (with-test (:name (directory :wild-inferiors))
  21   (let ((dir (directory "../**/*.*")))
  22     ;; We know a little bit about the structure of this result;
  23     ;; let's test to make sure that this test file is in it.
  24     ;; If the  truename of this file is not as expected, the look for only the
  25     ;; name+type regardless of directory, treating all parts as essentially random.
  26     (let ((string-to-find
  27            (if (truename-as-expected-p)
  28                "tests/filesys.pure.lisp"
  29                (namestring (make-pathname :name (pathname-name *load-truename*)
  30                                           :type (pathname-type *load-truename*))))))
  31       (assert (find string-to-find dir
  32                     :test #'search :key #'namestring)))))
  33
  34 ;;; In sbcl-0.9.7 DIRECTORY failed on pathnames with character-set
  35 ;;; components.
  36 (with-test (:name (directory :character-set :pattern))
  37   ;; In addition to potential truename randomization,
  38   ;; do not assume that the current directory is the place to look.
  39   (let* ((pattern (if (truename-as-expected-p)
  40                       "[f]*.*"
  41                       (format nil "~a[~a]*~:[~;.*~]"
  42                               (namestring
  43                                (make-pathname :directory (pathname-directory *load-truename*)))
  44                               (char (pathname-name *load-truename*) 0)
  45                               (pathname-type *load-truename*))))
  46          (string-to-find (if (truename-as-expected-p)
  47                              "filesys.pure.lisp"
  48                              (pathname-name *load-truename*)))
  49          (dir (directory pattern)))
  50     (assert (find string-to-find dir :test #'search :key #'namestring))))
  51
  52 ;;; Canonicalization of pathnames for DIRECTORY
  53 (with-test (:name (directory :/.))
  54   (assert (equal (directory #p".") (directory #p"./")))
  55   (assert (equal (directory #p".") (directory #p""))))
  56 (with-test (:name (directory :/..))
  57   (assert (equal (directory #p"..") (directory #p"../"))))
  58 (with-test (:name (directory :unspecific))
  59   (assert (equal (directory #p".")
  60                  (directory (make-pathname
  61                              :name :unspecific
  62                              :type :unspecific)))))
  63
  64 ;;; This used to signal a TYPE-ERROR.
  65 (with-test (:name (directory :..*))
  66   (directory "somedir/..*"))
  67
  68 (with-test (:name (directory *default-pathname-defaults* :bug-1740563))
  69   (with-test-directory ()
  70     (close (open "a.txt" :if-does-not-exist :create))
  71     (close (open "b.lisp" :if-does-not-exist :create))
  72     (flet ((directory* (pattern &rest d-p-d-components)
  73              (let ((*default-pathname-defaults*
  74                      (apply #'make-pathname
  75                             :defaults *default-pathname-defaults*
  76                             d-p-d-components)))
  77                (directory pattern))))
  78       (let* ((expected-wild (directory "*.*"))
  79              (expected-one-file (directory "a.txt"))
  80              (cases '((:name nil   :type "txt")
  81                       (:name nil   :type :wild)
  82                       (:name "a"   :type nil)
  83                       (:name "a"   :type "txt")
  84                       (:name "a"   :type :wild)
  85                       (:name :wild :type nil)
  86                       (:name :wild :type :wild)
  87                       (:name :wild :type "txt"))))
  88         (dolist (components cases)
  89           (assert (equal (apply #'directory* "*.*" components)
  90                          expected-wild))
  91           (assert (equal (apply #'directory* "a.txt" components)
  92                          expected-one-file)))
  93         (assert (equal (directory* "" :name :wild :type :wild)
  94                        expected-wild))))))
  95 \f
  96 ;;;; OPEN
  97
  98 ;;; In sbcl-0.6.9 FOO-NAMESTRING functions  returned "" instead of NIL.
  99 (with-test (:name (file-namestring directory-namestring :name))
 100   (let ((pathname0 (make-pathname :host nil
 101                                   :directory
 102                                   (pathname-directory
 103                                    *default-pathname-defaults*)
 104                                   :name "getty"))
 105         (pathname1 (make-pathname :host nil
 106                                   :directory nil
 107                                   :name nil)))
 108     (assert (equal (file-namestring pathname0) "getty"))
 109     (assert (equal (directory-namestring pathname0)
 110                    (directory-namestring *default-pathname-defaults*)))
 111     (assert (equal (file-namestring pathname1) ""))
 112     (assert (equal (directory-namestring pathname1) ""))))
 113
 114 ;;; Set *default-pathname-defaults* to something other than the unix
 115 ;;; cwd, to catch functions which access the filesystem without
 116 ;;; merging properly.  We should test more functions than just OPEN
 117 ;;; here, of course
 118
 119 (with-test (:name (open *default-pathname-defaults*))
 120   (let ((*default-pathname-defaults*
 121          (make-pathname :directory
 122                         (butlast
 123                          (pathname-directory *default-pathname-defaults*))
 124                         :defaults *default-pathname-defaults*)))
 125     ;; SBCL 0.7.1.2 failed to merge on OPEN
 126     (with-open-file (i "tests/filesys.pure.lisp")
 127       (assert i))))
 128
 129 ;;; OPEN, LOAD and friends should signal an error of type FILE-ERROR
 130 ;;; if they are fed wild pathname designators; firstly, with wild
 131 ;;; pathnames that don't correspond to any files:
 132 (with-test (:name (open :wild file-error 1))
 133   (assert-error (open "non-existent*.lisp") file-error))
 134 (with-test (:name (load :wild file-error 1))
 135   (assert-error (load "non-existent*.lisp") file-error))
 136 ;;; then for pathnames that correspond to precisely one:
 137 (with-test (:name (open :wild file-error 2))
 138   (assert-error (open "filesys.pur*.lisp") file-error))
 139 (with-test (:name (load :wild file-error 2))
 140   (assert-error (load "filesys.pur*.lisp") file-error))
 141 ;;; then for pathnames corresponding to many:
 142 (with-test (:name (open :wild file-error 3))
 143   (assert-error (open "*.lisp") file-error))
 144 (with-test (:name (load :wild file-error 3))
 145   (assert-error (load "*.lisp") file-error))
 146
 147 ;;; ANSI: FILE-LENGTH should signal an error of type TYPE-ERROR if
 148 ;;; STREAM is not a stream associated with a file.
 149 ;;;
 150 ;;; (Peter Van Eynde's ansi-test suite caught this, and Eric Marsden
 151 ;;; reported a fix for CMU CL, which was ported to sbcl-0.6.12.35.)
 152 (with-test (:name (file-length *terminal-io* type-error))
 153   (assert-error (file-length *terminal-io*) type-error))
 154
 155 (with-test (:name (file-length synonym-stream))
 156   (with-open-file (*stream* "filesys.pure.lisp" :direction :input)
 157     (declare (special *stream*))
 158     (assert (integerp (file-length (make-synonym-stream '*stream*))))
 159     (let ((*stream2* (make-synonym-stream '*stream*)))
 160       (declare (special *stream2*))
 161       (assert (integerp (file-length (make-synonym-stream '*stream2*)))))))
 162
 163 ;;; A few cases Windows does have enough marbles to pass right now
 164 (with-test (:name (sb-ext:native-namestring :win32)
 165                   :skipped-on (not :win32))
 166   (assert (equal "C:\\FOO" (native-namestring "C:\\FOO")))
 167   (assert (equal "C:\\FOO" (native-namestring "C:/FOO")))
 168   (assert (equal "C:\\FOO\\BAR" (native-namestring "C:\\FOO\\BAR")))
 169   (assert (equal "C:\\FOO\\BAR" (native-namestring "C:\\FOO\\BAR\\" :as-file t))))
 170
 171 (with-test (:name (sb-ext:parse-native-namestring :as-directory :junk-allowed))
 172   (assert
 173    (equal
 174     (parse-native-namestring "foo.lisp" nil *default-pathname-defaults*
 175                              :as-directory t)
 176     (parse-native-namestring "foo.lisp" nil *default-pathname-defaults*
 177                              :as-directory t
 178                              :junk-allowed t))))
 179
 180 ;;; Test for NATIVE-PATHNAME / NATIVE-NAMESTRING stuff
 181 ;;;
 182 ;;; given only safe characters in the namestring, NATIVE-PATHNAME will
 183 ;;; never error, and NATIVE-NAMESTRING on the result will return the
 184 ;;; original namestring.
 185 (with-test (:name (sb-ext:native-namestring sb-ext:native-pathname :random))
 186   (let ((safe-chars
 187          (coerce
 188           (cons #\Newline
 189                 (loop for x from 32 to 127 collect (code-char x)))
 190           'simple-base-string))
 191         (tricky-sequences #("/../" "../" "/.." "." "/." "./" "/./"
 192                             "[]" "*" "**" "/**" "**/" "/**/" "?"
 193                             "\\*" "\\[]" "\\?" "\\*\\*" "*\\*")))
 194    (labels ((canon (s)
 195               #+win32
 196               ;; We canonicalize to \ as the directory separator
 197               ;; on windows -- though both \ and / are legal.
 198               (substitute #\\ #\/ s)
 199               #+unix
 200               ;; Consecutive separators become a single separator
 201               (let ((p (search "//" s)))
 202                 (if p
 203                     (canon (concatenate 'string (subseq s 0 p) (subseq s (1+ p))))
 204                     s))))
 205     (loop for length = (random 32)
 206           for native-namestring = (coerce
 207                                    (loop repeat length
 208                                          collect
 209                                          (char safe-chars
 210                                                (random (length safe-chars))))
 211                                    'simple-base-string)
 212           for pathname = (native-pathname native-namestring)
 213           for nnn = (native-namestring pathname)
 214           repeat 1000
 215           do (setf native-namestring (canon native-namestring))
 216              (unless (string= nnn native-namestring)
 217                (error "1: wanted ~S, got ~S" native-namestring nnn)))
 218     (loop for native-namestring = (with-output-to-string (s)
 219                                     (write-string "mu" s)
 220                                     (loop
 221                                       (let ((r (random 1.0)))
 222                                         (cond
 223                                           ((< r 1/20) (return))
 224                                           ((< r 1/2)
 225                                            (write-char
 226                                             (char safe-chars
 227                                                   (random (length safe-chars)))
 228                                             s))
 229                                           (t (write-string
 230                                               (aref tricky-sequences
 231                                                     (random
 232                                                      (length tricky-sequences)))
 233                                               s))))))
 234           for pathname = (native-pathname native-namestring)
 235           for tricky-nnn = (native-namestring pathname)
 236           repeat 1000
 237           do (setf native-namestring (canon native-namestring))
 238              (unless (string= tricky-nnn native-namestring)
 239                (error "2: wanted ~S, got ~S" native-namestring tricky-nnn))))))
 240
 241 ;;; USER-HOMEDIR-PATHNAME and the extension SBCL-HOMEDIR-PATHNAME both
 242 ;;; used to call PARSE-NATIVE-NAMESTRING without supplying a HOST
 243 ;;; argument, and so would lose when *DEFAULT-PATHNAME-DEFAULTS* was a
 244 ;;; logical pathname.
 245 (with-test (:name (user-homedir-pathname :robustness))
 246   (let ((*default-pathname-defaults* (pathname "SYS:")))
 247     (assert (not (typep (user-homedir-pathname)
 248                         'logical-pathname)))))
 249
 250 (with-test (:name (sb-int:sbcl-homedir-pathname :robustness))
 251   (let ((*default-pathname-defaults* (pathname "SYS:")))
 252     (assert (not (typep (sb-int:sbcl-homedir-pathname)
 253                         'logical-pathname)))))
 254
 255 (with-test (:name (file-author stringp))
 256   #-win32
 257   (assert (stringp (file-author (user-homedir-pathname))))
 258   #+win32
 259   (assert (not (file-author (user-homedir-pathname)))))
 260 (with-test (:name (file-write-date integerp))
 261   (assert (integerp (file-write-date (user-homedir-pathname)))))
 262
 263 ;;; Generated with
 264 ;;; (loop for exist in '(nil t)
 265 ;;;       append
 266 ;;;       (loop for (if-exists if-does-not-exist) in '((nil :error)
 267 ;;;                                                    (:error nil)
 268 ;;;                                                    (nil nil)
 269 ;;;                                                    (:error :error))
 270 ;;;             collect (list 'do-open exist if-exists if-does-not-exist)))
 271 (with-test (:name (open :never-openning))
 272   (flet ((do-open (existing if-exists if-does-not-exist
 273                    &optional (direction :output))
 274            (open (if existing
 275                      #.(or *compile-file-truename* *load-truename*)
 276                      "a-really-non-existing-file")
 277                  :direction direction
 278                  :if-exists if-exists :if-does-not-exist if-does-not-exist)))
 279     (assert-error (do-open nil nil :error) file-error)
 280     (assert (not (do-open nil :error nil)))
 281     (assert (not (do-open t nil :error)))
 282     (assert-error (do-open t :error nil) file-error)
 283     (assert (not (do-open nil nil nil)))
 284     (assert-error (do-open nil :error :error) file-error)
 285     (assert (not (do-open t nil nil)))
 286     (assert-error (do-open t :error :error))
 287
 288     (assert-error (do-open nil nil :error :io) file-error)
 289     (assert (not (do-open nil :error nil :io)))
 290     (assert (not (do-open t nil :error :io)))
 291     (assert-error (do-open t :error nil :io) file-error)
 292     (assert (not (do-open nil nil nil :io)))
 293     (assert-error (do-open nil :error :error :io) file-error)
 294     (assert (not (do-open t nil nil :io)))
 295     (assert-error (do-open t :error :error :io) file-error)))
 296
 297 (with-test (:name (open :new-version))
 298   (multiple-value-bind (value error)
 299       (ignore-errors (open #.(or *compile-file-truename* *load-truename*)
 300                            :direction :output
 301                            :if-exists :new-version))
 302     (assert (not value))
 303     (assert error)
 304     (let ((control (simple-condition-format-control error)))
 305       (assert (search "OPEN :IF-EXISTS :NEW-VERSION is not supported" control))
 306       (assert (search "when a new version must be created." control)))))
 307
 308 (with-test (:name (parse-native-namestring :canon) :skipped-on (not :unix))
 309   (let ((pathname (parse-native-namestring "foo/bar//baz")))
 310     (assert (string= (car (last (pathname-directory pathname))) "bar"))))
 311
 312 \f
 313 ;;;; DELETE-DIRECTORY
 314
 315 (with-test (:name (delete-directory :as-file :complicated-name-or-type :bug-1740624))
 316   ;; This test creates directories whose names are in some way
 317   ;; complicated to express as the filename part of a pathname, for
 318   ;; example by including characters that need escaping in namestrings
 319   ;; or looking like a :type component without a :name
 320   ;; component. DELETE-DIRECTORY is applied to pathnames with filename
 321   ;; parts to delete these directories. The intention is testing the
 322   ;; translation from filename part to directory component employed by
 323   ;; DELETE-DIRECTORY.
 324   (labels ((prepare (string)
 325              #-win32 (substitute #\\ #\E string)
 326              #+win32 (substitute #\^ #\E string))
 327            (make-type (type)
 328              (make-pathname :type (prepare type)))
 329            (make-unspecific (namep typep)
 330              (apply #'make-pathname
 331                     :directory '(:relative "foo")
 332                     (append (when namep '(:name :unspecific))
 333                             (when typep '(:type :unspecific)))))
 334            (test (as-file as-directory)
 335              (with-test-directory (test-directory)
 336                (let ((delete-directory (merge-pathnames
 337                                          (typecase as-file
 338                                            (string (prepare as-file))
 339                                            (pathname as-file))
 340                                          test-directory)))
 341                  (ensure-directories-exist (merge-pathnames
 342                                             (prepare as-directory)
 343                                             test-directory))
 344                  (delete-directory delete-directory)
 345                  (assert (not (probe-file (prepare as-directory))))))))
 346     ;; Name component present
 347     #-win32 (test "aE?b"                    "aE?b/")
 348     #-win32 (test "aE*b"                    "aE*b/")
 349             (test "aE[cd]b"                 "aE[cd]b/")
 350             (test "aEEb"                    "aEEb/")
 351     ;; Type component
 352     #-win32 (test (make-type "a?b")         ".aE?b/")
 353     #-win32 (test (make-type "a*b")         ".aE*b/")
 354             (test (make-type "a[cd]b")      ".aE[cd]b/")
 355             (test (make-type "aEb")         ".aEEb/")
 356     ;; Name and type components present
 357     #-win32 (test "foo.aE?b"                "foo.aE?b/")
 358     #-win32 (test "foo.aE*b"                "foo.aE*b/")
 359             (test "foo.aE[cd]b"             "foo.aE[cd]b/")
 360             (test "foo.aEEb"                "foo.aEEb/")
 361     ;; Name and/or type :unspecific
 362             (test (make-unspecific nil nil) "foo/")
 363             (test (make-unspecific nil t)   "foo/")
 364             (test (make-unspecific t   nil) "foo/")
 365             (test (make-unspecific t   t)   "foo/")))
 366
 367 (with-test (:name (rename-file :overwrite))
 368   (with-test-directory ()
 369     (with-open-file (s "a" :direction :output)
 370       (write-line "a" s))
 371     (with-open-file (s "b" :direction :output)
 372       (write-line "b" s))
 373     (rename-file "a" "b")
 374     (assert (null (probe-file "a")))
 375     (with-open-file (s "b")
 376       (assert (equal "a" (read-line s))))))