GitLab

at 2025-11-13T10:56:53-08:00

Fix #373:  Add macros to handle temporary files, streams, and directories

Merge branch 'issue-373-handle-temp-files' into 'master'

Fix #373:  Add macros to handle temporary files, streams, and directories

Closes #373 and #375

See merge request cmucl/cmucl!269

 	     "*TRUST-DYNAMIC-EXTENT-DECLARATIONS*"

-	     "INVALID-FASL")

+	     "INVALID-FASL"

+	     "WITH-TEMPORARY-DIRECTORY"

+	     "WITH-TEMPORARY-FILE")

   ;; gencgc features

   #+gencgc

   (:export "GET-GC-ASSERTIONS"

   "Return an EQ hash of X.  The value of this hash for any given object can (of

   course) change at arbitary times."

   `(lisp::pointer-hash ,x))

+

+

+(defun get-os-temp-path ()

+  "Get a path to an appropriate temporary location from the OS.  A string

+  is returned to that path.  The path ends with a \"/\" character."

+  (let ((path (alien:alien-funcall

+	       (alien:extern-alien "os_temporary_directory"

+				   (function (alien:* c-call:char))))))

+    (when (alien:null-alien path)

+      (error "Unable to find path to temporary directory"))

+

+    (unwind-protect

+	 (unix::%file->name (cast path c-call:c-string))

+      (unless (alien:null-alien path)

+	(alien:free-alien path)))))

+

+;; Create a template suitable for mkstemp and mkdtemp.  DIRECTORY is

+;; the directory for the template.  If DIRECTORY is NIL, an

+;; OS-dependent location is used.  PREFIX is string that is the prefix

+;; for the filename for the template.  In all cases, we append exactly

+;; 6 X's to create the finale template.

+(defun create-template (directory prefix)

+  (concatenate 'string

+	       (or directory

+		   (get-os-temp-path))

+	       "/"

+	       prefix

+	       "XXXXXX"))

+

+;;; WITH-TEMPORARY-FILE  -- Public

+(defmacro with-temporary-file ((filename &key directory (prefix "cmucl-temp-file-"))

+			       &parse-body (forms decls))

+  _N"Creates a temporary file with a name bound to Filename which a

+ namestring.  If Directory is not provided, the temporary file is created

+ in a OS-dependent location.  The Prefix is a prefix to the file name

+ to be created.  If not provided a default prefix is used.

+ On completion, the file is automatically removed."

+  (let ((fd (gensym "FD-"))

+	(file-template (gensym "TEMP-PATH-"))

+	(unique-filename (gensym "UNIQUE-FILENAME-")))

+    `(let ((,file-template (create-template ,directory ,prefix))

+	   ,unique-filename)

+       (unwind-protect

+	    (let (,fd)

+	      (multiple-value-setq (,fd ,unique-filename)

+		(unix::unix-mkstemp ,file-template))

+	      (unless ,fd

+		(error "Unable to create temporary file with template ~S: ~A~%"

+		       ,file-template

+		       (unix:get-unix-error-msg ,unique-filename)))

+	      (unix:unix-close ,fd)

+	      (setf ,filename (pathname ,unique-filename))

+	      (locally ,@decls

+		,@forms))

+	 ;; We're done so delete the temp file, if one was created.

+	 (when (pathnamep ,filename)

+	   (delete-file ,filename))))))

+

+(defun delete-directory (dirname &key recursive)

+  _N"Delete the directory Dirname.  If the Recursive is non-NIL,

+  recursively delete the directory Dirname including all files and

+  subdirectories. Dirname must be a pathname to a directory.  Any NAME

+  or TYPE components in Dirname are ignored."

+  (declare (type pathname dirname))

+  (when recusive

+    ;; Find all the files or directories in DIRNAME.

+    (dolist (path (directory (merge-pathnames "*.*" dirname)))

+      ;; If the path is a directory, recursively delete the directory.

+      ;; Otherwise delete the file.  We do not follow any symlinks.

+      (if (eq (unix:unix-file-kind (namestring path)) :directory)

+	  (delete-directory path :recursive t)

+	  (delete-file path))))

+  ;; Finally delete the directory.

+  (unix:unix-rmdir (namestring dirname))

+  (values))

