diff --git a/test/script-support.lisp b/test/script-support.lisp index e82e1d155fa616b5f472225c1e9fe4877fd110eb..0a70c05f042d4c325833c6e10f7d63133527590d 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -457,7 +457,7 @@ is bound, write a message and exit on an error. If (null "1.0")))))) (defun output-location (&rest sublocation) - (list* *asdf-directory* "build/fasls" :implementation sublocation)) + (list* *asdf-directory* "build/fasls" :implementation-type sublocation)) (defun resolve-output (&rest sublocation) (acall :resolve-location (apply 'output-location sublocation))) diff --git a/test/test-module-pathnames.script b/test/test-module-pathnames.script index 1aeb3868d49ca7136d9ef712920c121e7d2740e6..6beaaac1c783289229039ccd975830acbcd955fe 100644 --- a/test/test-module-pathnames.script +++ b/test/test-module-pathnames.script @@ -11,7 +11,10 @@ (:static-file "level2/static.file") (:static-file "test-tmp.cl"))))) +(DBG "Loading the system") (asdf:load-system 'test-module-pathnames) + +(DBG "Checking pathnames") (flet ((pathname-foo (x) (list (or (normalize-pathname-directory-component (pathname-directory x)) '(:relative)) (pathname-name x) (pathname-type x)))) diff --git a/test/test-utilities.script b/test/test-utilities.script index 19a21f772288bdc198d05e82629f1306b87bc131..4ca98db63ba445cb82042ea1c6f16133ff19c588 100644 --- a/test/test-utilities.script +++ b/test/test-utilities.script @@ -19,28 +19,20 @@ ;; These are funky and non portable, omit from tests: ;; (make-pathname* :name "." :type nil :directory '(:absolute "tmp")) ;; (make-pathname* :name "." :type "" :directory '(:absolute "tmp")) -(assert (equal (multiple-value-list (split-unix-namestring-directory-components "" :ensure-directory t)) - '(:relative nil nil nil))) -(assert (equal (multiple-value-list (split-unix-namestring-directory-components "" :ensure-directory nil)) - '(:relative nil nil nil))) -(assert (equal (multiple-value-list (split-unix-namestring-directory-components "/" :ensure-directory t)) - '(:absolute nil nil nil))) -(assert (equal (multiple-value-list (split-unix-namestring-directory-components "/" :ensure-directory nil)) - '(:absolute nil nil nil))) -(assert (equal (multiple-value-list (split-unix-namestring-directory-components "/aa/ba" :ensure-directory t)) - '(:absolute ("aa" "ba") nil nil))) -(assert (equal (multiple-value-list (split-unix-namestring-directory-components "/aa/ba" :ensure-directory nil)) - '(:absolute ("aa") "ba" nil))) -(assert - (version-satisfies (asdf-version) (asdf-version))) -(assert - (version-satisfies (asdf-version) "3.0")) -(assert - (version-satisfies (asdf-version) "2.0")) -(assert - (version<= "2.0" (asdf-version))) -(assert - (not (version-satisfies (asdf-version) "666"))) +(macrolet ((ts (x y) + `(assert-equal (multiple-value-list (split-unix-namestring-directory-components ,@x)) + ',y))) + (ts ("" :ensure-directory t) (:relative nil nil nil)) + (ts ("" :ensure-directory nil) (:relative nil nil nil)) + (ts ("/" :ensure-directory t) (:absolute nil nil nil)) + (ts ("/" :ensure-directory nil) (:absolute nil nil nil)) + (ts ("/aa/ba" :ensure-directory t) (:absolute ("aa" "ba") nil nil)) + (ts ("/aa/ba" :ensure-directory nil) (:absolute ("aa") "ba" nil))) +(assert (version-satisfies (asdf-version) (asdf-version))) +(assert (version-satisfies (asdf-version) "3.0")) +(assert (version-satisfies (asdf-version) "2.0")) +(assert (version<= "2.0" (asdf-version))) +(assert (not (version-satisfies (asdf-version) "666"))) (assert-pathnames-equal (split-native-pathnames-string (join-namestrings '("foo" "bar"))) '(#p"foo" #p"bar")) @@ -235,10 +227,17 @@ (defparameter acrlf (strcat "a" +crlf+)) (defparameter blf (strcat "b" +lf+)) (defparameter ccr (strcat "c" +cr+)) -(assert-equal `("a" ,+crlf+) (multiple-value-list (stripln acrlf))) -(assert-equal `("b" ,+lf+) (multiple-value-list (stripln blf))) -(assert-equal `("c" ,+cr+) (multiple-value-list (stripln ccr))) -(assert-equal `(,acrlf ,+crlf+) (multiple-value-list (stripln (strcat acrlf +crlf+)))) -(assert-equal `(,blf ,+cr+) (multiple-value-list (stripln (strcat blf +cr+)))) -(assert-equal `("c" ,+crlf+) (multiple-value-list (stripln (strcat ccr +lf+)))) -(assert-equal `(,(strcat acrlf "b") ,+lf+) (multiple-value-list (stripln (strcat acrlf blf)))) +(macrolet ((ts (x y z) + `(progn + (assert-equal (list ,x ,y) (multiple-value-list (stripln ,z))) + (assert-equal (strcat ,x ,y) ,z)))) + (ts "a" +crlf+ acrlf) + (ts "b" +lf+ blf) + (ts "c" +cr+ ccr) + (ts acrlf +crlf+ (strcat acrlf +crlf+)) + (ts blf +cr+ (strcat blf +cr+)) + (ts "c" +crlf+ (strcat ccr +lf+)) + (ts (strcat acrlf "b") +lf+ (strcat acrlf blf))) + +(with-temporary-file (:stream s :direction :io :element-type 'character :prefix "LEP") + (println "Hello, World" s)) diff --git a/uiop/stream.lisp b/uiop/stream.lisp index 3f98f3e12cd55dba7641f2ea5787bdd361e7977d..c647812eca78eff0308776a45bc8f8b86958355c 100644 --- a/uiop/stream.lisp +++ b/uiop/stream.lisp @@ -546,18 +546,17 @@ The file will be open with specified DIRECTION, ELEMENT-TYPE and EXTERNAL-FORMAT ;; TODO: on Unix, do something about umask ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL ;; TODO: on Unix, use CFFI and mkstemp -- but UIOP is precisely meant to not depend on CFFI or on anything! Grrrr. - (with-open-file (stream pathname - :direction direction - :element-type element-type - #-gcl2.6 :external-format #-gcl2.6 external-format - :if-exists nil :if-does-not-exist :create) - (when stream - (return - (if keep - (funcall thunk stream pathname) - (unwind-protect - (funcall thunk stream pathname) - (ignore-errors (delete-file pathname))))))))) + (unwind-protect + (with-open-file (stream pathname + :direction direction + :element-type element-type + #-gcl2.6 :external-format #-gcl2.6 external-format + :if-exists nil :if-does-not-exist :create) + (if stream + (return (funcall thunk stream pathname)) + (setf pathname nil))) + (when (and pathname (not keep)) + (ignore-errors (delete-file pathname)))))) (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp) (pathname (gensym "PATHNAME") pathnamep)