~ chicken-core (chicken-5) 6256ae18ec023aef4cf388d3a0969c9928ac2fb2
commit 6256ae18ec023aef4cf388d3a0969c9928ac2fb2
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Jul 16 07:15:57 2012 +0200
Commit: Mario Domenech Goulart <mario.goulart@gmail.com>
CommitDate: Mon Jul 16 11:26:17 2012 -0300
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.
This fixes #810 (https://bugs.call-cc.org/ticket/810)
Signed-off-by: Mario Domenech Goulart <mario.goulart@gmail.com>
diff --git a/files.scm b/files.scm
index 3fae8f52..0b288825 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 c39ea3ec..ee01c845 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 04d476fa..dd1c8375 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;
Trap