+

+

+;;; WITH-TEMPORARY-DIRECTORY  -- Public

+(defmacro with-temporary-directory ((dirname &key directory (prefix  "cmucl-temp-dir-"))

+				    &parse-body (forms decls))

+ _N"Return a namestring to a temporary directory.  If Directory is not

+ provided, the directory is created in an OS-dependent location.  The

+ Prefix is a string that is used as a prefix for the name of the

+ temporary directory.  If Prefix is not given, a default prefix is

+ used.  The directory and all its contents are automatically removed

+ afterward."

+  (let ((err (gensym "ERR-"))

+	(dir-template (gensym "DIR-TEMPLATE-")))

+    `(let ((,dir-template (create-template ,directory ,prefix))

+	   ,dirname ,err)

+       (unwind-protect

+	    (progn

+	      (multiple-value-setq (,dirname ,err)

+		(unix::unix-mkdtemp ,dir-template))

+	      (unless ,dirname

+		(error "Unable to create temporary directory at ~S: ~A"

+		       ,dir-template

+		       (unix:get-unix-error-msg ,err)))

+	      (setf ,dirname (pathname (concatenate 'string ,dirname "/")))

+	      (locally ,@decls

+		,@forms))

+	 ;; If a temp directory was created, remove it and all its

+	 ;; contents.  Is there a better way?

+	 (when ,dirname

+	   (delete-directory ,dirname :recursive t))))))
     (c:deftransform pprint-defun)

     (c:defoptimizer pprint-defun)

     (ext:with-float-traps-masked pprint-with-like)

-    (ext:with-float-traps-enabled pprint-with-like)))

+    (ext:with-float-traps-enabled pprint-with-like)

+    (ext::with-temporary-directory pprint-with-like)))

 (defun pprint-init ()

   (setf *initial-pprint-dispatch* (make-pprint-dispatch-table))

 "  course) change at arbitary times."

 msgstr ""

+#: src/code/extensions.lisp

+msgid ""

+"Get a path to an appropriate temporary location from the OS.  A string\n"

+"  is returned to that path.  The path ends with a \"/\" character."

+msgstr ""

+

+#: src/code/extensions.lisp

+msgid ""

+"Creates a temporary file with a name bound to Filename which a\n"

+" namestring.  If Directory is not provided, the temporary file is created\n"

+" in a OS-dependent location.  The Prefix is a prefix to the file name\n"

+" to be created.  If not provided a default prefix is used.\n"

+" On completion, the file is automatically removed."

+msgstr ""

+

+#: src/code/extensions.lisp

+msgid ""

+"Delete the directory Dirname.  If the Recursive is non-NIL,\n"

+"  recursively delete the directory Dirname including all files and\n"

+"  subdirectories. Dirname must be a pathname to a directory.  Any NAME\n"

+"  or TYPE components in Dirname are ignored."

+msgstr ""

+

+#: src/code/extensions.lisp

+msgid ""

+"Return a namestring to a temporary directory.  If Directory is not\n"

+" provided, the directory is created in an OS-dependent location.  The\n"

+" Prefix is a string that is used as a prefix for the name of the\n"

+" temporary directory.  If Prefix is not given, a default prefix is\n"

+" used.  The directory and all its contents are automatically removed\n"

+" afterward."

+msgstr ""

+

 #: src/code/commandline.lisp

 msgid "A list of all the command line arguments after --"

 msgstr ""

 #include <dlfcn.h>

 #include <string.h>

 #include <assert.h>

+#include <unistd.h>

 #include "os.h"

 #include "arch.h"

     return TRUE;

 }

 #endif

+

+/*

+ * Return a new string containing the path to an OS-dependent location

+ * where temporary files/directories can be stored.  If NULL is

+ * returned, such a location could not be found or some other error

+ * happened.

+ *

+ * Caller must call free() on the string returned.

+ */

+char *

+os_temporary_directory(void)

+{

+    /*

+     * macosx has a secure per-user temporary directory.

+     * Don't cache the result as this is only called once.

+     */

+    size_t len;

+    char path[PATH_MAX];

+

+    len = confstr(_CS_DARWIN_USER_TEMP_DIR, path, PATH_MAX);

+    if (len == 0 || len > PATH_MAX || (len == PATH_MAX && path[len - 1] != '/')) {

+	strlcpy(path, "/tmp/");

+    } else if (path[len - 1] != '/') {

+	strcat(path, "/");

+    }

+    return strdup(path);

+}
     return TRUE;

 }

 #endif

+

+/*

+ * Return a new string containing the path to an OS-dependent location

+ * where temporary files/directories can be stored.  The string must

+ * end with a slash.  If NULL is returned, such a location could not

+ * be found or some other error happened.

+ *

+ * Caller must call free() on the string returned.

+ */

+char *

+os_temporary_directory(void)

+{

+    /*

+     * If the TMP envvar is set, use that as the temporary directory.

+     * Otherwise, just assume "/tmp" will work.

+     */

+    char *tmp;

+    size_t len;

+    char *result;

+

+    tmp = getenv("TMP");

+    if (tmp == NULL) {

+	return strdup("/tmp/");

+    }

+    len = strlen(tmp);

+    if (tmp[len] == '/') {

+	return strdup(tmp);

+    }

+    result = malloc(len + 2);

+    if (result) {

+	sprintf(result, "%s/", tmp);

+    }

+    return result;

+}
     return TRUE;

 }

 #endif

+

+/*

+ * Return a new string containing the path to an OS-dependent location

+ * where temporary files/directories can be stored.  The string must

+ * end with a slash.  If NULL is returned, such a location could not

+ * be found or some other error happened.

+ *

+ * Caller must call free() on the string returned.

+ */

+char *

+os_temporary_directory(void)

+{

+    /*

+     * If the TMP envvar is set, use that as the temporary directory.

+     * Otherwise, just assume "/tmp" will work.

+     */

+    char *tmp;

+    size_t len;

+    char *result;

+

+    tmp = getenv("TMP");

+    if (tmp == NULL) {

+	return strdup("/tmp/");

+    }

+    len = strlen(tmp);

+    if (tmp[len] == '/') {

+	return strdup(tmp);

+    }

+    result = malloc(len + 2);

+    if (result) {

+	sprintf(result, "%s/", tmp);

+    }

+    return result;

+}
 	return FALSE;

 }

 #endif

+

+/*

+ * Return a new string containing the path to an OS-dependent location

+ * where temporary files/directories can be stored.  The string must

+ * end with a slash.  If NULL is returned, such a location could not

+ * be found or some other error happened.

+ *

+ * Caller must call free() on the string returned.

+ */

+char *

+os_temporary_directory(void)

+{

+    /*

+     * If the TMP envvar is set, use that as the temporary directory.

+     * Otherwise, just assume "/tmp" will work.

+     */

+    char *tmp;

+    size_t len;

+    char *result;

+

+    tmp = getenv("TMP");

+    if (tmp == NULL) {

+	return strdup("/tmp/");

+    }

+    len = strlen(tmp);

+    if (tmp[len] == '/') {

+	return strdup(tmp);

+    }

+    result = malloc(len + 2);

+    if (result) {

+	sprintf(result, "%s/", tmp);

+    }

+    return result;

+}
     interrupt_install_low_level_handler(SIGSEGV, sigsegv_handler);

     interrupt_install_low_level_handler(SIGBUS, sigbus_handler);

 }

+

+/*

+ * Return a new string containing the path to an OS-dependent location

+ * where temporary files/directories can be stored.  The string must

+ * end with a slash.  If NULL is returned, such a location could not

+ * be found or some other error happened.

+ *

+ * Caller must call free() on the string returned.

+ */

+char *

+os_temporary_directory(void)

+{

+    /*

+     * If the TMP envvar is set, use that as the temporary directory.

+     * Otherwise, just assume "/tmp" will work.

+     */

+    char *tmp;

+    size_t len;

+    char *result;

+

+    tmp = getenv("TMP");

+    if (tmp == NULL) {

+	return strdup("/tmp/");

+    }

+    len = strlen(tmp);

+    if (tmp[len] == '/') {

+	return strdup(tmp);

+    }

+    result = malloc(len + 2);

+    if (result) {

+	sprintf(result, "%s/", tmp);

+    }

+    return result;

+}
 #include <sys/utsname.h>

 #include <unistd.h>

 #include <time.h>

+#if defined(DARWIN)

+#include <limits.h>

+#endif

 #include "os.h"

 #include "internals.h"

     *status = -1;

     return NULL;

 }

-    

 /*

  * Return a new string (or NULL) for the current working directory.

     return TRUE;

 }

 #endif

+

+/*

+ * Return a new string containing the path to an OS-dependent location

+ * where temporary files/directories can be stored.  The string must

+ * end with a slash.  If NULL is returned, such a location could not

+ * be found or some other error happened.

+ *

+ * Caller must call free() on the string returned.

+ */

+char *

+os_temporary_directory(void)

+{

+    /*

+     * If the TMP envvar is set, use that as the temporary directory.

+     * Otherwise, just assume "/tmp" will work.

+     */

+    char *tmp;

+    size_t len;

+    char *result;

+

+    tmp = getenv("TMP");

+    if (tmp == NULL) {

+	return strdup("/tmp/");

+    }

+    len = strlen(tmp);

+    if (tmp[len] == '/') {

+	return strdup(tmp);

+    }

+    result = malloc(len + 2);

+    if (result) {

+	sprintf(result, "%s/", tmp);

+    }

+    return result;

+}
   (ensure-directories-exist *test-path* :verbose t))

 (define-test clear-output-1

-  (:tag :trac)

+    (:tag :trac)

   (assert-eql

    0

-   (unwind-protect

-	(let ((s (open *test-file*

-		       :direction :output

-		       :if-exists :supersede)))

-	  ;; Write a character to the (fully buffered) output

-	  ;; stream. Clear the output and close the file. Nothing

-	  ;; should have been written to the file.

-	  (write-char #\a s)

-	  (clear-output s)

-	  (close s)

-	  (setf s (open *test-file*))

-	  (file-length s))

-     (delete-file *test-file*))))

+   (ext:with-temporary-file (test-file)

+     (let ((s (open test-file

+		    :direction :output

+		    :if-exists :supersede)))

+       ;; Write a character to the (fully buffered) output

+       ;; stream. Clear the output and close the file. Nothing

+       ;; should have been written to the file.

+       (write-char #\a s)

+       (clear-output s)

+       (close s)

+       (setf s (open test-file))

+       (prog1

+	   (file-length s)

+	 (close s))))))

 (define-test file-position.1

     (:tag :issues)

 		(pathname-directory "/tmp/Foo/BAR/" :case :common)))

 (define-test trac.36

-  (:tag :trac)

-  (let ((path "/tmp/trac.36.bom.txt"))

-    (flet ((bug (&optional (format :utf16))

+    (:tag :trac)

+  (flet ((bug (&optional (format :utf16))

+	   (ext:with-temporary-file (path)

 	     (with-open-file (s path

 				:direction :output

-				:if-exists :supersede

 				:external-format format)

 	       (format s "Hello~%"))

 	     (with-open-file (s path 

 				:direction :input

 				:external-format format)

 	       (let ((ch (read-char s)))

-		 (values ch (file-position s))))))

-      (assert-equal (values #\H 4)

-		    (bug :utf16))

-      (assert-equal (values #\H 8)

-		    (bug :utf32)))))

+		 (values ch (file-position s)))))))

+    (assert-equal (values #\H 4)

+		  (bug :utf16))

+    (assert-equal (values #\H 8)

+		  (bug :utf32))))

 (define-test trac.43

-  (:tag :trac)

+    (:tag :trac)

   (assert-true

-   (let ((path "/tmp/trac.43.txt"))

-     (unwind-protect

-	  (progn

-	    (with-open-file (ostream path :direction :output

-					  :external-format :utf-8)

-	      (dotimes (i 1000)

-		(write-char (code-char #x1234) ostream)))

-

-	    (with-open-file (stream path :direction :input

-					 :external-format :utf-8)

-	      (let ((p0 (file-position stream))

-		    (ch (read-char stream)))

-		(unread-char ch stream)

-		(let ((p0* (file-position stream)))

-		  (eql p0* p0)))))))))

+   (ext:with-temporary-file (path)

+     (with-open-file (ostream path :direction :output

+				   :external-format :utf-8)

+       (dotimes (i 1000)

+	 (write-char (code-char #x1234) ostream)))

+

+     (with-open-file (stream path :direction :input

+				  :external-format :utf-8)

+       (let ((p0 (file-position stream))

+	     (ch (read-char stream)))

+	 (unread-char ch stream)

+	 (let ((p0* (file-position stream)))

+	   (eql p0* p0)))))))

 (define-test trac.50

   (:tag :trac)

 		(princ-to-string (make-pathname :directory '(:absolute "tmp" "" "a" "" "b")))))

 (define-test trac.58

-  (:tag :trac)

+    (:tag :trac)

   (assert-false

-   (let ((path "/tmp/trac.58.txt")

-	 failures)

-     (unwind-protect

-	  (progn

-	    (with-open-file (s path :direction :output :external-format :utf-16)

-	      (dotimes (i 300)

-		(write-char (code-char i) s)))

-

-	    (with-open-file (s path :direction :input :external-format :utf-16)

-	      (dotimes (i 300)

-		(let ((ch (read-char s nil nil)))

-		  (unless (= i (char-code ch))

-		    (push (list i ch (char-code ch)) failures)))))

-	    failures)

-       (delete-file path)))))

+   (let (failures)

+     (ext:with-temporary-file (path)

+       (with-open-file (s path :direction :output :external-format :utf-16)

+	 (dotimes (i 300)

+	   (write-char (code-char i) s)))

+

+       (with-open-file (s path :direction :input :external-format :utf-16)

+	 (dotimes (i 300)

+	   (let ((ch (read-char s nil nil)))

+	     (unless (= i (char-code ch))

+	       (push (list i ch (char-code ch)) failures)))))

+       failures))

+   failures))

 (define-test trac.63

   (:tag :trac)

   ;; Create a temp file full of latin1 characters.

   (assert-equal

    '(0 1)

-   (let ((path "/tmp/trac.70.txt"))

-     (unwind-protect

-	  (progn

-	    (with-open-file (s path :direction :output :if-exists :supersede

-				    :external-format :latin1)

-	      (dotimes (k 255)

-		(write-char (code-char k) s)))

-	    (with-open-file (s path :direction :input :external-format :latin1)

-	      (list (file-position s)

-		    (progn

-		      (read-char s)

-		      (file-position s)))))

-       (delete-file path)))))

+   (ext:with-temporary-file (path)

+     (with-open-file (s path :direction :output :if-exists :supersede

+			     :external-format :latin1)

+       (dotimes (k 255)

+	 (write-char (code-char k) s)))

+     (with-open-file (s path :direction :input :external-format :latin1)

+       (list (file-position s)

+	     (progn

+	       (read-char s)

+	       (file-position s)))))))

 (define-test trac.80

   (:tag :trac)

   (:tag :trac)

   ;; Test that run-program accepts :element-type and produces the

   ;; correct output.

-  (let ((path "/tmp/trac.87.output")

-	(string "Hello"))

-    (unwind-protect

-	 (progn

-	   (with-open-file (s path :direction :output :if-exists :supersede

+  (let ((string "Hello"))

+    (ext:with-temporary-file (path)

+      (with-open-file (s path :direction :output :if-exists :supersede

 			      :external-format :latin1)

-	     (write-string string s))

-	   (let* ((expected (stream:string-to-octets string :external-format :latin1))

-		  (octets (make-array (length expected)

-				      :element-type '(unsigned-byte 8)))

-		  (proc (ext:run-program "/bin/cat" (list path)

-					 :output :stream

-					 :element-type '(unsigned-byte 8))))

-	     (read-sequence octets (ext:process-output proc))

-	     (assert-equalp

-	      expected

-	      octets)))

-      (delete-file path))))

+	(write-string string s))

+      (let* ((expected (stream:string-to-octets string :external-format :latin1))

+	     (octets (make-array (length expected)

+				 :element-type '(unsigned-byte 8)))

+	     (proc (ext:run-program "/bin/cat" (list (namestring path))

+				    :output :stream

+				    :element-type '(unsigned-byte 8))))

+	(read-sequence octets (ext:process-output proc))

+	(assert-equalp

+	 expected

+	 octets)))))

 (define-test trac.87.input

   (:tag :trac)

   ;; Test that run-program accepts :element-type and produces the

   ;; correct input (and output).

-  (let ((path "/tmp/trac.87.input")

-	(string "Hello"))

-    (unwind-protect

-	 (progn

-	   (with-open-file (s path :direction :output :if-exists :supersede

+  (let ((string "Hello"))

+    (ext:with-temporary-file (path)

+      (with-open-file (s path :direction :output :if-exists :supersede

 			      :external-format :latin1)

-	     (write-string string s))

-	   (let ((octets (stream:string-to-octets string :external-format :latin1))

-		 (output (make-array (length string)

-				     :element-type '(unsigned-byte 8)))

-		 (proc (ext:run-program "/bin/cat" (list path)

-					:input :stream

-					:output :stream

-					:element-type '(unsigned-byte 8))))

-	     (write-sequence octets (ext:process-input proc))

-	     (read-sequence output (ext:process-output proc))

-	     (assert-equalp

-	      octets

-	      output)))

-      (delete-file path))))

+	(write-string string s))

+      (let ((octets (stream:string-to-octets string :external-format :latin1))

+	    (output (make-array (length string)

+				:element-type '(unsigned-byte 8)))

+	    (proc (ext:run-program "/bin/cat" (list (namestring path))

+				   :input :stream

+				   :output :stream

+				   :element-type '(unsigned-byte 8))))

+	(write-sequence octets (ext:process-input proc))

+	(read-sequence output (ext:process-output proc))

+	(assert-equalp

+	 octets

+	 output)))))

 (define-test trac.92

   (:tag :trac)

   (:tag :trac)

   (assert-eql

    0

-   (let ((s (open *test-file*

-		  :direction :output

-		  :if-exists :supersede)))

-     (unwind-protect

-	  (progn

-	    (write-char #\a s)

-	    (clear-output s)

-	    (close s)

-	    (setf s (open *test-file*))

-	    (file-length s))

+   (ext:with-temporary-file (test-file)

+     (let ((s (open test-file

+		    :direction :output

+		    :if-exists :supersede)))

+       (write-char #\a s)

+       (clear-output s)

        (close s)

-       (delete-file *test-file*)))))

+       (setf s (open test-file))

+       (file-length s)))))

 (defun read-string-fn (str)

      (handler-case

Raymond Toy pushed to branch master at cmucl / cmucl

Commits:

13 changed files:

Changes: