Commit 09a0fe12 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

More tweaks (and tests) for with-temporary-file, and change run-program accordingly.

parent 89860149
...@@ -245,5 +245,24 @@ ...@@ -245,5 +245,24 @@
(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)
(with-temporary-file (:stream s :direction :io :prefix "LEP") (with-temporary-file (:stream s :direction :io :prefix "LEP")
(println "Hello, World" s)) (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))
...@@ -611,22 +611,20 @@ It returns a process-info plist with possible keys: ...@@ -611,22 +611,20 @@ It returns a process-info plist with possible keys:
(hard-case () (hard-case ()
(if activep (if activep
(funcall fun :stream #'activity) (funcall fun :stream #'activity)
(with-temporary-file (:pathname tmp :stream s (with-temporary-file (:pathname tmp)
:direction (ecase direction
((:input) :output)
((:output :error-output) :io))
:element-type element-type
:external-format external-format)
(ecase direction (ecase direction
(:input (:input
(unwind-protect (activity s) (with-output-file (s tmp :if-exists :overwrite
(ignore-errors (close s))) :external-format external-format
:element-type element-type)
(activity s))
(funcall fun tmp nil)) (funcall fun tmp nil))
((:output :error-output) ((:output :error-output)
(unwind-protect (multiple-value-prog1 (funcall fun tmp nil)
(multiple-value-prog1 (funcall fun tmp nil) (with-input-file (s tmp
(activity s)) :external-format external-format
(ignore-errors (close s))))))))) :element-type element-type)
(activity s)))))))))
(typecase activity-spec (typecase activity-spec
((or null string pathname (eql :interactive)) ((or null string pathname (eql :interactive))
(easy-case)) (easy-case))
......
...@@ -533,6 +533,7 @@ If a string, repeatedly read and evaluate from it, returning the last values." ...@@ -533,6 +533,7 @@ If a string, repeatedly read and evaluate from it, returning the last values."
(defun call-with-temporary-file (defun call-with-temporary-file
(thunk &key (thunk &key
(want-stream-p t) (want-pathname-p t)
prefix keep (direction :io) prefix keep (direction :io)
(element-type *default-stream-element-type*) (element-type *default-stream-element-type*)
(external-format *utf-8-external-format*)) (external-format *utf-8-external-format*))
...@@ -542,24 +543,37 @@ This utility will KEEP the file past its extent if and only if explicitly reques ...@@ -542,24 +543,37 @@ This utility will KEEP the file past its extent if and only if explicitly reques
The file will be open with specified DIRECTION, ELEMENT-TYPE and EXTERNAL-FORMAT." The file will be open with specified DIRECTION, ELEMENT-TYPE and EXTERNAL-FORMAT."
#+gcl2.6 (declare (ignorable external-format)) #+gcl2.6 (declare (ignorable external-format))
(check-type direction (member :output :io)) (check-type direction (member :output :io))
(assert (or want-stream-p want-pathname-p))
(loop (loop
:with prefix = (namestring (ensure-absolute-pathname (or prefix "tmp") #'temporary-directory)) :with prefix = (namestring (ensure-absolute-pathname (or prefix "tmp") #'temporary-directory))
:with results = ()
:for counter :from (random (ash 1 32)) :for counter :from (random (ash 1 32))
:for pathname = (pathname (format nil "~A~36R" prefix counter)) :do :for pathname = (pathname (format nil "~A~36R" prefix counter))
:for okp = nil :do
;; TODO: on Unix, do something about umask ;; 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, 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. ;; TODO: on Unix, use CFFI and mkstemp -- but UIOP is precisely meant to not depend on CFFI or on anything! Grrrr.
(unwind-protect (unwind-protect
(with-open-file (stream pathname (progn
:direction direction (with-open-file (stream pathname
:element-type element-type :direction direction
#-gcl2.6 :external-format #-gcl2.6 external-format :element-type element-type
:if-exists nil :if-does-not-exist :create) #-gcl2.6 :external-format #-gcl2.6 external-format
(if stream :if-exists nil :if-does-not-exist :create)
(return (funcall thunk stream pathname)) (when stream
(setf pathname nil))) (setf okp pathname)
(when (and pathname (not keep)) (when want-stream-p
(ignore-errors (delete-file pathname)))))) (setf results
(multiple-value-list
(if want-pathname-p
(funcall thunk stream pathname)
(funcall thunk stream)))))))
(when okp
(if want-stream-p
(return (apply 'values results))
(return (funcall thunk pathname)))))
(when (and okp (not keep))
(ignore-errors (delete-file-if-exists okp))))))
(defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp) (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
(pathname (gensym "PATHNAME") pathnamep) (pathname (gensym "PATHNAME") pathnamep)
...@@ -572,19 +586,24 @@ The STREAM will be closed if no binding is specified. ...@@ -572,19 +586,24 @@ The STREAM will be closed if no binding is specified.
Unless KEEP is specified, delete the file afterwards." Unless KEEP is specified, delete the file afterwards."
(check-type stream symbol) (check-type stream symbol)
(check-type pathname symbol) (check-type pathname symbol)
`(flet ((think (,stream ,pathname) (assert (or streamp pathnamep))
,@(unless pathnamep `((declare (ignore ,pathname)))) `(flet ((think (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname)))
,@(unless streamp `((when ,stream (close ,stream))))
,@body)) ,@body))
#-gcl (declare (dynamic-extent #'think)) #-gcl (declare (dynamic-extent #'think))
(call-with-temporary-file (call-with-temporary-file
#'think #'think
:want-stream-p ,streamp
:want-pathname-p ,pathnamep
,@(when direction `(:direction ,direction)) ,@(when direction `(:direction ,direction))
,@(when prefix `(:prefix ,prefix)) ,@(when prefix `(:prefix ,prefix))
,@(when keep `(:keep ,keep)) ,@(when keep `(:keep ,keep))
,@(when element-type `(:element-type ,element-type)) ,@(when element-type `(:element-type ,element-type))
,@(when external-format `(:external-format ,external-format))))) ,@(when external-format `(:external-format ,external-format)))))
(defun get-temporary-file (&key prefix)
(with-temporary-file (:pathname pn :keep t :prefix prefix)
pn))
;; Temporary pathnames in simple cases where no contention is assumed ;; Temporary pathnames in simple cases where no contention is assumed
(defun add-pathname-suffix (pathname suffix) (defun add-pathname-suffix (pathname suffix)
"Add a SUFFIX to the name of a PATHNAME, return a new pathname" "Add a SUFFIX to the name of a PATHNAME, return a new pathname"
......
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