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