(assert (typep (nth-value 1 (ignore-errors (file-length *terminal-io*)))
'type-error))
+;;; A few cases Windows does have enough marbles to pass right now
+#+win32
+(progn
+ (assert (equal "C:\\FOO" (native-namestring "C:\\FOO")))
+ (assert (equal "C:\\FOO" (native-namestring "C:/FOO")))
+ (assert (equal "C:\\FOO\\BAR" (native-namestring "C:\\FOO\\BAR")))
+ (assert (equal "C:\\FOO\\BAR" (native-namestring "C:\\FOO\\BAR\\" :as-file t))))
+
+(with-test (:name (:parse-native-pathname :as-directory :junk-allowed))
+ (assert
+ (equal
+ (parse-native-namestring "foo.lisp" nil *default-pathname-defaults*
+ :as-directory t)
+ (parse-native-namestring "foo.lisp" nil *default-pathname-defaults*
+ :as-directory t
+ :junk-allowed t))))
+
;;; Test for NATIVE-PATHNAME / NATIVE-NAMESTRING stuff
;;;
;;; given only safe characters in the namestring, NATIVE-PATHNAME will
;;; never error, and NATIVE-NAMESTRING on the result will return the
;;; original namestring.
-(let ((safe-chars
- ;; for WIN32, we might want to remove #\: here
- (coerce
- (cons #\Newline
- (loop for x from 32 to 127 collect (code-char x)))
- 'simple-base-string))
- (tricky-sequences #("/../" "../" "/.." "." "/." "./" "/./"
- "[]" "*" "**" "/**" "**/" "/**/" "?"
- "\\*" "\\[]" "\\?" "\\*\\*" "*\\*")))
- (loop repeat 1000
- for length = (random 32)
- for native-namestring = (coerce
- (loop repeat length
- collect
- (char safe-chars
- (random (length safe-chars))))
- 'simple-base-string)
- for pathname = (native-pathname native-namestring)
- for nnn = (native-namestring pathname)
- do (assert (string= nnn native-namestring)))
- (loop repeat 1000
- for native-namestring = (with-output-to-string (s)
- (loop
- (let ((r (random 1.0)))
- (cond
- ((< r 1/20) (return))
- ((< r 1/2)
- (write-char
+(with-test (:name :random-native-namestrings)
+ (let ((safe-chars
+ (coerce
+ (cons #\Newline
+ (loop for x from 32 to 127 collect (code-char x)))
+ 'simple-base-string))
+ (tricky-sequences #("/../" "../" "/.." "." "/." "./" "/./"
+ "[]" "*" "**" "/**" "**/" "/**/" "?"
+ "\\*" "\\[]" "\\?" "\\*\\*" "*\\*")))
+ (loop repeat 1000
+ for length = (random 32)
+ for native-namestring = (coerce
+ (loop repeat length
+ collect
(char safe-chars
- (random (length safe-chars)))
- s))
- (t (write-string
- (aref tricky-sequences
- (random
- (length tricky-sequences)))
- s))))))
- for pathname = (native-pathname native-namestring)
- for nnn = (native-namestring pathname)
- do (assert (string= nnn native-namestring))))
+ (random (length safe-chars))))
+ 'simple-base-string)
+ for pathname = (native-pathname native-namestring)
+ for nnn = (native-namestring pathname)
+ do #+win32
+ ;; We canonicalize to \ as the directory separator
+ ;; on windows -- though both \ and / are legal.
+ (setf native-namestring (substitute #\\ #\/ native-namestring))
+ (unless (string= nnn native-namestring)
+ (error "1: wanted ~S, got ~S" native-namestring nnn)))
+ (loop repeat 1000
+ for native-namestring = (with-output-to-string (s)
+ (write-string "mu" s)
+ (loop
+ (let ((r (random 1.0)))
+ (cond
+ ((< r 1/20) (return))
+ ((< r 1/2)
+ (write-char
+ (char safe-chars
+ (random (length safe-chars)))
+ s))
+ (t (write-string
+ (aref tricky-sequences
+ (random
+ (length tricky-sequences)))
+ s))))))
+ for pathname = (native-pathname native-namestring)
+ for tricky-nnn = (native-namestring pathname)
+ do #+win32
+ ;; We canonicalize to \ as the directory separator
+ ;; on windows -- though both \ and / are legal.
+ (setf native-namestring (substitute #\\ #\/ native-namestring))
+ (unless (string= tricky-nnn native-namestring)
+ (error "2: wanted ~S, got ~S" native-namestring tricky-nnn)))))
+
+;;; USER-HOMEDIR-PATHNAME and the extension SBCL-HOMEDIR-PATHNAME both
+;;; used to call PARSE-NATIVE-NAMESTRING without supplying a HOST
+;;; argument, and so would lose when *DEFAULT-PATHNAME-DEFAULTS* was a
+;;; logical pathname.
+(with-test (:name :user-homedir-pathname-robustness)
+ (let ((*default-pathname-defaults* (pathname "SYS:")))
+ (assert (not (typep (user-homedir-pathname)
+ 'logical-pathname)))))
+
+(with-test (:name :sbcl-homedir-pathname-robustness)
+ (let ((*default-pathname-defaults* (pathname "SYS:")))
+ (assert (not (typep (sb-impl::sbcl-homedir-pathname)
+ 'logical-pathname)))))
+
+(with-test (:name :file-author-stringp)
+ #-win32
+ (assert (stringp (file-author (user-homedir-pathname))))
+ #+win32
+ (assert (not (file-author (user-homedir-pathname)))))
+(with-test (:name :file-write-date-integerp)
+ (assert (integerp (file-write-date (user-homedir-pathname)))))
+
+;;; Canonicalization of pathnames for DIRECTORY
+(with-test (:name :directory-/.)
+ (assert (equal (directory #p".") (directory #p"./")))
+ (assert (equal (directory #p".") (directory #p""))))
+(with-test (:name :directory-/..)
+ (assert (equal (directory #p"..") (directory #p"../"))))
+(with-test (:name :directory-unspecific)
+ (assert (equal (directory #p".")
+ (directory (make-pathname
+ :name :unspecific
+ :type :unspecific)))))
+
+;;; Generated with
+;;; (loop for exist in '(nil t)
+;;; append
+;;; (loop for (if-exists if-does-not-exist) in '((nil :error)
+;;; (:error nil)
+;;; (nil nil)
+;;; (:error :error))
+;;; collect (list 'do-open exist if-exists if-does-not-exist)))
+(with-test (:name :open-never-openning)
+ (flet ((do-open (existing if-exists if-does-not-exist
+ &optional (direction :output))
+ (open (if existing
+ #.(or *compile-file-truename* *load-truename*)
+ "a-really-non-existing-file")
+ :direction direction
+ :if-exists if-exists :if-does-not-exist if-does-not-exist)))
+ (assert (raises-error?
+ (do-open nil nil :error)))
+ (assert (not
+ (do-open nil :error nil)))
+ (assert (not
+ (do-open t nil :error)))
+ (assert (raises-error?
+ (do-open t :error nil)))
+ (assert (not
+ (do-open nil nil nil)))
+ (assert (raises-error?
+ (do-open nil :error :error)))
+ (assert (not
+ (do-open t nil nil)))
+ (assert (raises-error? (do-open t :error :error)))
+
+ (assert (raises-error?
+ (do-open nil nil :error :io)))
+ (assert (not
+ (do-open nil :error nil :io)))
+ (assert (not
+ (do-open t nil :error :io)))
+ (assert (raises-error?
+ (do-open t :error nil :io)))
+ (assert (not
+ (do-open nil nil nil :io)))
+ (assert (raises-error?
+ (do-open nil :error :error :io)))
+ (assert (not
+ (do-open t nil nil :io)))
+ (assert (raises-error? (do-open t :error :error :io)))))
+
+(with-test (:name :open-new-version)
+ (multiple-value-bind (value error)
+ (ignore-errors (open #.(or *compile-file-truename* *load-truename*)
+ :direction :output
+ :if-exists :new-version))
+ (assert (not value))
+ (assert error)
+ (assert (equal (simple-condition-format-control error)
+ "OPEN :IF-EXISTS :NEW-VERSION is not supported ~
+ when a new version must be created."))))
projects / sbcl.git / blobdiff