~ chicken-core (chicken-5) 33eedb468111336a33fef16408c1b17a3d1e9d70
commit 33eedb468111336a33fef16408c1b17a3d1e9d70
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Mon Feb 19 21:23:04 2018 +1300
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sat Feb 24 15:30:56 2018 +0100
Move `directory' to chicken.file
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/file.scm b/file.scm
index 3a57d8b2..4e1e4a90 100644
--- a/file.scm
+++ b/file.scm
@@ -41,14 +41,101 @@
(foreign-declare #<<EOF
#include <errno.h>
+#define C_rmdir(str) C_fix(rmdir(C_c_string(str)))
+
#ifndef _WIN32
# include <sys/stat.h>
# 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)))
+# define C_mkdir(str) C_fix(mkdir(C_c_string(str)))
+#endif
+
+#if !defined(_WIN32) || defined(__CYGWIN__)
+# include <sys/types.h>
+# include <dirent.h>
+#else
+struct dirent
+{
+ char * d_name;
+};
+
+typedef struct
+{
+ struct _finddata_t fdata;
+ int handle;
+ struct dirent current;
+} DIR;
+
+static DIR * C_fcall
+opendir(const char *name)
+{
+ int name_len = strlen(name);
+ int what_len = name_len + 3;
+ DIR *dir = (DIR *)malloc(sizeof(DIR));
+ char *what;
+ if (!dir)
+ {
+ errno = ENOMEM;
+ return NULL;
+ }
+ what = (char *)malloc(what_len);
+ if (!what)
+ {
+ free(dir);
+ errno = ENOMEM;
+ return NULL;
+ }
+ C_strlcpy(what, name, what_len);
+ if (strchr("\\/", name[name_len - 1]))
+ C_strlcat(what, "*", what_len);
+ else
+ C_strlcat(what, "\\*", what_len);
+
+ dir->handle = _findfirst(what, &dir->fdata);
+ if (dir->handle == -1)
+ {
+ free(what);
+ free(dir);
+ return NULL;
+ }
+ dir->current.d_name = NULL; /* as the first-time indicator */
+ free(what);
+ return dir;
+}
+
+static int C_fcall
+closedir(DIR * dir)
+{
+ if (dir)
+ {
+ int res = _findclose(dir->handle);
+ free(dir);
+ return res;
+ }
+ return -1;
+}
+
+static struct dirent * C_fcall
+readdir(DIR * dir)
+{
+ if (dir)
+ {
+ if (!dir->current.d_name /* first time after opendir */
+ || _findnext(dir->handle, &dir->fdata) != -1)
+ {
+ dir->current.d_name = dir->fdata.name;
+ return &dir->current;
+ }
+ }
+ return NULL;
+}
#endif
-#define C_rmdir(str) C_fix(rmdir(C_c_string(str)))
+#define C_opendir(s,h) C_set_block_item(h, 0, (C_word) opendir(C_c_string(s)))
+#define C_readdir(h,e) C_set_block_item(e, 0, (C_word) readdir((DIR *)C_block_item(h, 0)))
+#define C_closedir(h) (closedir((DIR *)C_block_item(h, 0)), C_SCHEME_UNDEFINED)
+#define C_foundfile(e,b,l) (C_strlcpy(C_c_string(b), ((struct dirent *) C_block_item(e, 0))->d_name, l), C_fix(strlen(((struct dirent *) C_block_item(e, 0))->d_name)))
+
EOF
))
@@ -140,7 +227,33 @@ EOF
(##sys#string-append "cannot rename file - " strerror) old new))
new)
-;;; Directory management:
+
+;;; Directories:
+
+(define (directory #!optional (spec (current-directory)) show-dotfiles?)
+ (##sys#check-string spec 'directory)
+ (let ((buffer (make-string 256))
+ (handle (##sys#make-pointer))
+ (entry (##sys#make-pointer)))
+ (##core#inline
+ "C_opendir"
+ (##sys#make-c-string spec 'directory) handle)
+ (if (##sys#null-pointer? handle)
+ (posix-error #:file-error 'directory "cannot open directory" spec)
+ (let loop ()
+ (##core#inline "C_readdir" handle entry)
+ (if (##sys#null-pointer? entry)
+ (begin (##core#inline "C_closedir" handle) '())
+ (let* ((flen (##core#inline "C_foundfile" entry buffer (string-length buffer)))
+ (file (##sys#substring buffer 0 flen))
+ (char1 (string-ref file 0))
+ (char2 (and (fx> flen 1) (string-ref file 1))))
+ (if (and (eq? #\. char1)
+ (or (not char2)
+ (and (eq? #\. char2) (eq? 2 flen))
+ (not show-dotfiles?)))
+ (loop)
+ (cons file (loop)))))))))
(define-inline (*create-directory loc name)
(unless (fx= 0 (##core#inline "C_mkdir" (##sys#make-c-string name loc)))
@@ -182,6 +295,7 @@ EOF
(rmdir name))
(rmdir name))))
+
;;; file-copy and file-move : they do what you'd think.
(define (file-copy origfile newfile #!optional (clobber #f) (blocksize 1024))
diff --git a/posix-common.scm b/posix-common.scm
index adab12a9..98ffe85c 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -97,11 +97,6 @@ static char C_time_string [TIME_STRING_MAXLENGTH + 1];
#define C_set_file_ptr(port, ptr) (C_set_block_item(port, 0, (C_block_item(ptr, 0))), C_SCHEME_UNDEFINED)
-#define C_opendir(x,h) C_set_block_item(h, 0, (C_word) opendir(C_c_string(x)))
-#define C_closedir(h) (closedir((DIR *)C_block_item(h, 0)), C_SCHEME_UNDEFINED)
-#define C_readdir(h,e) C_set_block_item(e, 0, (C_word) readdir((DIR *)C_block_item(h, 0)))
-#define C_foundfile(e,b,l) (C_strlcpy(C_c_string(b), ((struct dirent *) C_block_item(e, 0))->d_name, l), C_fix(strlen(((struct dirent *) C_block_item(e, 0))->d_name)))
-
/* It is assumed that 'int' is-a 'long' */
#define C_ftell(a, n, p) C_int64_to_num(a, ftell(C_port_file(p)))
#define C_fseek(p, n, w) C_mk_nbool(fseek(C_port_file(p), C_num_to_int64(n), C_unfix(w)))
@@ -467,34 +462,6 @@ EOF
(lambda (dir)
((if (fixnum? dir) change-directory* cd) dir))))
-(define directory
- (lambda (#!optional (spec (current-directory)) show-dotfiles?)
- (##sys#check-string spec 'directory)
- (let ([buffer (make-string 256)]
- [handle (##sys#make-pointer)]
- [entry (##sys#make-pointer)] )
- (##core#inline
- "C_opendir"
- (##sys#make-c-string spec 'directory) handle)
- (if (##sys#null-pointer? handle)
- (posix-error #:file-error 'directory "cannot open directory" spec)
- (let loop ()
- (##core#inline "C_readdir" handle entry)
- (if (##sys#null-pointer? entry)
- (begin
- (##core#inline "C_closedir" handle)
- '() )
- (let* ([flen (##core#inline "C_foundfile" entry buffer (string-length buffer))]
- [file (##sys#substring buffer 0 flen)]
- [char1 (string-ref file 0)]
- [char2 (and (fx> flen 1) (string-ref file 1))] )
- (if (and (eq? #\. char1)
- (or (not char2)
- (and (eq? #\. char2) (eq? 2 flen))
- (not show-dotfiles?) ) )
- (loop)
- (cons file (loop)) ) ) ) ) ) ) ) )
-
;;; umask
(define file-creation-mode
diff --git a/posix.scm b/posix.scm
index f8f7f1da..bc1ff275 100644
--- a/posix.scm
+++ b/posix.scm
@@ -46,7 +46,7 @@
create-session create-symbolic-link
current-effective-group-id current-effective-user-id
current-effective-user-name current-group-id current-process-id
- current-user-id current-user-name directory
+ current-user-id current-user-name
directory? duplicate-fileno fcntl/dupfd fcntl/getfd
fcntl/getfl fcntl/setfd fcntl/setfl fifo? fifo? file-access-time
file-change-time file-close file-control file-creation-mode
diff --git a/posixwin.scm b/posixwin.scm
index a9e53525..31bcb9f3 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -104,83 +104,6 @@ static C_TLS char C_shlcmd[256] = "";
/* Current user name */
static C_TLS TCHAR C_username[255 + 1] = "";
-/* DIRENT stuff */
-struct dirent
-{
- char * d_name;
-};
-
-typedef struct
-{
- struct _finddata_t fdata;
- int handle;
- struct dirent current;
-} DIR;
-
-static DIR * C_fcall
-opendir(const char *name)
-{
- int name_len = strlen(name);
- int what_len = name_len + 3;
- DIR *dir = (DIR *)malloc(sizeof(DIR));
- char *what;
- if (!dir)
- {
- errno = ENOMEM;
- return NULL;
- }
- what = (char *)malloc(what_len);
- if (!what)
- {
- free(dir);
- errno = ENOMEM;
- return NULL;
- }
- C_strlcpy(what, name, what_len);
- if (strchr("\\/", name[name_len - 1]))
- C_strlcat(what, "*", what_len);
- else
- C_strlcat(what, "\\*", what_len);
-
- dir->handle = _findfirst(what, &dir->fdata);
- if (dir->handle == -1)
- {
- free(what);
- free(dir);
- return NULL;
- }
- dir->current.d_name = NULL; /* as the first-time indicator */
- free(what);
- return dir;
-}
-
-static int C_fcall
-closedir(DIR * dir)
-{
- if (dir)
- {
- int res = _findclose(dir->handle);
- free(dir);
- return res;
- }
- return -1;
-}
-
-static struct dirent * C_fcall
-readdir(DIR * dir)
-{
- if (dir)
- {
- if (!dir->current.d_name /* first time after opendir */
- || _findnext(dir->handle, &dir->fdata) != -1)
- {
- dir->current.d_name = dir->fdata.name;
- return &dir->current;
- }
- }
- return NULL;
-}
-
#define open_binary_input_pipe(a, n, name) C_mpointer(a, _popen(C_c_string(name), "r"))
#define open_text_input_pipe(a, n, name) open_binary_input_pipe(a, n, name)
#define open_binary_output_pipe(a, n, name) C_mpointer(a, _popen(C_c_string(name), "w"))
diff --git a/types.db b/types.db
index 9ee24365..e43b0322 100644
--- a/types.db
+++ b/types.db
@@ -1559,6 +1559,7 @@
;; file
+(chicken.file#directory (#(procedure #:clean #:enforce) chicken.file#directory (#!optional string *) (list-of string)))
(chicken.file#create-directory (#(procedure #:clean #:enforce) chicken.file#create-directory (string #!optional *) string))
(chicken.file#create-temporary-directory (#(procedure #:clean #:enforce) chicken.file#create-temporary-directory () string))
(chicken.file#create-temporary-file (#(procedure #:clean #:enforce) chicken.file#create-temporary-file (#!optional string) string))
@@ -1937,7 +1938,6 @@
(chicken.posix#current-process-id (#(procedure #:clean) chicken.posix#current-process-id () fixnum))
(chicken.posix#current-user-id (#(procedure #:clean) chicken.posix#current-user-id () fixnum))
(chicken.posix#current-user-name (#(procedure #:clean) chicken.posix#current-user-name () string))
-(chicken.posix#directory (#(procedure #:clean #:enforce) chicken.posix#directory (#!optional string *) (list-of string)))
(chicken.posix#directory? (#(procedure #:clean #:enforce) chicken.posix#directory? ((or string fixnum)) boolean))
(chicken.posix#duplicate-fileno (#(procedure #:clean #:enforce) chicken.posix#duplicate-fileno (fixnum #!optional fixnum) fixnum))
(chicken.posix#fcntl/dupfd fixnum)
Trap