Skip to content
Snippets Groups Projects
Commit 623bf535 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Tweak with-temporary-file and its tests.

One WTF test fails on GCL, due to a compiler bug.
parent 3a5927e6
No related branches found
No related tags found
No related merge requests found
...@@ -302,34 +302,29 @@ ...@@ -302,34 +302,29 @@
(ts "c" +crlf+ (strcat ccr +lf+)) (ts "c" +crlf+ (strcat ccr +lf+))
(ts (strcat acrlf "b") +lf+ (strcat acrlf blf))) (ts (strcat acrlf "b") +lf+ (strcat acrlf blf)))
(DBG :wtf-s) (DBG "testing with-temporary-file")
(with-temporary-file (:stream s :direction :io :prefix "LEP") (with-temporary-file (:stream s :direction :io :prefix "WTF0")
(println "Hello, World" s) (println "Hello, World" s)
(file-position s 0) (file-position s 0)
(assert-equal (read-line s) "Hello, World")) (assert-equal (read-line s) "Hello, World"))
(DBG :wtf-p) (let ((pn1 (with-temporary-file (:pathname pn :direction :output :prefix "WTF1")
(let ((pn (assert-equal (read-file-lines pn) ())
(with-temporary-file (:pathname pn :direction :output :prefix "LEP") pn)))
(assert-equal (read-file-lines pn) ()) (assert (not (probe-file pn1))))
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 ((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 (assert
(not (probe-file (not (probe-file
(let ((s 'outer-s)) (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)) (assert (open-stream-p s))
(DBG :wsp s p (probe-file p))
(println "Same thing with :close-stream" s) (println "Same thing with :close-stream" s)
:close-stream :close-stream
(assert-equal s 'outer-s) ;; the stream s (1) has been closed and (2) is no longer in scope. (assert-equal s 'outer-s) ;; the stream s (1) has been closed and (2) is no longer in scope.
......
...@@ -601,17 +601,17 @@ Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'e ...@@ -601,17 +601,17 @@ Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'e
(when stream (when stream
(setf okp pathname) (setf okp pathname)
(when want-stream-p (when want-stream-p
(setf results ;; Note: can't return directly from within with-open-file
(multiple-value-list ;; or the non-local return causes the file creation to be undone.
(if want-pathname-p (setf results (multiple-value-list
(funcall thunk stream pathname) (if want-pathname-p
(funcall thunk stream))))))) (funcall thunk stream pathname)
(when okp (funcall thunk stream)))))))
(unless want-stream-p (cond
(setf results (multiple-value-list (call-function thunk pathname)))) ((not okp) nil)
(when after (after (return (call-function after okp)))
(setf results (multiple-value-list (call-function after pathname)))) ((and want-pathname-p (not want-stream-p)) (return (call-function thunk okp)))
(return (apply 'values results)))) (t (return (apply 'values results)))))
(when (and okp (not (call-function keep))) (when (and okp (not (call-function keep)))
(ignore-errors (delete-file-if-exists okp)))))) (ignore-errors (delete-file-if-exists okp))))))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment