Here are two more patches that move `file-{read,write,execute}-access?'
and `directory' into chicken.file, where they're actually exported.

Cheers,

Evan
>From 7f5a258010ce712b31133736ac1e4077e84def7c Mon Sep 17 00:00:00 2001
From: Evan Hanson <ev...@foldling.org>
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 #<<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
 ))
 
@@ -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

>From b362ac2ced9d297583be55a3de7d1f3002c3a676 Mon Sep 17 00:00:00 2001
From: Evan Hanson <ev...@foldling.org>
Date: Tue, 20 Feb 2018 17:46:50 +1300
Subject: [PATCH 2/2] Move `file-{read,write,execute}-access?' to chicken.file

---
 file.scm         | 32 ++++++++++++++++++++++++++++++++
 posix-common.scm | 32 --------------------------------
 posix.scm        |  6 +++---
 posixunix.scm    |  1 -
 posixwin.scm     |  1 -
 types.db         |  7 +++----
 6 files changed, 38 insertions(+), 41 deletions(-)

diff --git a/file.scm b/file.scm
index a720acd6..63969fbd 100644
--- a/file.scm
+++ b/file.scm
@@ -41,6 +41,19 @@
   (foreign-declare #<<EOF
 #include <errno.h>
 
+#define C_test_access(fn, m) C_fix(access((char *)C_data_pointer(fn), C_unfix(m)))
+
+/* For Windows */
+#ifndef R_OK
+# define R_OK 2
+#endif
+#ifndef W_OK
+# define W_OK 4
+#endif
+#ifndef X_OK
+# define X_OK 2
+#endif
+
 #define C_rmdir(str)        C_fix(rmdir(C_c_string(str)))
 
 #ifndef _WIN32
@@ -223,6 +236,25 @@ EOF
   new)
 
 
+;;; Permissions:
+
+(define-foreign-variable _r_ok int "R_OK")
+(define-foreign-variable _w_ok int "W_OK")
+(define-foreign-variable _x_ok int "X_OK")
+
+(define (test-access filename acc loc)
+  (##sys#check-string filename loc)
+  (let ((r (##core#inline "C_test_access" (##sys#make-c-string filename loc) acc)))
+    (or (fx= r 0)
+	(if (fx= (##sys#update-errno) (foreign-value "EACCES" int))
+	    #f
+	    (posix-error #:file-error loc "cannot access file" filename)))))
+
+(define (file-read-access? filename) (test-access filename _r_ok 'file-read-access?))
+(define (file-write-access? filename) (test-access filename _w_ok 'file-write-access?))
+(define (file-execute-access? filename) (test-access filename _x_ok 'file-execute-access?))
+
+
 ;;; Directories:
 
 (define (directory #!optional (spec (current-directory)) show-dotfiles?)
diff --git a/posix-common.scm b/posix-common.scm
index 98ffe85c..d3f1c751 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -44,17 +44,6 @@ static C_TLS struct stat C_statbuf;
 # define S_IFSOCK           0140000
 #endif
 
-/* For Windows */
-#ifndef R_OK
-#define R_OK			2
-#endif
-#ifndef W_OK
-#define W_OK			4
-#endif
-#ifndef X_OK
-#define X_OK			2
-#endif
-
 #define cpy_tmvec_to_tmstc08(ptm, v) \
     ((ptm)->tm_sec = C_unfix(C_block_item((v), 0)), \
     (ptm)->tm_min = C_unfix(C_block_item((v), 1)), \
@@ -317,27 +306,6 @@ EOF
 (define (directory? file)
   (eq? 'directory (file-type file #f #f)))
 
-(define file-read-access?)
-(define file-write-access?)
-(define file-execute-access?)
-
-(define-foreign-variable _r_ok int "R_OK")
-(define-foreign-variable _w_ok int "W_OK")
-(define-foreign-variable _x_ok int "X_OK")
-
-(let ()
-  (define (check filename acc loc)
-    (##sys#check-string filename loc)
-    (let ((r (##core#inline "C_test_access" (##sys#make-c-string filename loc) acc)))
-      (if (fx= r -1)
-	  (if (fx= (##sys#update-errno) _eacces)
-	      #f
-	      (posix-error #:file-error loc "cannot access file" filename))
-	  #t)))
-  (set! file-read-access? (lambda (filename) (check filename _r_ok 'file-read-access?)))
-  (set! file-write-access? (lambda (filename) (check filename _w_ok 'file-write-access?)))
-  (set! file-execute-access? (lambda (filename) (check filename _x_ok 'file-execute-access?))) )
-
 
 ;;; File position access:
 
diff --git a/posix.scm b/posix.scm
index d973f9ec..eb27a30a 100644
--- a/posix.scm
+++ b/posix.scm
@@ -50,11 +50,11 @@
    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
-   file-execute-access? file-group file-link file-lock
+   file-group file-link file-lock
    file-lock/blocking file-mkstemp file-modification-time file-open
-   file-owner file-permissions file-position file-read file-read-access?
+   file-owner file-permissions file-position file-read
    file-select file-size file-stat file-test-lock file-truncate
-   file-type file-unlock file-write file-write-access? fileno/stderr
+   file-type file-unlock file-write fileno/stderr
    fileno/stdin fileno/stdout
    local-time->seconds local-timezone-abbreviation
    open-input-file* open-input-pipe open-output-file* open-output-pipe
diff --git a/posixunix.scm b/posixunix.scm
index 124c6b6e..7607854d 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -134,7 +134,6 @@ static C_TLS struct stat C_statbuf;
 #define C_truncate(f, n)    C_fix(truncate((char *)C_data_pointer(f), C_num_to_int(n)))
 #define C_ftruncate(f, n)   C_fix(ftruncate(C_unfix(f), C_num_to_int(n)))
 #define C_alarm             alarm
-#define C_test_access(fn, m)     C_fix(access((char *)C_data_pointer(fn), C_unfix(m)))
 #define C_close(fd)         C_fix(close(C_unfix(fd)))
 #define C_umask(m)          C_fix(umask(C_unfix(m)))
 
diff --git a/posixwin.scm b/posixwin.scm
index 31bcb9f3..d0dad8b8 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -111,7 +111,6 @@ static C_TLS TCHAR C_username[255 + 1] = "";
 #define close_pipe(p)			     C_fix(_pclose(C_port_file(p)))
 
 #define C_chmod(fn, m)	    C_fix(chmod(C_data_pointer(fn), C_unfix(m)))
-#define C_test_access(fn, m)	    C_fix(access((char *)C_data_pointer(fn), C_unfix(m)))
 #define C_pipe(d, m)	    C_fix(_pipe(C_pipefds, PIPE_BUF, C_unfix(m)))
 #define C_close(fd)	    C_fix(close(C_unfix(fd)))
 
diff --git a/types.db b/types.db
index 050feff1..0e410a67 100644
--- a/types.db
+++ b/types.db
@@ -1576,7 +1576,9 @@
 (chicken.file#find-files (#(procedure #:enforce) chicken.file#find-files (string #!rest) list))
 (chicken.file#glob (#(procedure #:clean #:enforce) chicken.file#glob (#!rest string) list))
 (chicken.file#rename-file (#(procedure #:clean #:enforce) chicken.file#rename-file (string string) string))
-
+(chicken.file#file-read-access? (#(procedure #:clean #:enforce) chicken.file#file-read-access? (string) boolean))
+(chicken.file#file-write-access? (#(procedure #:clean #:enforce) chicken.file#file-write-access? (string) boolean))
+(chicken.file#file-execute-access? (#(procedure #:clean #:enforce) chicken.file#file-execute-access? (string) boolean))
 
 ;; pathname
 
@@ -1953,7 +1955,6 @@
 (chicken.posix#file-close (#(procedure #:clean #:enforce) chicken.posix#file-close (fixnum) undefined))
 (chicken.posix#file-control (#(procedure #:clean #:enforce) chicken.posix#file-control (fixnum fixnum #!optional fixnum) fixnum))
 (chicken.posix#file-creation-mode (#(procedure #:clean #:enforce) chicken.posix#file-creation-mode (#!optional fixnum) fixnum))
-(chicken.posix#file-execute-access? (#(procedure #:clean #:enforce) chicken.posix#file-execute-access? (string) boolean))
 (chicken.posix#file-link (#(procedure #:clean #:enforce) chicken.posix#file-link (string string) undefined))
 (chicken.posix#file-lock (#(procedure #:clean #:enforce) chicken.posix#file-lock (port #!optional fixnum integer) (struct lock)))
 (chicken.posix#file-lock/blocking (#(procedure #:clean #:enforce) chicken.posix#file-lock/blocking (port #!optional fixnum integer) (struct lock)))
@@ -1965,7 +1966,6 @@
 (chicken.posix#file-permissions (#(procedure #:clean #:enforce) chicken.posix#file-permissions ((or string fixnum)) fixnum))
 (chicken.posix#file-position (#(procedure #:clean #:enforce) chicken.posix#file-position ((or port fixnum)) integer))
 (chicken.posix#file-read (#(procedure #:clean #:enforce) chicken.posix#file-read (fixnum fixnum #!optional *) list))
-(chicken.posix#file-read-access? (#(procedure #:clean #:enforce) chicken.posix#file-read-access? (string) boolean))
 (chicken.posix#file-select (#(procedure #:clean #:enforce) chicken.posix#file-select ((or (list-of fixnum) fixnum false) (or (list-of fixnum) fixnum false) #!optional fixnum) * *))
 (chicken.posix#file-size (#(procedure #:clean #:enforce) chicken.posix#file-size ((or string fixnum)) integer))
 (chicken.posix#file-stat (#(procedure #:clean #:enforce) chicken.posix#file-stat ((or string fixnum) #!optional *) (vector-of integer)))
@@ -1974,7 +1974,6 @@
 (chicken.posix#file-type (#(procedure #:clean #:enforce) chicken.posix#file-type ((or string fixnum) #!optional * *) symbol))
 (chicken.posix#file-unlock (#(procedure #:clean #:enforce) chicken.posix#file-unlock ((struct lock)) undefined))
 (chicken.posix#file-write (#(procedure #:clean #:enforce) chicken.posix#file-write (fixnum * #!optional fixnum) fixnum))
-(chicken.posix#file-write-access? (#(procedure #:clean #:enforce) chicken.posix#file-write-access? (string) boolean))
 (chicken.posix#fileno/stderr fixnum)
 (chicken.posix#fileno/stdin fixnum)
 (chicken.posix#fileno/stdout fixnum)
-- 
2.11.0

_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers

Reply via email to