[Chicken-hackers] [PATCH] use PID to reduce conflicts for temporary file names

[Felix]

The attached patch adds the current process-ID to the filenames
generated by "create-temporary-filename"/"create-temporary-directory".

This patch fixes #810.


cheers,
felix

>From 3ed258833aef25dd3f46ecaca46ed525ba28d573 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Mon, 16 Jul 2012 07:15:57 +0200
Subject: [PATCH] Use PID when creating temporary files or directories to reduce 
the risk of reusing temporary filenames. This can be a problem when (for 
example) two processes create a large number of temporary files concurrently.

---
 files.scm        |   14 ++++++++++----
 posix-common.scm |    2 +-
 runtime.c        |   50 +++++++++++++++++++++++++-------------------------
 3 files changed, 36 insertions(+), 30 deletions(-)

diff --git a/files.scm b/files.scm
index 3fae8f5..0b28882 100644
--- a/files.scm
+++ b/files.scm
@@ -295,7 +295,8 @@ EOF
 (define create-temporary-directory)
 
 (let ((temp #f)
-      (temp-prefix "temp"))
+      (temp-prefix "temp")
+      (string-append string-append))
   (define (tempdir)
     (or temp
        (let ((tmp 
@@ -312,9 +313,12 @@ EOF
        (let* ((n (##core#inline "C_random_fixnum" #x10000))
               (pn (make-pathname 
                    (tempdir)
-                   (##sys#string-append 
+                   (string-append 
                     temp-prefix
-                    (number->string n 16)) ext)) )
+                    (number->string n 16)
+                    "."
+                    (##sys#number->string (##sys#fudge 33))) ; PID
+                   ext)) )
          (if (file-exists? pn)
              (loop)
              (call-with-output-file pn (lambda (p) pn)) ) ) ) ) )
@@ -326,7 +330,9 @@ EOF
                    (tempdir)
                    (string-append
                     temp-prefix
-                    (number->string n 16)))))
+                    (number->string n 16)
+                    "."
+                    (##sys#number->string (##sys#fudge 33)))))) ; PID
          (if (directory-exists? pn) 
              (loop)
              (let ((r (##core#inline "C_mkdir" (##sys#make-c-string pn 
'create-temporary-directory))))
diff --git a/posix-common.scm b/posix-common.scm
index c39ea3e..ee01c84 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -505,7 +505,7 @@ EOF
 
 ;;; Processes
 
-(define current-process-id (foreign-lambda int "C_getpid"))
+(define (current-process-id) (##sys#fudge 33))
 
 (define process-wait
   (lambda args
diff --git a/runtime.c b/runtime.c
index 04d476f..dd1c837 100644
--- a/runtime.c
+++ b/runtime.c
@@ -4113,112 +4113,112 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
       if(locative_table[ i ] != C_SCHEME_UNDEFINED) ++j;
     return C_fix(j);
 
-  case C_fix(20):
+  case C_fix(20):              /* unused */
     return C_SCHEME_FALSE;
 
-  case C_fix(21):
+  case C_fix(21):              /* largest fixnum */
     return C_fix(C_MOST_POSITIVE_FIXNUM);
 
-  case C_fix(22):
+  case C_fix(22):              /* does this process use a private 
egg-repository? */
     return C_mk_bool(private_repository != NULL);
 
-  case C_fix(23):
+  case C_fix(23):              /* seconds since process startup */
     return C_fix(C_startup_time_seconds);
 
-  case C_fix(24):
+  case C_fix(24):              /* dynamic loading available? */
 #ifdef NO_DLOAD2
     return C_SCHEME_FALSE;
 #else
     return C_SCHEME_TRUE;
 #endif
 
-  case C_fix(25):
+  case C_fix(25):              /* REPL on error? XXX Is this used anywhere? */
     return C_mk_bool(C_enable_repl);
 
-  case C_fix(26):
+  case C_fix(26):              /* number of untriggered finalizers */
     return C_fix(live_finalizer_count);
 
-  case C_fix(27):
+  case C_fix(27):              /* total number of finalizers used and unused */
     return C_fix(allocated_finalizer_count);
 
-  case C_fix(28):
+  case C_fix(28):              /* are procedure-tabled enabled? */
 #ifdef C_ENABLE_PTABLES
     return C_SCHEME_TRUE;
 #else
     return C_SCHEME_FALSE;
 #endif
 
-  case C_fix(29):
+  case C_fix(29):              /* size of ring-buffer used to hold trace 
entries */
     return C_fix(C_trace_buffer_size);
 
-  case C_fix(30):
+  case C_fix(30):              /* unused */
     return C_SCHEME_FALSE;
 
-  case C_fix(31):
+  case C_fix(31):              /* GC time since last invocation */
     tgc = timer_accumulated_gc_ms;
     timer_accumulated_gc_ms = 0;
     return C_fix(tgc);
 
-  case C_fix(32):
+  case C_fix(32):              /* are GC-hooks enabled? */
 #ifdef C_GC_HOOKS
     return C_SCHEME_TRUE;
 #else
     return C_SCHEME_FALSE;
 #endif
 
-  case C_fix(33):
-    return C_SCHEME_TRUE;
+  case C_fix(33):              /* return process-ID */
+    return C_fix(C_getpid());
 
-  case C_fix(34):
+  case C_fix(34):              /* effective maximum for procedure arguments */
 #ifdef C_HACKED_APPLY
     return C_fix(TEMPORARY_STACK_SIZE);
 #else
     return C_fix(126);
 #endif
 
-  case C_fix(35):
+  case C_fix(35):              /* unused */
     /* used to be apply-hook indicator */
     return C_SCHEME_FALSE;
     
-  case C_fix(36):
+  case C_fix(36):              /* toggle debug mode */
     debug_mode = !debug_mode;
     return C_mk_bool(debug_mode);
 
-  case C_fix(37):
+  case C_fix(37):              /* heap-dump enabled? */
     return C_mk_bool(dump_heap_on_exit);
 
-  case C_fix(38):
+  case C_fix(38):              /* SVN revision of built sources */
 #ifdef C_SVN_REVISION
     return C_fix(C_SVN_REVISION);
 #else
     return C_fix(0);
 #endif
 
-  case C_fix(39):
+  case C_fix(39):              /* is this a cross-chicken? */
 #if defined(C_CROSS_CHICKEN) && C_CROSS_CHICKEN
     return C_SCHEME_TRUE;
 #else
     return C_SCHEME_FALSE;
 #endif
 
-  case C_fix(40):
+  case C_fix(40):              /* assembly stub for "apply" available? */
 #if defined(C_HACKED_APPLY)
     return C_SCHEME_TRUE;
 #else
     return C_SCHEME_FALSE;
 #endif
 
-  case C_fix(41):
+  case C_fix(41):              /* major CHICKEN version */
     return C_fix(C_MAJOR_VERSION);
 
-  case C_fix(42):
+  case C_fix(42):              /* binary version number */
 #ifdef C_BINARY_VERSION
     return C_fix(C_BINARY_VERSION);
 #else
     return C_fix(0);
 #endif
 
-  case C_fix(43):
+  case C_fix(43):              /* minor CHICKEN version */
     return C_fix(C_MINOR_VERSION);
 
   default: return C_SCHEME_UNDEFINED;
-- 
1.7.0.4