From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Fri, 24 Mar 2017 18:35:45 +0000 (-0700)
Subject: Add with-temporary-file (for tempfiles that are renamed into place).
X-Git-Tag: mit-scheme-pucked-9.2.12~168
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3b1cae64c9c9730a4ee0595433d1482edc09f7fc;p=mit-scheme.git

Add with-temporary-file (for tempfiles that are renamed into place).
---

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 886377c61..a2e62c664 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -677,6 +677,7 @@ USA.
 	  string->mime-type
 	  string-is-mime-token?
 	  string-is-mime-type?
+	  with-temporary-file
 	  write-mime-type)
   (initialization (initialize-package!)))
 
diff --git a/src/runtime/sfile.scm b/src/runtime/sfile.scm
index 619ed9888..0bca2af51 100644
--- a/src/runtime/sfile.scm
+++ b/src/runtime/sfile.scm
@@ -206,6 +206,17 @@ USA.
      (lambda () (receiver pathname))
      (lambda () (deallocate-temporary-file pathname)))))
 
+(define (with-temporary-file pathname thunk)
+  (dynamic-wind
+   (lambda ()
+     (let ((updater (fixed-objects-updater 'files-to-delete))
+	   (string (string-for-primitive (->namestring pathname))))
+       (with-files-to-delete-locked
+	(lambda ()
+	  (updater (lambda (filenames) (cons string filenames)))))))
+   thunk
+   (lambda () (deallocate-temporary-file pathname))))
+
 (define files-to-delete-mutex)
 
 (define (with-files-to-delete-locked thunk)
@@ -226,7 +237,8 @@ USA.
 		   #t)))))))
 
 (define (deallocate-temporary-file pathname)
-  (delete-file-no-errors pathname)
+  (if (file-exists? pathname)
+      (delete-file-no-errors pathname))
   (let ((updater (fixed-objects-updater 'files-to-delete))
 	(filename (string-for-primitive (->namestring pathname))))
     (with-files-to-delete-locked