chiark / gitweb /
sys.lisp: New tools for making temporary files.
authorMark Wooding <mdw@distorted.org.uk>
Mon, 22 Dec 2014 22:16:53 +0000 (22:16 +0000)
committerMark Wooding <mdw@distorted.org.uk>
Mon, 22 Dec 2014 22:23:08 +0000 (22:23 +0000)
Not used yet.  Wait for it...

sys.lisp

index bcc8433..10cd5ca 100644 (file)
--- a/sys.lisp
+++ b/sys.lisp
@@ -102,4 +102,83 @@ (defun canonify-hostname (name)
   #-(or cmu sbcl clisp ecl)
   name)
 
+(export 'fresh-file-name)
+(defun fresh-file-name (template)
+  "Return the pathname of a fresh (newly created) file.
+
+   The TEMPLATE explains where to put the file; the name portion of the
+   TEMPLATE will have a suffix appended to it to ensure freshness."
+  (let* ((pathname (pathname template))
+        (base (pathname-name pathname)))
+    (loop
+      (let ((try (make-pathname :name (format nil "~A-~6,'0D"
+                                             base (random 1000000))
+                               :defaults pathname)))
+       (with-open-file (stream try
+                        :direction :output
+                        :if-exists nil
+                        :if-does-not-exist :create)
+         (when stream
+           (close stream)
+           (return try)))))))
+
+(export '(temporary-file-context-p
+         make-temporary-file-context
+         temporary-file-context-active-p))
+(defstruct (temporary-file-context
+            (:constructor make-temporary-file-context
+                          (%base
+                           &aux
+                           (base (if %base
+                                     (merge-pathnames %base)
+                                     *default-pathname-defaults*)))))
+  "Keeps track of a collection of temporary files."
+  (active-p t :type boolean)
+  (base *default-pathname-defaults* :type pathname)
+  (temporaries nil :type list))
+
+(export 'temporary-file)
+(defun temporary-file (context template)
+  "Create a new temporary file, and return its name.
+
+   The new file is associated with a CONTEXT (as created by
+   `make-temporary-file-context'), and will be removed when
+   `clear-temporary-files' is called on the context."
+  (unless (temporary-file-context-active-p context)
+    (error "Temporary function context has expired"))
+  (let ((temp (fresh-file-name
+              (merge-pathnames template
+                               (temporary-file-context-base context)))))
+    (push temp (temporary-file-context-temporaries context))
+    temp))
+
+(export 'clear-temporary-files)
+(defun clear-temporary-files (context)
+  "Removes the temporary files associated with CONTEXT.
+
+   The context becomes inactive, and an error is signalled if an attempt is
+   made to associate more files with it."
+  (mapc #'delete-file (temporary-file-context-temporaries context))
+  (setf (temporary-file-context-active-p context) nil))
+
+(defun with-temporary-files* (thunk &optional base)
+  "The innards of `with-temporary-files'.
+
+   Invoke THUNK with a temporary-files context as its argument, returning
+   whatever values it returns.  When THUNK terminates, remove the files in
+   the context."
+  (let ((context (make-temporary-file-context base)))
+    (unwind-protect (funcall thunk context)
+      (clear-temporary-files context))))
+
+(export 'with-temporary-files)
+(defmacro with-temporary-files
+    ((context &key (base '*default-pathname-defaults*)) &body body)
+  "Evaluate BODY within a temporary-files context.
+
+   Bind the new context to CONTEXT, and evaluate the BODY; when BODY
+   terminates (normally or otherwise), delete the files.  See
+   `temporary-file'."
+  `(with-temporary-files* (lambda (,context) ,@body) ,base))
+
 ;;;----- That's all, folks --------------------------------------------------