From aaacbd24923ec4ec38e3c63b62add4798a5df1e7 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Mon, 22 Dec 2014 22:16:53 +0000
Subject: [PATCH] sys.lisp: New tools for making temporary files.

Not used yet.  Wait for it...
---
 sys.lisp | 79 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 79 insertions(+)

diff --git a/sys.lisp b/sys.lisp
index bcc8433..10cd5ca 100644
--- a/sys.lisp
+++ b/sys.lisp
@@ -102,4 +102,83 @@
   #-(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 --------------------------------------------------
-- 
2.11.0