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

Enhance WITH-TEMPORARY-FILE. Robustify TRUENAMIZE for GCL.

parent 33b25631
No related branches found
No related tags found
No related merge requests found
...@@ -266,13 +266,19 @@ and recurse each of its subdirectories on which the RECURSEP returns true when C ...@@ -266,13 +266,19 @@ and recurse each of its subdirectories on which the RECURSEP returns true when C
(down-components ())) (down-components ()))
(assert (eq :absolute (first directory))) (assert (eq :absolute (first directory)))
(loop :while up-components :do (loop :while up-components :do
(if-let (parent (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components)) (if-let (parent
:name nil :type nil :version nil :defaults p))) (ignore-errors
(return (merge-pathnames* (make-pathname* :directory `(:relative ,@down-components) (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components))
:defaults p) :name nil :type nil :version nil :defaults p))))
(ensure-directory-pathname parent))) (if-let (simplified
(push (pop up-components) down-components)) (ignore-errors
:finally (return p)))))) (merge-pathnames*
(make-pathname* :directory `(:relative ,@down-components)
:defaults p)
(ensure-directory-pathname parent))))
(return simplified)))
(push (pop up-components) down-components)
:finally (return p))))))
(defun resolve-symlinks (path) (defun resolve-symlinks (path)
"Do a best effort at resolving symlinks in PATH, returning a partially or totally resolved PATH." "Do a best effort at resolving symlinks in PATH, returning a partially or totally resolved PATH."
......
...@@ -530,25 +530,41 @@ If a string, repeatedly read and evaluate from it, returning the last values." ...@@ -530,25 +530,41 @@ 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) (want-stream-p t) (want-pathname-p t) (direction :io) keep after
prefix keep (direction :io) directory prefix suffix type
(element-type *default-stream-element-type*) (element-type *default-stream-element-type*)
(external-format *utf-8-external-format*)) (external-format *utf-8-external-format*))
"Call a THUNK with STREAM and PATHNAME arguments identifying a temporary file. "Call a THUNK with stream and/or pathname arguments identifying a temporary file.
The pathname will be based on appending a random suffix to PREFIX.
This utility will KEEP the file past its extent if and only if explicitly requested. The temporary file's pathname will be based on concatenating
The file will be open with specified DIRECTION, ELEMENT-TYPE and EXTERNAL-FORMAT." PREFIX (defaults to \"tmp\"), a random alphanumeric string, and optional SUFFIX and TYPE,
within DIRECTORY (defaulting to the TEMPORARY-DIRECTORY) if the PREFIX isn't absolute.
The file will be open with specified DIRECTION (defaults to :IO),
ELEMENT-TYPE (defaults to *DEFAULT-STREAM-ELEMENT-TYPE*) and
EXTERNAL-FORMAT (defaults to *UTF-8-EXTERNAL-FORMAT*).
If WANT-STREAM-P is true (the defaults to T), then THUNK will then be CALL-FUNCTION'ed
with the stream and the pathname (if WANT-PATHNAME-P is true, defaults to T),
and stream with be closed after the THUNK exits (either normally or abnormally).
If WANT-STREAM-P is false, then WANT-PATHAME-P must be true, and then
THUNK is only CALL-FUNCTION'ed after the stream is closed, with the pathname as argument.
Upon exit of THUNK, the AFTER thunk if defined is CALL-FUNCTION'ed with the pathname as argument.
If AFTER is defined, its results are returned, otherwise, the results of THUNK are returned.
Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'ed returns true."
(check-type direction (member :output :io)) (check-type direction (member :output :io))
(assert (or want-stream-p want-pathname-p)) (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")
(or directory #'temporary-directory)))
:with results = () :with results = ()
:for counter :from (random (ash 1 32)) :for counter :from (random (expt 36 8))
:for pathname = (pathname (format nil "~A~36R" prefix counter)) :for pathname = (pathname (format nil "~A~36R~@[~A~]~@[.~A~]" prefix counter suffix type))
:for okp = nil :do :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 --
;; except UIOP is precisely meant to not depend on CFFI or on anything! Grrrr.
;; Can we at least design some hook?
(unwind-protect (unwind-protect
(progn (progn
(with-open-file (stream pathname (with-open-file (stream pathname
...@@ -565,50 +581,71 @@ The file will be open with specified DIRECTION, ELEMENT-TYPE and EXTERNAL-FORMAT ...@@ -565,50 +581,71 @@ The file will be open with specified DIRECTION, ELEMENT-TYPE and EXTERNAL-FORMAT
(funcall thunk stream pathname) (funcall thunk stream pathname)
(funcall thunk stream))))))) (funcall thunk stream)))))))
(when okp (when okp
(if want-stream-p (unless want-stream-p
(return (apply 'values results)) (setf results (multiple-value-list (call-function thunk pathname))))
(return (funcall thunk pathname))))) (when after
(when (and okp (not keep)) (setf results (multiple-value-list (call-function after pathname))))
(return (apply 'values results))))
(when (and okp (not (call-function keep)))
(ignore-errors (delete-file-if-exists okp)))))) (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)
prefix keep direction element-type external-format) directory prefix suffix type
keep direction element-type external-format)
&body body) &body body)
"Evaluate BODY where the symbols specified by keyword arguments "Evaluate BODY where the symbols specified by keyword arguments
STREAM and PATHNAME (if respectively specified) are bound corresponding STREAM and PATHNAME (if respectively specified) are bound corresponding
to a newly created temporary file ready for I/O, as per CALL-WITH-TEMPORARY-FILE. to a newly created temporary file ready for I/O, as per CALL-WITH-TEMPORARY-FILE.
The STREAM will be closed if no binding is specified. At least one of STREAM or PATHNAME must be specified.
Unless KEEP is specified, delete the file afterwards." If the STREAM is not specified, it will be closed before the BODY is evaluated.
If STREAM is specified, then the :CLOSE-STREAM label if it appears in the BODY,
separates forms run before and after the stream is closed.
The values of the last form of the BODY (not counting the separating :CLOSE-STREAM) are returned.
Upon success, the KEEP form is evaluated and the file is is deleted unless it evaluates to TRUE."
(check-type stream symbol) (check-type stream symbol)
(check-type pathname symbol) (check-type pathname symbol)
(assert (or streamp pathnamep)) (assert (or streamp pathnamep))
`(flet ((think (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname))) (let* ((afterp (position :close-stream body))
,@body)) (before (if afterp (subseq body 0 (1- afterp)) body))
#-gcl (declare (dynamic-extent #'think)) (after (when afterp (subseq body (1+ afterp))))
(call-with-temporary-file (beforef (gensym "BEFORE"))
#'think (afterf (gensym "AFTER")))
:want-stream-p ,streamp `(flet (,@(when before
:want-pathname-p ,pathnamep `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname))) ,@before)))
,@(when direction `(:direction ,direction)) ,@(when after
,@(when prefix `(:prefix ,prefix)) (assert pathnamep)
,@(when keep `(:keep ,keep)) `((,afterf (,pathname) ,@after))))
,@(when element-type `(:element-type ,element-type)) #-gcl (declare (dynamic-extent ,@(when before `(#',beforef)) ,@(when after `(#',afterf))))
,@(when external-format `(:external-format ,external-format))))) (call-with-temporary-file
,(when before `#',beforef)
(defun get-temporary-file (&key prefix) :want-stream-p ,streamp
(with-temporary-file (:pathname pn :keep t :prefix prefix) :want-pathname-p ,pathnamep
,@(when direction `(:direction ,direction))
,@(when directory `(:directory ,directory))
,@(when prefix `(:prefix ,prefix))
,@(when suffix `(:suffix ,suffix))
,@(when type `(:suffix ,type))
,@(when keep `(:keep ,keep))
,@(when after `(:after `#',afterf))
,@(when element-type `(:element-type ,element-type))
,@(when external-format `(:external-format ,external-format))))))
(defun get-temporary-file (&key directory prefix suffix type)
(with-temporary-file (:pathname pn :keep t
:directory directory :prefix prefix :suffix suffix :type type)
pn)) 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 &rest keys)
"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.
(make-pathname :name (strcat (pathname-name pathname) suffix) Further KEYS can be passed to MAKE-PATHNAME."
:defaults pathname)) (apply 'make-pathname :name (strcat (pathname-name pathname) suffix)
:defaults pathname keys))
(defun tmpize-pathname (x) (defun tmpize-pathname (x)
"Return a new pathname modified from X by adding a trivial deterministic suffix" "Return a new pathname modified from X by adding a trivial deterministic suffix"
(add-pathname-suffix x "-ASDF-TMP")) (add-pathname-suffix x "-TMP"))
(defun call-with-staging-pathname (pathname fun) (defun call-with-staging-pathname (pathname fun)
"Calls fun with a staging pathname, and atomically "Calls fun with a staging pathname, and atomically
......
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