diff --git a/test/test-utilities.script b/test/test-utilities.script index b7260a55fb78f1738c10fa07e9adafdcc16f202d..5002cbff8a7a5515efdaa74266cb6ff8dbbf2a3e 100644 --- a/test/test-utilities.script +++ b/test/test-utilities.script @@ -302,34 +302,29 @@ (ts "c" +crlf+ (strcat ccr +lf+)) (ts (strcat acrlf "b") +lf+ (strcat acrlf blf))) -(DBG :wtf-s) -(with-temporary-file (:stream s :direction :io :prefix "LEP") +(DBG "testing with-temporary-file") +(with-temporary-file (:stream s :direction :io :prefix "WTF0") (println "Hello, World" s) (file-position s 0) (assert-equal (read-line s) "Hello, World")) -(DBG :wtf-p) -(let ((pn - (with-temporary-file (:pathname pn :direction :output :prefix "LEP") - (assert-equal (read-file-lines pn) ()) - pn))) - (assert (not (probe-file pn)))) - -(DBG :wtf-s-p) -(let ((pn - (with-temporary-file (:stream s :pathname p :keep t :direction :io :prefix "LEP") - (println "Hello, World" s) - (DBG :wsp s p (probe-file p)) - p))) - (assert-equal (read-file-lines pn) '("Hello, World")) - (delete-file pn)) +(let ((pn1 (with-temporary-file (:pathname pn :direction :output :prefix "WTF1") + (assert-equal (read-file-lines pn) ()) + pn))) + (assert (not (probe-file pn1)))) +(let ((pn2 (with-temporary-file (:stream s :pathname p :keep t :direction :io :prefix "WTF2") + (println "Hello, World" s) + p))) + (assert-equal (read-file-lines pn2) '("Hello, World")) + (delete-file pn2)) + +#-gcl ;; BUG in GCL compiling the WTF internal loop. Works if loaded without compiling. (assert (not (probe-file (let ((s 'outer-s)) - (with-temporary-file (:stream s :pathname p :direction :io :prefix "LEP") + (with-temporary-file (:stream s :pathname p :direction :io :prefix "WTF3") (assert (open-stream-p s)) - (DBG :wsp s p (probe-file p)) (println "Same thing with :close-stream" s) :close-stream (assert-equal s 'outer-s) ;; the stream s (1) has been closed and (2) is no longer in scope. diff --git a/uiop/stream.lisp b/uiop/stream.lisp index 6c1840148b0c6893d4f34876bc08789de2eaa806..a31a00141e1ccd4e8e02d4eafc014b3935ee3ccc 100644 --- a/uiop/stream.lisp +++ b/uiop/stream.lisp @@ -601,17 +601,17 @@ Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'e (when stream (setf okp pathname) (when want-stream-p - (setf results - (multiple-value-list - (if want-pathname-p - (funcall thunk stream pathname) - (funcall thunk stream))))))) - (when okp - (unless want-stream-p - (setf results (multiple-value-list (call-function thunk pathname)))) - (when after - (setf results (multiple-value-list (call-function after pathname)))) - (return (apply 'values results)))) + ;; Note: can't return directly from within with-open-file + ;; or the non-local return causes the file creation to be undone. + (setf results (multiple-value-list + (if want-pathname-p + (funcall thunk stream pathname) + (funcall thunk stream))))))) + (cond + ((not okp) nil) + (after (return (call-function after okp))) + ((and want-pathname-p (not want-stream-p)) (return (call-function thunk okp))) + (t (return (apply 'values results))))) (when (and okp (not (call-function keep))) (ignore-errors (delete-file-if-exists okp))))))