>From 7f5a258010ce712b31133736ac1e4077e84def7c Mon Sep 17 00:00:00 2001 From: Evan Hanson Date: Mon, 19 Feb 2018 21:23:04 +1300 Subject: [PATCH 1/2] Move `directory' to chicken.file --- file.scm | 120 +++++++++++++++++++++++++++++++++++++++++++++++++++++-- posix-common.scm | 33 --------------- posix.scm | 2 +- posixwin.scm | 77 ----------------------------------- types.db | 2 +- 5 files changed, 119 insertions(+), 115 deletions(-) diff --git a/file.scm b/file.scm index 4792bbdc..a720acd6 100644 --- a/file.scm +++ b/file.scm @@ -41,14 +41,101 @@ (foreign-declare #< +#define C_rmdir(str) C_fix(rmdir(C_c_string(str))) + #ifndef _WIN32 # include # 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 +# include +#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 )) @@ -135,7 +222,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))) @@ -177,6 +290,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 d29a51f0..d973f9ec 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 b87864e4..050feff1 100644 --- a/types.db +++ b/types.db @@ -1564,6 +1564,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)) @@ -1940,7 +1941,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) -- 2.11.0