~ chicken-core (chicken-5) 0440011fdb38d94119a38162c42c5cd1bac8dab7
commit 0440011fdb38d94119a38162c42c5cd1bac8dab7
Author: felix <bunny351@gmail.com>
AuthorDate: Thu Apr 29 09:53:33 2010 +0200
Commit: felix <bunny351@gmail.com>
CommitDate: Thu Apr 29 09:53:33 2010 +0200
- removed deprecated `-host-extension' option of `chicken-install'
- added `create-temporary-directory' (files unit)
- removed deprecated second optional argument to `make-absolute-pathname' (files unit)
- removed deprecated `canonical-path' (posix unit)
- removed deprecated `current-environment' (posix unit)
- started moving definitions into `posix-common.scm'
diff --git a/chicken-install.scm b/chicken-install.scm
index c9063a67..9bcb7c6e 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -614,8 +614,7 @@ EOF
((string=? "-test" arg)
(set! *run-tests* #t)
(loop (cdr args) eggs))
- ((or (string=? "-host" arg)
- (string=? "-host-extension" arg)) ; DEPRECATED
+ ((string=? "-host" arg)
(set! *host-extension* #t)
(loop (cdr args) eggs))
((string=? "-deploy" arg)
diff --git a/distribution/manifest b/distribution/manifest
index bb470550..0877f8d5 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -81,6 +81,7 @@ regex.scm
irregex.scm
posixunix.scm
posixwin.scm
+posix-common.scm
profiler.scm
runtime.c
scheduler.scm
diff --git a/files.import.scm b/files.import.scm
index 344474da..334f0f5d 100644
--- a/files.import.scm
+++ b/files.import.scm
@@ -32,6 +32,7 @@
make-pathname
directory-null?
make-absolute-pathname
+ create-temporary-directory
create-temporary-file
decompose-pathname
absolute-pathname?
diff --git a/files.scm b/files.scm
index b87df181..0b7edf81 100644
--- a/files.scm
+++ b/files.scm
@@ -40,7 +40,15 @@
(usual-integrations)
(fixnum)
(hide chop-pds absolute-pathname-root root-origin root-directory split-directory)
- (disable-interrupts) )
+ (disable-interrupts)
+ (foreign-declare #<<EOF
+#ifndef _WIN32
+# define C_mkdir(str) C_fix(mkdir(C_c_string(str), S_IRWXU | S_IRWXG | S_IRWXO))
+#else
+# define C_mkdir(str) C_fix(mkdir(C_c_string(str)))
+#endif
+EOF
+))
(cond-expand
[paranoia]
@@ -248,11 +256,11 @@
ext) ) )
(set! make-pathname
- (lambda (dirs file #!optional ext pds) ; The 'pds' argument is DEPRECATED
+ (lambda (dirs file #!optional ext)
(_make-pathname 'make-pathname (canonicalize-dirs dirs pds) file ext pds)))
(set! make-absolute-pathname
- (lambda (dirs file #!optional ext pds) ; The 'pds' argument is DEPRECATED
+ (lambda (dirs file #!optional ext)
(_make-pathname
'make-absolute-pathname
(let ([dir (canonicalize-dirs dirs pds)])
@@ -335,24 +343,55 @@
(let-values ([(dir file _) (decompose-pathname pn)])
(make-pathname dir file ext) ) ) ) )
-(define create-temporary-file
- (let ([get-environment-variable get-environment-variable]
- [make-pathname make-pathname]
- [file-exists? file-exists?]
- [call-with-output-file call-with-output-file] )
- (lambda ext
- (let ((dir (or (get-environment-variable "TMPDIR")
- (get-environment-variable "TEMP")
- (get-environment-variable "TMP")
- (file-exists? "/tmp")))
- (ext (if (pair? ext) (car ext) "tmp")))
- (##sys#check-string ext 'create-temporary-file)
- (let loop ()
- (let* ([n (##sys#fudge 16)]
- [pn (make-pathname dir (##sys#string-append "t" (number->string n 16)) ext)] )
- (if (file-exists? pn)
- (loop)
- (call-with-output-file pn (lambda (p) pn)) ) ) ) ) ) ) )
+(define create-temporary-file)
+(define create-temporary-directory)
+
+(let ((get-environment-variable get-environment-variable)
+ (make-pathname make-pathname)
+ (file-exists? file-exists?)
+ (directory-exists? directory-exists?)
+ (call-with-output-file call-with-output-file)
+ (temp #f)
+ (temp-prefix "temp"))
+ (define (tempdir)
+ (or temp
+ (let ((tmp
+ (or (get-environment-variable "TMPDIR")
+ (get-environment-variable "TEMP")
+ (get-environment-variable "TMP")
+ (file-exists? "/tmp")
+ (
+ (set! temp tmp)
+ tmp)))
+ (set! create-temporary-file
+ (lambda (#!optional (ext "tmp"))
+ (##sys#check-string ext 'create-temporary-file)
+ (let loop ()
+ (let* ((n (##sys#fudge 16))
+ (pn (make-pathname
+ (tempdir)
+ (##sys#string-append
+ temp-prefix
+ (number->string n 16)) ext)) )
+ (if (file-exists? pn)
+ (loop)
+ (call-with-output-file pn (lambda (p) pn)) ) ) ) ) )
+ (set! create-temporary-directory
+ (lambda ()
+ (let loop ()
+ (let* ((n (##sys#fudge 16))
+ (pn (make-pathname
+ (tempdir)
+ (string-append
+ temp-prefix
+ (number->string n 16)))))
+ (if (directory-exists? pn)
+ (loop)
+ (let ((r (##core#inline "C_mkdir" (##sys#make-c-string pn))))
+ (##sys#signal-hook
+ #:file-error 'create-temporary-directory
+ (##sys#string-append "cannot create temporary directory - " strerror)
+ name) )))))))
;;; normalize pathname for a particular platform
@@ -365,9 +404,9 @@
(display display)
(bldplt (if (memq (build-platform) '(msvc mingw32)) 'windows 'unix)) )
(define (addpart part parts)
- (cond ((string=? "." part) parts )
- ((string=? ".." part) (if (null? parts) '("..") (cdr parts)) )
- (else (cons part parts) ) ) )
+ (cond ((string=? "." part) parts)
+ ((string=? ".." part) (if (null? parts) '("..") (cdr parts)))
+ (else (cons part parts) ) ) )
(lambda (path #!optional (platform bldplt))
(let ((sep (if (eq? platform 'windows) #\\ #\/)))
(##sys#check-string path 'normalize-pathname)
diff --git a/library.scm b/library.scm
index dabacde0..e3204a43 100644
--- a/library.scm
+++ b/library.scm
@@ -1244,7 +1244,7 @@ EOF
(lambda (key args #!optional thunk)
(##sys#check-list args 'get-keyword)
(let ((r (##core#inline "C_i_get_keyword" key args tag)))
- (if (eq? r tag)
+ (if (eq? r tag) ; not found
(and thunk (thunk))
r)))))
diff --git a/manual/Unit files b/manual/Unit files
index 7d9e0985..46285a9f 100644
--- a/manual/Unit files
+++ b/manual/Unit files
@@ -110,7 +110,7 @@ Returns 3 values: the {{base-origin}}, {{base-directory}}, and the
* On Windows {{(decompose-directory "c:foo/bar")}} => {{"c:" #f ("foo" "bar")}}
-=== Temporary files
+=== Temporary files and directories
==== create-temporary-file
@@ -119,7 +119,19 @@ Returns 3 values: the {{base-origin}}, {{base-directory}}, and the
Creates an empty temporary file and returns its pathname. If
{{EXTENSION}} is not given, then {{.tmp}} is used. If the
environment variable {{TMPDIR, TEMP}} or {{TMP}} is set,
-then the pathname names a file in that directory.
+then the pathname names a file in that directory. If none of
+the environment variables is given the location of the
+temporary file defaults to {{/tmp}} if it exists or the
+current-directory
+
+
+==== create-temporary-directory
+
+<procedure>(create-temporary-directory)</procedure>
+
+Creates an empty temporary directory and returns its pathname. If the
+environment variable {{TMPDIR, TEMP}} or {{TMP}} is set, then the
+temporary directory is created at that location.
=== Deleting a file without signalling an error
diff --git a/posix-common.scm b/posix-common.scm
new file mode 100644
index 00000000..508fad7f
--- /dev/null
+++ b/posix-common.scm
@@ -0,0 +1,69 @@
+;;;; posix-common.scm - common code for UNIX and Windows versions of the posix unit
+;
+; Copyright (c) 2010, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
+; disclaimer in the documentation and/or other materials provided with the distribution.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+;;; Find matching files:
+
+(define find-files
+ (let ([glob glob]
+ [string-match string-match]
+ [make-pathname make-pathname]
+ [pathname-file pathname-file]
+ [directory? directory?] )
+ (lambda (dir pred . action-id-limit)
+ (let-optionals
+ action-id-limit
+ ([action (lambda (x y) (cons x y))] ; we want cons inlined
+ [id '()]
+ [limit #f] )
+ (##sys#check-string dir 'find-files)
+ (let* ([depth 0]
+ [lproc
+ (cond [(not limit) (lambda _ #t)]
+ [(fixnum? limit) (lambda _ (fx< depth limit))]
+ [else limit] ) ]
+ [pproc
+ (if (or (string? pred) (regexp? pred))
+ (lambda (x) (string-match pred x))
+ pred) ] )
+ (let loop ([fs (glob (make-pathname dir "*"))]
+ [r id] )
+ (if (null? fs)
+ r
+ (let ([f (##sys#slot fs 0)]
+ [rest (##sys#slot fs 1)] )
+ (cond [(directory? f)
+ (cond [(member (pathname-file f) '("." "..")) (loop rest r)]
+ [(lproc f)
+ (loop rest
+ (fluid-let ([depth (fx+ depth 1)])
+ (loop (glob (make-pathname f "*"))
+ (if (pproc f) (action f r) r)) ) ) ]
+ [else (loop rest (if (pproc f) (action f r) r))] ) ]
+ [(pproc f) (loop rest (action f r))]
+ [else (loop rest r)] ) ) ) ) ) ) ) ) )
+
+
+;;; TODO: add more here...
diff --git a/posix.import.scm b/posix.import.scm
index 7ddf0ebe..2118ccb9 100644
--- a/posix.import.scm
+++ b/posix.import.scm
@@ -29,7 +29,6 @@
'(_exit
call-with-input-pipe
call-with-output-pipe
- canonical-path ; DEPRECATED
change-directory
change-file-mode
change-file-owner
@@ -44,7 +43,6 @@
current-effective-group-id
current-effective-user-id
current-effective-user-name
- current-environment ; DEPRECATED
get-environment-variables
current-group-id
current-process-id
diff --git a/posixunix.scm b/posixunix.scm
index 28460997..6f0bf358 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -956,72 +956,6 @@ EOF
(##sys#substring buffer 0 len)
(posix-error #:file-error 'current-directory "cannot retrieve current directory") ) ) ) ) ) )
-(define canonical-path ; DEPRECATED
- (let ((null? null?)
- (char=? char=?)
- (string=? string=?)
- (alpha? char-alphabetic?)
- (sref string-ref)
- (ssplit (cut string-split <> "/\\"))
- (sappend string-append)
- (isperse (cut string-intersperse <> "/"))
- (sep? (lambda (c) (or (char=? #\/ c) (char=? #\\ c))))
- (get-environment-variable get-environment-variable)
- (user current-user-name)
- (cwd (let ((cw current-directory))
- (lambda ()
- (condition-case (cw)
- (var () "/"))))))
- (lambda (path)
- (##sys#check-string path 'canonical-path)
- (let ((p (cond ((fx= 0 (##sys#size path))
- (sappend (cwd) "/"))
- ((and (fx< (##sys#size path) 3)
- (sep? (sref path 0)))
- path)
- ((fx= 1 (##sys#size path))
- (sappend (cwd) "/" path))
- ((and (char=? #\~ (sref path 0))
- (sep? (sref path 1)))
- (sappend
- (or (get-environment-variable "HOME")
- (sappend "/home/" (user)))
- (##sys#substring path 1
- (##sys#size path))))
- ((fx= 2 (##sys#size path))
- (sappend (cwd) "/" path))
- ((and (alpha? (sref path 0))
- (char=? #\: (sref path 1))
- (sep? (sref path 2)))
- (##sys#substring path 3 (##sys#size path)))
- ((and (char=? #\/ (sref path 0))
- (alpha? (sref path 1))
- (char=? #\: (sref path 2)))
- (##sys#substring path 3 (##sys#size path)))
- ((sep? (sref path 0))
- path)
- (else
- (sappend (cwd) "/" path)))))
- (let loop ((l (ssplit p))
- (r '()))
- (if (null? l)
- (if (null? r)
- "/"
- (if (sep? (sref p (- (##sys#size p) 1)))
- (sappend
- "/"
- (isperse (reverse (cons "" r))))
- (sappend
- "/"
- (isperse (reverse r)))))
- (loop
- (cdr l)
- (if (string=? ".." (car l))
- (cdr r)
- (if (string=? "." (car l))
- r
- (cons (car l) r))))))))))
-
;;; Pipes:
@@ -1904,8 +1838,6 @@ EOF
(scan (fx+ j 1)) ) )
'() ) ) ) ) ) )
-(define current-environment get-environment-variables) ; DEPRECATED
-
;;; Memory mapped I/O:
@@ -2357,47 +2289,6 @@ EOF
(lambda (cmd #!optional args env)
(%process 'process* #t cmd args env) )) )
-;;; Find matching files:
-
-(define find-files
- (let ([glob glob]
- [string-match string-match]
- [make-pathname make-pathname]
- [pathname-file pathname-file]
- [directory? directory?] )
- (lambda (dir pred . action-id-limit)
- (let-optionals
- action-id-limit
- ([action (lambda (x y) (cons x y))] ; we want cons inlined
- [id '()]
- [limit #f] )
- (##sys#check-string dir 'find-files)
- (let* ([depth 0]
- [lproc
- (cond [(not limit) (lambda _ #t)]
- [(fixnum? limit) (lambda _ (fx< depth limit))]
- [else limit] ) ]
- [pproc
- (if (or (string? pred) (regexp? pred))
- (lambda (x) (string-match pred x))
- pred) ] )
- (let loop ([fs (glob (make-pathname dir "*"))]
- [r id] )
- (if (null? fs)
- r
- (let ([f (##sys#slot fs 0)]
- [rest (##sys#slot fs 1)] )
- (cond [(directory? f)
- (cond [(member (pathname-file f) '("." "..")) (loop rest r)]
- [(lproc f)
- (loop rest
- (fluid-let ([depth (fx+ depth 1)])
- (loop (glob (make-pathname f "*"))
- (if (pproc f) (action f r) r)) ) ) ]
- [else (loop rest (if (pproc f) (action f r) r))] ) ]
- [(pproc f) (loop rest (action f r))]
- [else (loop rest r)] ) ) ) ) ) ) ) ) )
-
;;; chroot:
@@ -2407,3 +2298,8 @@ EOF
(##sys#check-string dir 'set-root-directory!)
(when (fx< (chroot dir) 0)
(posix-error #:file-error 'set-root-directory! "unable to change root directory" dir) ) ) ) )
+
+
+;;; common code
+
+(include "posix-common.scm")
diff --git a/posixwin.scm b/posixwin.scm
index e422cbf8..85cfd3b3 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -1279,81 +1279,6 @@ EOF
(##sys#signal-hook #:file-error 'current-directory "cannot retrieve current directory") ) ) ) ) ) )
-(define canonical-path ;;DEPRECATED
- (let ((null? null?)
- (char=? char=?)
- (string=? string=?)
- (alpha? char-alphabetic?)
- (sref string-ref)
- (ssplit (cut string-split <> "/\\"))
- (sappend string-append)
- (isperse (cut string-intersperse <> "\\"))
- (sep? (lambda (c) (or (char=? #\/ c) (char=? #\\ c))))
- (user current-user-name)
- (cwd (let ((cw current-directory))
- (lambda ()
- (condition-case (cw)
- (var () "c:\\"))))))
- (lambda (path)
- (##sys#check-string path 'canonical-path)
- (let ((p (cond ((fx= 0 (##sys#size path))
- (sappend (cwd) "\\"))
- ((and (fx< (##sys#size path) 3)
- (sep? (sref path 0)))
- (sappend
- (##sys#substring (cwd) 0 2)
- path))
- ((fx= 1 (##sys#size path))
- (sappend (cwd) "\\" path))
- ((and (char=? #\~ (sref path 0))
- (sep? (sref path 1)))
- (sappend
- (##sys#substring (cwd) 0 3)
- "Documents and Settings\\"
- (user)
- (##sys#substring path 1
- (##sys#size path))))
- ((fx= 2 (##sys#size path))
- (sappend (cwd) "\\" path))
- ((and (alpha? (sref path 0))
- (char=? #\: (sref path 1))
- (sep? (sref path 2)))
- path)
- ((and (char=? #\/ (sref path 0))
- (alpha? (sref path 1))
- (char=? #\: (sref path 2)))
- (sappend
- (##sys#substring path 1 3)
- "\\"
- (##sys#substring path 3
- (##sys#size path))))
- ((sep? (sref path 0))
- (sappend
- (##sys#substring (cwd) 0 2)
- path))
- (else
- (sappend (cwd) "\\" path)))))
- (let loop ((l (ssplit (##sys#substring p 3 (##sys#size p))))
- (r '()))
- (if (null? l)
- (if (null? r)
- (##sys#substring p 0 3)
- (if (sep? (sref p (- (##sys#size p) 1)))
- (sappend
- (##sys#substring p 0 3)
- (isperse (reverse (cons "" r))))
- (sappend
- (##sys#substring p 0 3)
- (isperse (reverse r)))))
- (loop
- (cdr l)
- (if (string=? ".." (car l))
- (cdr r)
- (if (string=? "." (car l))
- r
- (cons (car l) r))))))))))
-
-
;;; Pipes:
(let ()
@@ -1707,7 +1632,6 @@ EOF
(scan (fx+ j 1)) ) )
'() ) ) ) ) ) )
-(define current-environment get-environment-variables) ; DEPRECATED
;;; Time related things:
@@ -2059,47 +1983,6 @@ EOF
(##sys#error 'current-user-name "cannot retrieve current user-name") ) ) )
-;;; Find matching files:
-
-(define find-files
- (let ([glob glob]
- [string-match string-match]
- [make-pathname make-pathname]
- [pathname-file pathname-file]
- [directory? directory?] )
- (lambda (dir pred . action-id-limit)
- (let-optionals
- action-id-limit
- ([action (lambda (x y) (cons x y))] ; we want cons inlined
- [id '()]
- [limit #f] )
- (##sys#check-string dir 'find-files)
- (let* ([depth 0]
- [lproc
- (cond [(not limit) (lambda _ #t)]
- [(fixnum? limit) (lambda _ (fx< depth limit))]
- [else limit] ) ]
- [pproc
- (if (or (string? pred) (regexp? pred))
- (lambda (x) (string-match pred x))
- pred) ] )
- (let loop ([fs (glob (make-pathname dir "*"))]
- [r id] )
- (if (null? fs)
- r
- (let ([f (##sys#slot fs 0)]
- [rest (##sys#slot fs 1)] )
- (cond [(directory? f)
- (cond [(member (pathname-file f) '("." "..")) (loop rest r)]
- [(lproc f)
- (loop rest
- (fluid-let ([depth (fx+ depth 1)])
- (loop (glob (make-pathname f "*"))
- (if (pproc f) (action f r) r)) ) ) ]
- [else (loop rest (if (pproc f) (action f r) r))] ) ]
- [(pproc f) (loop rest (action f r))]
- [else (loop rest r)] ) ) ) ) ) ) ) ) )
-
;;; unimplemented stuff:
(define-syntax define-unimplemented
@@ -2172,3 +2055,8 @@ EOF
(define prot/none 0)
(define prot/read 0)
(define prot/write 0)
+
+
+;;; common code
+
+(include "posix-common.scm")
diff --git a/rules.make b/rules.make
index 27c02387..7c34c762 100644
--- a/rules.make
+++ b/rules.make
@@ -860,9 +860,9 @@ srfi-69.c: $(SRCDIR)srfi-69.scm $(SRCDIR)private-namespace.scm
$(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@ -extend $(SRCDIR)private-namespace.scm
utils.c: $(SRCDIR)utils.scm
$(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
-posixunix.c: $(SRCDIR)posixunix.scm
+posixunix.c: $(SRCDIR)posixunix.scm $(SRCDIR)posix-common.scm
$(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
-posixwin.c: $(SRCDIR)posixwin.scm
+posixwin.c: $(SRCDIR)posixwin.scm $(SRCDIR)posix-common.scm
$(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
regex.c: $(SRCDIR)regex.scm $(SRCDIR)irregex.scm
$(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
diff --git a/setup-api.scm b/setup-api.scm
index 01d14967..4b1bfb5f 100644
--- a/setup-api.scm
+++ b/setup-api.scm
@@ -103,8 +103,6 @@
(define (shellpath str)
(qs (normalize-pathname str)))
-(define (cross-chicken) (##sys#fudge 39)) ; DEPRECATED
-
(define *csc-options* '())
(define *base-directory* (current-directory))
diff --git a/types.db b/types.db
index bbd557b8..f9f366af 100644
--- a/types.db
+++ b/types.db
@@ -519,6 +519,7 @@
(make-pathname (procedure make-pathname (* * #!optional string string) string))
(directory-null? (procedure directory-null? (string) boolean))
(make-absolute-pathname (procedure make-absolute-pathname (* * #!optional string string) string))
+(create-temporary-directory (procedure create-temporary-directory () string))
(create-temporary-file (procedure create-temporary-file (#!optional string) string))
(decompose-pathname (procedure decompose-pathname (string) * * *))
(absolute-pathname? (procedure absolute-pathname? (string) boolean))
Trap