Adding a preserve thunk to call-with-temp-file/dir.

lib/chibi/net/http-server.scm

@@ -209,7 +209,7 @@
 
 (define (http-cgi-bin-servlet request local-path next restart)
   (call-with-temp-file "cgi.out"
-    (lambda (temp-file out)
+    (lambda (temp-file out preserve)
       (let ((pid (fork)))
         (cond
          ((zero? pid)

lib/chibi/net/server-util.sld

@@ -5,5 +5,5 @@
           (chibi temp-file)
           (srfi 33) (srfi 69))
   (export line-handler command-handler parse-command
-          get-host file-mime-type call-with-temp-file)
+          get-host file-mime-type)
   (include "server-util.scm"))

lib/chibi/snow/commands.scm

@@ -1365,7 +1365,7 @@
 (define (install-sexp-file cfg obj dest)
   (if (install-with-sudo? cfg dest)
       (call-with-temp-file "sexp"
-        (lambda (tmp-path out)
+        (lambda (tmp-path out preserve)
           (write-simple-pretty obj out)
           (close-output-port out)
           (system "sudo" "cp" tmp-path dest)))
@@ -1715,7 +1715,7 @@
    (else
     (call-with-temp-dir
      "pkg"
-     (lambda (dir)
+     (lambda (dir preserve)
        (tar-extract snowball (lambda (f) (make-path dir (path-strip-top f))))
        (let ((libs (filter-map (lambda (lib) (build-library impl cfg lib dir))
                                (package-libraries pkg))))
@@ -1745,7 +1745,8 @@
                 `(,@(remove (lambda (x)
                               (and (pair? x) (eq? 'installed-files (car x))))
                             pkg)
-                  (installed-files ,@installed-files)))))))))))
+                  (installed-files ,@installed-files))))
+             (preserve))))))))
 
 (define (install-package-from-file repo impl cfg file)
   (let ((pkg (package-file-meta file))

lib/chibi/temp-file.scm

@@ -1,8 +1,21 @@
 
-(define (call-with-temp-file template proc)
-  (let ((base (string-append
+;;> Runs a procedure on a temporary file.  \var{proc} should be a
+;;> procedure of three values: \scheme{(path out preserve)}, where
+;;> \scheme{path} is the path to the temporary file, \scheme{out} is
+;;> an output port opened on the file, and \scheme{preserve} is a
+;;> thunk to disable deleting the file.  The file name will be in a
+;;> temp directory, based on \var{template} and having the same
+;;> extension if present, with permissions from the optional
+;;> \var{mode} which defaults to \scheme{#o700}.  Returns the result
+;;> of \var{proc}, after first deleting the file if the
+;;> \scheme{preserve} thunk was not called.
+
+(define (call-with-temp-file template proc . o)
+  (let* ((mode (if (pair? o) (car o) #o700))
+         (pid (current-process-id))
+         (base (string-append
                 "/tmp/" (path-strip-extension template)
-               "-" (number->string (current-process-id)) "-"
+                "-" (number->string pid) "-"
                 (number->string (exact (round (current-second)))) "-"))
          (ext (or (path-extension template) "tmp")))
     (let lp ((i 0))
@@ -14,19 +27,33 @@
           (lp (+ i 1)))
          (else
           (let ((fd (open path
-                          (bitwise-ior open/write open/create open/exclusive))))
+                          (bitwise-ior open/write open/create open/exclusive)
+                          mode)))
             (if (not fd)
                 (if (file-exists? path) ;; created between test and open
                     (lp (+ i 1))
                     (error "Couldn't generate temp file in /tmp " path))
-                (let* ((out (open-output-file-descriptor fd #o700))
-                       (res (proc path out)))
+                (let* ((out (open-output-file-descriptor fd))
+                       (preserve? #f)
+                       (res (proc path out (lambda () (set! preserve? #t)))))
                   (close-output-port out)
-                  (delete-file path)
+                  (if (and (not preserve?) (equal? pid (current-process-id)))
+                      (delete-file path))
                   res)))))))))
 
-(define (call-with-temp-dir template proc)
-  (let* ((pid (current-process-id))
+;;> Runs a procedure on a temporary directory.  \var{proc} should be a
+;;> procedure of two values: \scheme{(path preserve)}, where
+;;> \scheme{path} is the path to the temporary directory and
+;;> \scheme{preserve} is a thunk to disable deleting the dir.  The
+;;> directory name will be in a temp directory, based on
+;;> \var{template}, with permissions from the optional \var{mode}
+;;> which defaults to \scheme{#o700}.  Returns the result of
+;;> \var{proc}, after first deleting the file hierarchy rooted at
+;;> \scheme{path} if the \scheme{preserve} thunk was not called.
+
+(define (call-with-temp-dir template proc . o)
+  (let* ((mode (if (pair? o) (car o) #o700))
+         (pid (current-process-id))
          (base (string-append
                 "/tmp/" template "-" (number->string pid) "-"
                 (number->string (exact (round (current-second)))) "-")))
@@ -37,10 +64,11 @@
           (error "Repeatedly failed to generate temp dir in /tmp " path))
          ((file-exists? path)
           (lp (+ i 1)))
-         ((create-directory path #o700)
-          (let ((res (proc path)))
+         ((create-directory path mode)
+          (let* ((preserve? #f)
+                 (res (proc path (lambda () (set! preserve? #t)))))
             ;; sanity check for host threading issues and broken forks
-            (if (equal? pid (current-process-id))
+            (if (and (not preserve?) (equal? pid (current-process-id)))
                 (delete-file-hierarchy path))
             res))
          (else

lib/chibi/zlib.scm

@@ -50,7 +50,7 @@
 ;; Use a temp file to avoid dead-lock issues with pipes.
 (define (process-run-bytevector cmd bvec)
   (call-with-temp-file "bvec"
-    (lambda (path out)
+    (lambda (path out preserve)
       (write-bytevector bvec out)
       (close-output-port out)
       (process->bytevector (append cmd (list path))))))