~ chicken-core (master) 9d5a8f4bc3b7f61acb7df6779a63c1a72f8bd544
commit 9d5a8f4bc3b7f61acb7df6779a63c1a72f8bd544
Author: Stanislav Kljuhhin <stanislav.kljuhhin@me.com>
AuthorDate: Tue Sep 22 21:43:07 2026 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Sep 24 14:07:29 2026 +0200
Fix race in create-temporary-file/directory
This patch fixes a race in create-temporary-file/directory on POSIX
platforms and adds a useful call-with-temporary-file. Documenation is
updated as well.
- Add file-mkstemps and file-mkdtemp to chicken.file.posix
- Use the above for create-temporary-file/directory in chicken.file
on POSIX platforms
- Leave Windows implementation as it was
- call-with-temporary-file mirrors the existing call-with-output-file
including the fd leak in case proc raises an error
- Use file-mkstemp for the above so it works on Windows as well
- Remove unneeded posix-error and replace with ##sys#posix-error at
all call sites
- Add some tests for all of the above
Signed-off-by: felix <felix@call-with-current-continuation.org>
diff --git a/file.scm b/file.scm
index fc793101..a672d541 100644
--- a/file.scm
+++ b/file.scm
@@ -35,7 +35,7 @@
(declare
(unit file)
- (uses extras irregex pathname)
+ (uses extras irregex lolevel pathname posix)
(fixnum)
(disable-interrupts)
(foreign-declare #<<EOF
@@ -126,6 +126,7 @@ EOF
(module chicken.file
(create-directory delete-directory
create-temporary-file create-temporary-directory
+ call-with-temporary-file
delete-file delete-file* copy-file move-file rename-file
file-exists? directory-exists?
file-readable? file-writable? file-executable?
@@ -134,28 +135,17 @@ EOF
(import scheme
chicken.base
chicken.condition
+ chicken.file.posix
chicken.fixnum
chicken.foreign
chicken.io
chicken.irregex
+ chicken.memory.representation
chicken.pathname
chicken.process-context)
(include "common-declarations.scm")
-(define-foreign-variable strerror c-string "strerror(errno)")
-
-;; TODO: Some duplication from POSIX, to give better error messages.
-;; This really isn't so much posix-specific, and code like this is
-;; also in library.scm. This should be deduplicated across the board.
-(define posix-error
- (let ([strerror (foreign-lambda c-string "strerror" int)]
- [string-append string-append] )
- (lambda (type loc msg . args)
- (let ([rn (##sys#update-errno)])
- (apply ##sys#signal-hook/errno
- type rn loc (string-append msg " - " (strerror rn)) args)))))
-
;;; Existence checks:
@@ -180,7 +170,7 @@ EOF
(or (fx= r 0)
(if (fx= (##sys#update-errno) (foreign-value "EACCES" int))
#f
- (posix-error #:file-error loc "cannot access file" filename)))))
+ (##sys#posix-error #:file-error loc "cannot access file" filename)))))
(define (file-readable? filename) (test-access filename _r_ok 'file-readable?))
(define (file-writable? filename) (test-access filename _w_ok 'file-writable?))
@@ -198,7 +188,7 @@ EOF
"C_opendir"
(##sys#make-c-string spec 'directory) handle)
(if (##sys#null-pointer? handle)
- (posix-error #:file-error 'directory "cannot open directory" spec)
+ (##sys#posix-error #:file-error 'directory "cannot open directory" spec)
(let loop ()
(##core#inline "C_readdir" handle entry)
(if (##sys#null-pointer? entry)
@@ -222,7 +212,7 @@ EOF
(define-inline (*create-directory loc name)
(unless (fx= 0 (##core#inline "C_mkdir" (##sys#make-c-string name loc)))
- (posix-error #:file-error loc "cannot create directory" name)))
+ (##sys#posix-error #:file-error loc "cannot create directory" name)))
(define create-directory
(lambda (name #!optional recursive)
@@ -244,7 +234,7 @@ EOF
(let ((sname (##sys#make-c-string dir)))
(when (and (not (fx= 0 (##core#inline "C_rmdir" sname)))
(not (fx= (##sys#update-errno) (foreign-value "ENOENT" int))))
- (posix-error #:file-error 'delete-directory "cannot delete directory" dir))))
+ (##sys#posix-error #:file-error 'delete-directory "cannot delete directory" dir))))
(##sys#check-string name 'delete-directory)
(if recursive
(let ((files (find-files ; relies on `find-files' to list dir-contents before dir
@@ -267,9 +257,9 @@ EOF
(define (delete-file filename)
(##sys#check-string filename 'delete-file)
(unless (eq? 0 (##core#inline "C_remove" (##sys#make-c-string filename 'delete-file)))
- (##sys#signal-hook/errno
- #:file-error (##sys#update-errno) 'delete-file
- (##sys#string-append "cannot delete file - " strerror) filename))
+ (##sys#posix-error
+ #:file-error 'delete-file
+ "cannot delete file" filename))
filename)
(define (delete-file* file)
@@ -288,9 +278,9 @@ EOF
"C_rename"
(##sys#make-c-string oldfile 'rename-file)
(##sys#make-c-string newfile 'rename-file)))
- (##sys#signal-hook/errno
- #:file-error (##sys#update-errno) 'rename-file
- (##sys#string-append "cannot rename file - " strerror) oldfile newfile))
+ (##sys#posix-error
+ #:file-error 'rename-file
+ "cannot rename file" oldfile newfile))
newfile)
(define (copy-file oldfile newfile #!optional (clobber #f) (blocksize 1024))
@@ -347,6 +337,7 @@ EOF
(define create-temporary-file)
(define create-temporary-directory)
+(define call-with-temporary-file)
(let ((temp-prefix "temp")
(string-append string-append))
@@ -363,41 +354,66 @@ EOF
(set! create-temporary-file
(lambda (#!optional (ext "tmp"))
(##sys#check-string ext 'create-temporary-file)
- (let loop ()
- (let* ((n (##core#inline "C_random_fixnum" #x10000))
- (getpid (foreign-lambda int "C_getpid"))
- (pn (make-pathname
- (tempdir)
- (string-append
- temp-prefix
- (number->string n 16)
- "."
- (##sys#number->string (getpid)))
- ext)))
- (if (file-exists? pn)
- (loop)
- (call-with-output-file pn (lambda (p) pn)))))))
+ (if ##sys#windows-platform
+ (let loop ()
+ (let* ((n (##core#inline "C_random_fixnum" #x10000))
+ (getpid (foreign-lambda int "C_getpid"))
+ (pn (make-pathname
+ (tempdir)
+ (string-append
+ temp-prefix
+ (number->string n 16)
+ "."
+ (##sys#number->string (getpid)))
+ ext)))
+ (if (file-exists? pn)
+ (loop)
+ (call-with-output-file pn (lambda (p) pn)))))
+ (let* ((n (number-of-bytes ext))
+ ;; Account for the added dot.
+ (n (if (fx= n 0) 0 (fx+ n 1)))
+ (pn (make-pathname
+ (tempdir)
+ (string-append temp-prefix "XXXXXX")
+ ext)))
+ (let-values (((fd pn) (file-mkstemps pn n)))
+ (file-close fd)
+ pn)))))
(set! create-temporary-directory
(lambda ()
- (let loop ()
- (let* ((n (##core#inline "C_random_fixnum" #x10000))
- (getpid (foreign-lambda int "C_getpid"))
- (pn (make-pathname
- (tempdir)
- (string-append
- temp-prefix
- (number->string n 16)
- "."
- (##sys#number->string (getpid))))))
- (if (file-exists? pn)
- (loop)
- (let ((r (##core#inline "C_mkdir" (##sys#make-c-string pn 'create-temporary-directory))))
- (if (eq? r 0)
- pn
- (##sys#signal-hook
- #:file-error 'create-temporary-directory
- (##sys#string-append "cannot create temporary directory - " strerror)
- pn)))))))))
+ (if ##sys#windows-platform
+ (let loop ()
+ (let* ((n (##core#inline "C_random_fixnum" #x10000))
+ (getpid (foreign-lambda int "C_getpid"))
+ (pn (make-pathname
+ (tempdir)
+ (string-append
+ temp-prefix
+ (number->string n 16)
+ "."
+ (##sys#number->string (getpid))))))
+ (if (file-exists? pn)
+ (loop)
+ (let ((r (##core#inline "C_mkdir" (##sys#make-c-string pn 'create-temporary-directory))))
+ (if (eq? r 0)
+ pn
+ (##sys#posix-error
+ #:file-error 'create-temporary-directory
+ "cannot create temporary directory" pn))))))
+ (file-mkdtemp
+ (make-pathname (tempdir) (string-append temp-prefix "XXXXXX"))))))
+ (set! call-with-temporary-file
+ (let ((open-output-file* open-output-file*)
+ (close-output-port close-output-port))
+ (lambda (p)
+ (let-values (((fd pn) (file-mkstemp
+ (make-pathname (tempdir) (string-append temp-prefix "XXXXXX")))))
+ (let ((f (open-output-file* fd)))
+ (##sys#call-with-values
+ (lambda () (p f pn))
+ (lambda results
+ (close-output-port f)
+ (apply ##sys#values results)))))))))
;;; Filename globbing:
diff --git a/manual/Module (chicken file posix) b/manual/Module (chicken file posix)
index 1df15369..1a174bf3 100644
--- a/manual/Module (chicken file posix)
+++ b/manual/Module (chicken file posix)
@@ -511,6 +511,47 @@ Example usage:
(close-output-port temp-port)))
</enscript>
+==== file-mkstemps
+
+<procedure>(file-mkstemps TEMPLATE-FILENAME SUFFIX-LENGTH)</procedure>
+
+Create a file based on the given {{TEMPLATE-FILENAME}}, in which
+the six characters before the suffix must be ''XXXXXX''. These will
+be replaced with a string that makes the filename unique.
+{{SUFFIX-LENGTH}} should be a fixnum giving the length of the suffix
+in bytes. The file descriptor of the created file and the generated
+filename is returned. See the {{mkstemps(3)}} manual page for details
+on how this function works. The template string given is not modified.
+
+Example usage:
+
+<enscript highlight=scheme>
+ (let ((suffix ".tmp"))
+ (let-values (((fd temp-path)
+ (file-mkstemps (string-append "/tmp/mytemporary.XXXXXX" suffix)
+ (number-of-bytes suffix))))
+ (let ((temp-port (open-output-file* fd)))
+ (format temp-port "This file is ~A.~%" temp-path)
+ (close-output-port temp-port))))
+</enscript>
+
+'''NOTE''': On native Windows builds (all except cygwin), this
+procedure is unimplemented and will raise an error.
+
+==== file-mkdtemp
+
+<procedure>(file-mkdtemp TEMPLATE-FILENAME)</procedure>
+
+Create a directory based on the given {{TEMPLATE-FILENAME}}, in which
+the six last characters must be ''XXXXXX''. These will be replaced
+with a string that makes the directory name unique. The generated
+directory name is returned. See the {{mkdtemp(3)}} manual page for
+details on how this function works. The template string given is
+not modified.
+
+'''NOTE''': On native Windows builds (all except cygwin), this
+procedure is unimplemented and will raise an error.
+
==== file-read
<procedure>(file-read FILENO SIZE [BUFFER])</procedure>
diff --git a/manual/Module (chicken file) b/manual/Module (chicken file)
index 8fc434a9..80b6d45e 100644
--- a/manual/Module (chicken file)
+++ b/manual/Module (chicken file)
@@ -165,6 +165,17 @@ Changed in CHICKEN 5.4.0: the values of the {{TMPDIR}}, {{TEMP}} and
{{TMP}} environment variables are no longer memoized (see
[[#1830|https://bugs.call-cc.org/ticket/1830]]).
+==== call-with-temporary-file
+
+<procedure>(call-with-temporary-file PROC)</procedure>
+
+Creates a temporary file and calls {{PROC}} with an output port for
+the file and its pathname. The file has no extension and is created
+in the same directory as with {{create-temporary-file}}.
+
+Returns the values returned by {{PROC}}. When {{PROC}} returns normally,
+the output port is closed. The file is not deleted.
+
=== Finding files
==== find-files
diff --git a/posix.scm b/posix.scm
index 43069da4..2bae52ac 100644
--- a/posix.scm
+++ b/posix.scm
@@ -45,8 +45,8 @@
duplicate-fileno fcntl/dupfd fcntl/getfd fcntl/getfl fcntl/setfd
fcntl/setfl file-access-time file-change-time file-modification-time
file-close file-control file-creation-mode file-group file-link
- file-lock file-lock/blocking file-mkstemp file-open file-owner
- file-permissions file-position file-read file-select file-size
+ file-lock file-lock/blocking file-mkstemp file-mkstemps file-mkdtemp
+ file-open file-owner file-permissions file-position file-read file-select file-size
file-stat file-truncate file-unlock file-write
file-type block-device? character-device? directory? fifo?
regular-file? socket? symbolic-link?
@@ -87,6 +87,8 @@
(define file-lock)
(define file-lock/blocking)
(define file-mkstemp)
+(define file-mkstemps)
+(define file-mkdtemp)
(define file-open)
(define file-owner)
(define file-permissions)
diff --git a/posixunix.scm b/posixunix.scm
index eea81b24..e11520f5 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -182,6 +182,8 @@ static sigset_t C_sigset;
#define C_read(fd, b, n) C_fix(read(C_unfix(fd), C_c_string(b), C_unfix(n)))
#define C_write(fd, b, start, n) C_fix(write(C_unfix(fd), C_c_string(b) + C_unfix(start), C_unfix(n)))
#define C_mkstemp(t) C_fix(mkstemp(C_c_string(t)))
+#define C_mkstemps(t, n) C_fix(mkstemps(C_c_string(t), C_unfix(n)))
+#define C_mkdtemp(t) C_fix(mkdtemp(C_c_string(t)) ? 0 : -1)
#define C_ctime(n) (C_secs = (n), ctime(&C_secs))
@@ -403,6 +405,34 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
fd
(##sys#buffer->string! bv2 (fx- len 1)))))))
+(set! chicken.file.posix#file-mkstemps
+ (lambda (template suffixlen)
+ (##sys#check-string template 'file-mkstemps)
+ (##sys#check-fixnum suffixlen 'file-mkstemps)
+ (let* ((bv1 (##sys#make-c-string template 'file-mkstemps))
+ (len (##sys#size bv1))
+ (bv2 (##sys#make-bytevector len)) )
+ (##core#inline "C_copy_memory" bv2 bv1 len)
+ (let ((fd (##core#inline "C_mkstemps" bv2 suffixlen)))
+ (when (eq? -1 fd)
+ (posix-error #:file-error 'file-mkstemps
+ "cannot create temporary file" template) )
+ (values
+ fd
+ (##sys#buffer->string! bv2 (fx- len 1)))))))
+
+(set! chicken.file.posix#file-mkdtemp
+ (lambda (template)
+ (##sys#check-string template 'file-mkdtemp)
+ (let* ((bv1 (##sys#make-c-string template 'file-mkdtemp))
+ (len (##sys#size bv1))
+ (bv2 (##sys#make-bytevector len)) )
+ (##core#inline "C_copy_memory" bv2 bv1 len)
+ (when (eq? -1 (##core#inline "C_mkdtemp" bv2))
+ (posix-error #:file-error 'file-mkdtemp
+ "cannot create temporary directory" template) )
+ (##sys#buffer->string! bv2 (fx- len 1)))))
+
;;; I/O multiplexing:
diff --git a/posixwin.scm b/posixwin.scm
index 27917f3a..ff989dfe 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -916,6 +916,8 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
(set!-unimplemented chicken.file.posix#file-link)
(set!-unimplemented chicken.file.posix#file-lock)
(set!-unimplemented chicken.file.posix#file-lock/blocking)
+(set!-unimplemented chicken.file.posix#file-mkstemps)
+(set!-unimplemented chicken.file.posix#file-mkdtemp)
(set!-unimplemented chicken.file.posix#file-select)
(set!-unimplemented chicken.file.posix#file-test-lock)
(set!-unimplemented chicken.file.posix#file-truncate)
diff --git a/rules.make b/rules.make
index 501032f3..a0537062 100644
--- a/rules.make
+++ b/rules.make
@@ -786,10 +786,12 @@ repl.c: repl.scm \
chicken.eval.import.scm
file.c: file.scm \
chicken.condition.import.scm \
+ chicken.file.posix.import.scm \
chicken.fixnum.import.scm \
chicken.io.import.scm \
chicken.irregex.import.scm \
chicken.foreign.import.scm \
+ chicken.memory.representation.import.scm \
chicken.pathname.import.scm \
chicken.process-context.import.scm
lolevel.c: lolevel.scm \
diff --git a/tests/posix-tests.scm b/tests/posix-tests.scm
index 15e0dd33..c1f5934d 100644
--- a/tests/posix-tests.scm
+++ b/tests/posix-tests.scm
@@ -1,5 +1,7 @@
(import (chicken bitwise)
(chicken pathname)
+ (chicken condition)
+ (chicken errno)
(chicken file)
(chicken file posix)
(chicken platform)
@@ -31,6 +33,52 @@
(close-output-port port)
(delete-file* tnpfilpn) ) ) )
+(cond-expand
+ ((not windows)
+ (let ((tmp (create-temporary-directory)))
+ (for-each
+ (lambda (suffix)
+ (let ((template (make-pathname tmp (string-append "tempXXXXXX" suffix))))
+ (let-values (((fd name) (file-mkstemps template (number-of-bytes suffix))))
+ (assert (equal? template (make-pathname tmp (string-append "tempXXXXXX" suffix))))
+ (assert (not (equal? name template)))
+ (assert (equal? (pathname-directory name) tmp))
+ (assert (equal? (substring name (- (string-length name) (string-length suffix)))
+ suffix))
+ (assert (regular-file? name))
+ (assert (= 3 (file-write fd #u8("foo"))))
+ (set-file-position! fd 0 seek/set)
+ (assert (equal? '(#u8("foo") 3) (file-read fd 3)))
+ (file-close fd)
+ (delete-file name))))
+ '("" ".tmp" "привет"))
+ (let* ((template (make-pathname tmp "dirXXXXXX"))
+ (name (file-mkdtemp template)))
+ (assert (equal? template (make-pathname tmp "dirXXXXXX")))
+ (assert (not (equal? name template)))
+ (assert (equal? (pathname-directory name) tmp))
+ (assert (directory? name))
+ (delete-directory name))
+ (assert-error (file-mkstemps #f 0))
+ (assert-error (file-mkstemps (make-pathname tmp "tempXXXXXX.tmp") #f))
+ (assert-error (file-mkstemps (make-pathname tmp "tempXXXXXX.tmp") -1))
+ (assert-error (file-mkstemps (make-pathname tmp "tempXXXXXX.tmp") 1000000))
+ (assert-error (file-mkstemps (make-pathname tmp "temp\x00;XXXXXX.tmp") 4))
+ (assert-error (file-mkdtemp #f))
+ (assert-error (file-mkdtemp (make-pathname tmp "temp\x00;XXXXXX")))
+ (for-each
+ (lambda (thunk)
+ (assert
+ (handle-exceptions exn
+ (and ((condition-predicate 'file) exn)
+ (= (get-condition-property exn 'exn 'errno) errno/noent))
+ (thunk)
+ #f)))
+ (list (lambda () (file-mkstemps (make-pathname tmp "missing/tempXXXXXX.tmp") 4))
+ (lambda () (file-mkdtemp (make-pathname tmp "missing/dirXXXXXX")))))
+ (delete-directory tmp)))
+ (else))
+
(assert-error (get-environment-variable "with\x00;embedded-NUL"))
(assert-error (set-environment-variable! "with\x00;embedded-NUL" "blabla"))
(assert-error (set-environment-variable! "blabla" "with\x00;embedded-NUL"))
diff --git a/tests/test-create-temporary-file.scm b/tests/test-create-temporary-file.scm
index d60394b3..de29cf05 100644
--- a/tests/test-create-temporary-file.scm
+++ b/tests/test-create-temporary-file.scm
@@ -37,3 +37,38 @@
(let ((tmp (create-temporary-directory)))
(delete-directory tmp)
(assert (not (pathname-directory tmp))))))
+
+(for-each
+ (lambda (ext)
+ (let* ((tmp (create-temporary-file ext))
+ (suffix (if (zero? (string-length ext)) "" (string-append "." ext))))
+ (assert (equal? (substring tmp (- (string-length tmp) (string-length suffix)))
+ suffix))
+ (assert (file-exists? tmp))
+ (assert (call-with-input-file tmp (lambda (p) (eof-object? (read-char p)))))
+ (delete-file tmp)))
+ '("" "tmp" "привет"))
+
+(let ((dir (create-temporary-directory)))
+ (with-environment-variable "TMPDIR" dir
+ (lambda ()
+ (let ((port #f)
+ (name #f))
+ (assert
+ (eq? 'done
+ (call-with-temporary-file
+ (lambda (p tmp)
+ (set! port p)
+ (set! name tmp)
+ (assert (output-port? p))
+ (assert (not (port-closed? p)))
+ (assert (file-exists? tmp))
+ (assert (equal? (pathname-directory tmp) dir))
+ (assert (not (pathname-extension tmp)))
+ (display "привет" p)
+ 'done))))
+ (assert (port-closed? port))
+ (assert (file-exists? name))
+ (assert (equal? 'привет (call-with-input-file name read)))
+ (delete-file name))))
+ (delete-directory dir))
diff --git a/types.db b/types.db
index 02e4f716..eabad599 100644
--- a/types.db
+++ b/types.db
@@ -1670,6 +1670,7 @@
(chicken.file#create-directory (#(procedure #:clean #:enforce) chicken.file#create-directory (string #!optional *) string))
(chicken.file#create-temporary-directory (#(procedure #:clean #:enforce) chicken.file#create-temporary-directory () string))
(chicken.file#create-temporary-file (#(procedure #:clean #:enforce) chicken.file#create-temporary-file (#!optional string) string))
+(chicken.file#call-with-temporary-file (procedure chicken.file#call-with-temporary-file ((procedure (output-port string) . *)) . *))
(chicken.file#delete-directory (#(procedure #:clean #:enforce) chicken.file#delete-directory (string #!optional *) undefined))
(chicken.file#delete-file (#(procedure #:clean #:enforce) chicken.file#delete-file (string) string))
(chicken.file#delete-file* (#(procedure #:clean #:enforce) chicken.file#delete-file* (string) (or false string)))
@@ -2083,6 +2084,8 @@
(chicken.file.posix#file-lock (#(procedure #:clean #:enforce) chicken.file.posix#file-lock ((or port fixnum) #!optional *) boolean))
(chicken.file.posix#file-lock/blocking (#(procedure #:clean #:enforce) chicken.file.posix#file-lock/blocking ((or port fixnum) #!optional *) boolean))
(chicken.file.posix#file-mkstemp (#(procedure #:clean #:enforce) chicken.file.posix#file-mkstemp (string) fixnum string))
+(chicken.file.posix#file-mkstemps (#(procedure #:clean #:enforce) chicken.file.posix#file-mkstemps (string fixnum) fixnum string))
+(chicken.file.posix#file-mkdtemp (#(procedure #:clean #:enforce) chicken.file.posix#file-mkdtemp (string) string))
(chicken.file.posix#file-open (#(procedure #:clean #:enforce) chicken.file.posix#file-open (string fixnum #!optional fixnum) fixnum))
(chicken.file.posix#file-owner (#(procedure #:clean #:enforce) chicken.file.posix#file-owner ((or string fixnum port)) fixnum))
(chicken.file.posix#file-permissions (#(procedure #:clean #:enforce) chicken.file.posix#file-permissions ((or string fixnum port)) fixnum))
Trap