Add an optional argument to TEMPORARY-FILE-PATHNAME for a procedure
authorTaylor R. Campbell <net/mumble/campbell>
Wed, 10 Sep 2008 14:55:49 +0000 (14:55 +0000)
committerTaylor R. Campbell <net/mumble/campbell>
Wed, 10 Sep 2008 14:55:49 +0000 (14:55 +0000)
that transforms the generated pathname before trying to allocate a
temporary file.  Implemented only on Unix because that's all I can
test, and the only user of it at the moment will be liarc, which runs
only on Unix anyway.

v7/src/runtime/unxprm.scm

index 93dbd7ac69f53f482686c7160776d8ea10a3ba2f..c625e1ed562db0b1bb4b4ea09447f0103f0d2ab3 100644 (file)
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: unxprm.scm,v 1.75 2008/01/30 20:02:36 cph Exp $
+$Id: unxprm.scm,v 1.76 2008/09/10 14:55:49 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -40,7 +40,7 @@ USA.
 
 (define unix/file-access file-access)  ;upwards compatability
 
-(define (temporary-file-pathname #!optional directory)
+(define (temporary-file-pathname #!optional directory transformer)
   (let ((root-string
         (string-append
          "sch"
@@ -49,11 +49,19 @@ USA.
        (directory
         (if (or (default-object? directory) (not directory))
             (temporary-directory-pathname)
-            (pathname-as-directory directory))))
+            (pathname-as-directory directory)))
+       (transformer
+        (if (or (default-object? transformer) (not transformer))
+            identity-procedure
+            (begin
+              (guarantee-procedure-of-arity transformer 1
+                                            'TEMPORARY-FILE-PATHNAME)
+              transformer))))
     (let loop ((ext 0))
       (let ((pathname
-            (merge-pathnames (string-append root-string (number->string ext))
-                             directory)))
+            (transformer
+             (merge-pathnames (string-append root-string (number->string ext))
+                              directory))))
        (if (allocate-temporary-file pathname)
            (begin
              ;; Make sure file isn't readable or writeable by anyone