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
......@@ -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.
......
......@@ -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))))))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment