Raymond Toy pushed to branch master at cmucl / cmucl Commits: aca11a4b by Raymond Toy at 2025-11-13T10:56:53-08:00 Fix #373: Add macros to handle temporary files, streams, and directories - - - - - f5484369 by Raymond Toy at 2025-11-13T10:56:53-08:00 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 - - - - - 13 changed files: - src/code/exports.lisp - src/code/extensions.lisp - src/code/pprint.lisp - src/i18n/locale/cmucl.pot - src/lisp/Darwin-os.c - src/lisp/FreeBSD-os.c - src/lisp/Linux-os.c - src/lisp/NetBSD-os.c - src/lisp/OpenBSD-os.c - src/lisp/os-common.c - src/lisp/solaris-os.c - tests/fd-streams.lisp - tests/trac.lisp Changes: ===================================== src/code/exports.lisp ===================================== @@ -1211,7 +1211,9 @@ "*TRUST-DYNAMIC-EXTENT-DECLARATIONS*" - "INVALID-FASL") + "INVALID-FASL" + "WITH-TEMPORARY-DIRECTORY" + "WITH-TEMPORARY-FILE") ;; gencgc features #+gencgc (:export "GET-GC-ASSERTIONS" ===================================== src/code/extensions.lisp ===================================== @@ -612,3 +612,108 @@ "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)))))) ===================================== src/code/pprint.lisp ===================================== @@ -2092,7 +2092,8 @@ When annotations are present, invoke them at the right positions." (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)) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -5992,6 +5992,39 @@ msgid "" " 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 "" ===================================== src/lisp/Darwin-os.c ===================================== @@ -23,6 +23,7 @@ #include <dlfcn.h> #include <string.h> #include <assert.h> +#include <unistd.h> #include "os.h" #include "arch.h" @@ -571,3 +572,30 @@ os_support_sse2() 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); +} ===================================== src/lisp/FreeBSD-os.c ===================================== @@ -362,3 +362,37 @@ os_support_sse2() 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; +} ===================================== src/lisp/Linux-os.c ===================================== @@ -628,3 +628,37 @@ os_support_sse2(void) 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; +} ===================================== src/lisp/NetBSD-os.c ===================================== @@ -427,3 +427,37 @@ os_support_sse2() 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; +} ===================================== src/lisp/OpenBSD-os.c ===================================== @@ -190,3 +190,37 @@ os_install_interrupt_handlers(void) 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; +} ===================================== src/lisp/os-common.c ===================================== @@ -26,6 +26,9 @@ #include <sys/utsname.h> #include <unistd.h> #include <time.h> +#if defined(DARWIN) +#include <limits.h> +#endif #include "os.h" #include "internals.h" @@ -940,7 +943,6 @@ os_get_user_homedir(const char* name, int *status) *status = -1; return NULL; } - /* * Return a new string (or NULL) for the current working directory. ===================================== src/lisp/solaris-os.c ===================================== @@ -643,3 +643,37 @@ os_support_sse2() 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; +} ===================================== tests/fd-streams.lisp ===================================== @@ -18,22 +18,23 @@ (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) ===================================== tests/trac.lisp ===================================== @@ -104,42 +104,39 @@ (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) @@ -147,23 +144,21 @@ (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) @@ -254,19 +249,16 @@ ;; 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) @@ -278,49 +270,43 @@ (: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) @@ -384,18 +370,15 @@ (: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 View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/671d8973d1453ffc4a652fb... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/671d8973d1453ffc4a652fb... You're receiving this email because of your account on gitlab.common-lisp.net.