~ chicken-core (chicken-5) cb3552baadceeafdae06b381365e9815f14f8f1a
commit cb3552baadceeafdae06b381365e9815f14f8f1a
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sat May 13 20:53:45 2017 +0200
Commit: Kooda <kooda@upyum.com>
CommitDate: Mon Jun 5 23:08:30 2017 +0200
Rename change-file-mode to set-file-permissions! for consistency
This includes a SRFI-17 setter on file-permissions as well. The new
setter is moved from (chicken file) to (chicken file posix), because
the getter lives in that module too.
file-permissions is changed to return just the permissions, so that
the values used by setter and getter are symmetric.
Before, the getter would also return the file type from stat(), as in
it returned the raw value of st_mode. This makes no sense for the
name "file-permissions", I'd expect only the permissions.
Note that this doesn't remove any functionality: we can still get the
file type or any of the special bits using other getters, and if we
want we can still use "file-stat" to get the raw underlying values.
Finally, the setter is modified to match the getter in accepting both
a string and a fd or port, using fchmod. On Windows, fchmod is
implemented using GetFinalPathNameByHandle() followed by chmod(). To
make this work, the Windows API version has been bumped to Vista.
It's probably better to officially require Windows 7 or newer, though.
Signed-off-by: Kooda <kooda@upyum.com>
diff --git a/chicken.h b/chicken.h
index efd89789..d2e9db6d 100644
--- a/chicken.h
+++ b/chicken.h
@@ -110,10 +110,10 @@
# define C_LLP
#endif
-/* Declare base Win32 version for access to Timer Queue functions. */
+/* Declare base Win32 version: we require Vista or later */
#ifdef __MINGW32__
-# define _WIN32_WINNT 0x0500
+# define _WIN32_WINNT 0x0600
#endif
diff --git a/file.scm b/file.scm
index 68d9fc4b..b85f1cce 100644
--- a/file.scm
+++ b/file.scm
@@ -52,7 +52,6 @@ EOF
(module chicken.file
(block-device?
- change-file-mode
change-file-owner
character-device?
create-directory
diff --git a/posix-common.scm b/posix-common.scm
index b4ee2c1a..b22947f8 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -40,6 +40,7 @@ int C_not_implemented() { return -1; }
static C_TLS struct stat C_statbuf;
#define C_stat_type (C_statbuf.st_mode & S_IFMT)
+#define C_stat_perm (C_statbuf.st_mode & ~S_IFMT)
#define C_stat(fn) C_fix(stat((char *)C_data_pointer(fn), &C_statbuf))
#define C_fstat(f) C_fix(fstat(C_unfix(f), &C_statbuf))
@@ -253,7 +254,7 @@ EOF
(##core#inline "C_stat" path) ) ) )
(else
(##sys#signal-hook
- #:type-error loc "bad argument type - not a fixnum or string" file)) ) ) )
+ #:type-error loc "bad argument type - not a fixnum, port or string" file)) ) ) )
(if (fx< r 0)
(if err
(posix-error #:file-error loc "cannot access file" file)
@@ -268,6 +269,20 @@ EOF
_stat_st_dev _stat_st_rdev
_stat_st_blksize _stat_st_blocks) )
+(define (set-file-permissions! f p)
+ (##sys#check-fixnum p 'set-file-permissions!)
+ (let ((r (cond ((fixnum? f) (##core#inline "C_fchmod" f p))
+ ((port? f) (##core#inline "C_fchmod" (port->fileno f) p))
+ ((string? f)
+ (##core#inline "C_chmod"
+ (##sys#make-c-string f 'set-file-permissions!) p))
+ (else
+ (##sys#signal-hook
+ #:type-error 'file-permissions
+ "bad argument type - not a fixnum, port or string" f)) ) ) )
+ (when (fx< r 0)
+ (posix-error #:file-error 'set-file-permissions! "cannot change file permissions" f p) ) ))
+
(define (file-modification-time f) (##sys#stat f #f #t 'file-modification-time) _stat_st_mtime)
(define (file-access-time f) (##sys#stat f #f #t 'file-access-time) _stat_st_atime)
(define (file-change-time f) (##sys#stat f #f #t 'file-change-time) _stat_st_ctime)
@@ -285,9 +300,15 @@ EOF
'set-file-times! "cannot set file times" f rest)))))
(define (file-owner f) (##sys#stat f #f #t 'file-owner) _stat_st_uid)
-(define (file-permissions f) (##sys#stat f #f #t 'file-permissions) _stat_st_mode)
(define (file-size f) (##sys#stat f #f #t 'file-size) _stat_st_size)
+(define file-permissions
+ (getter-with-setter
+ (lambda (f)
+ (##sys#stat f #f #t 'file-permissions)
+ (foreign-value "C_stat_perm" unsigned-int))
+ set-file-permissions! ))
+
(define (file-type file #!optional link (err #t))
(and (##sys#stat file link err 'file-type)
(select (foreign-value "C_stat_type" unsigned-int)
@@ -321,14 +342,6 @@ EOF
(define (directory? file)
(eq? 'directory (file-type file #f #f)))
-
-(define change-file-mode
- (lambda (fname m)
- (##sys#check-string fname 'change-file-mode)
- (##sys#check-fixnum m 'change-file-mode)
- (when (fx< (##core#inline "C_chmod" (##sys#make-c-string fname 'change-file-mode) m) 0)
- (posix-error #:file-error 'change-file-mode "cannot change file mode" fname m) ) ) )
-
(define file-read-access?)
(define file-write-access?)
(define file-execute-access?)
diff --git a/posix.scm b/posix.scm
index 0bb3818e..026a8595 100644
--- a/posix.scm
+++ b/posix.scm
@@ -101,8 +101,8 @@
open/trunc open/write open/wronly perm/irgrp perm/iroth perm/irusr
perm/irwxg perm/irwxo perm/irwxu perm/isgid perm/isuid perm/isvtx
perm/iwgrp perm/iwoth perm/iwusr perm/ixgrp perm/ixoth perm/ixusr
- port->fileno seek/cur seek/end seek/set set-file-position!
- set-file-times!)
+ port->fileno seek/cur seek/end seek/set set-file-permissions!
+ set-file-position! set-file-times!)
(import chicken chicken.posix))
(module chicken.time.posix
diff --git a/posixunix.scm b/posixunix.scm
index 6e6a5569..5381cc02 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -32,7 +32,7 @@
(module chicken.posix
(emergency-exit call-with-input-pipe call-with-output-pipe change-directory
- change-directory* change-file-mode change-file-owner close-input-pipe
+ change-directory* change-file-owner close-input-pipe
close-output-pipe create-directory create-fifo create-pipe
create-session create-symbolic-link current-directory
current-effective-group-id current-effective-user-id
@@ -43,7 +43,8 @@
fifo? file-access-time file-change-time
file-creation-mode file-close file-control file-execute-access?
file-link file-lock file-lock/blocking file-mkstemp
- file-modification-time file-open file-owner file-permissions
+ file-modification-time file-open file-owner
+ file-permissions set-file-permissions!
file-position set-file-position! file-read file-read-access?
file-select file-size file-stat file-test-lock file-truncate
file-type file-unlock file-write file-write-access? fileno/stderr
@@ -187,6 +188,7 @@ static C_TLS struct stat C_statbuf;
#define C_getegid getegid
#define C_chown(fn, u, g) C_fix(chown(C_data_pointer(fn), C_unfix(u), C_unfix(g)))
#define C_chmod(fn, m) C_fix(chmod(C_data_pointer(fn), C_unfix(m)))
+#define C_fchmod(fd, m) C_fix(fchmod(C_unfix(fd), C_unfix(m)))
#define C_setuid(id) C_fix(setuid(C_unfix(id)))
#define C_setgid(id) C_fix(setgid(C_unfix(id)))
#define C_seteuid(id) C_fix(seteuid(C_unfix(id)))
diff --git a/posixwin.scm b/posixwin.scm
index df26705d..4f37581a 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -73,7 +73,9 @@
#include <io.h>
#include <process.h>
#include <signal.h>
+#include <stdio.h>
#include <utime.h>
+#include <windows.h>
#include <winsock2.h>
#define PIPE_BUF 512
@@ -306,6 +308,28 @@ set_last_errno()
return 0;
}
+static C_word C_fchmod(C_word fd, C_word m)
+{
+ TCHAR path[MAX_PATH];
+ DWORD result;
+ HANDLE fh = (HANDLE)_get_osfhandle(C_unfix(fd));
+
+ if (fh == INVALID_HANDLE_VALUE) {
+ set_last_errno();
+ return C_fix(-1);
+ }
+
+ result = GetFinalPathNameByHandle(fh, path, MAX_PATH, VOLUME_NAME_DOS);
+ if (result == 0) {
+ set_last_errno();
+ return C_fix(-1);
+ } else if (result >= MAX_PATH) { /* Shouldn't happen */
+ errno = ENOMEM; /* For lack of anything better */
+ return C_fix(-1);
+ }
+ return C_fix(chmod(path, C_unfix(m)));
+}
+
static int C_fcall
process_wait(C_word h, C_word t)
{
@@ -641,7 +665,7 @@ EOF
(module chicken.posix
(emergency-exit call-with-input-pipe call-with-output-pipe change-directory
- change-directory* change-file-mode change-file-owner close-input-pipe
+ change-directory* change-file-owner close-input-pipe
close-output-pipe create-directory create-fifo create-pipe
create-session create-symbolic-link current-directory
current-effective-group-id current-effective-user-id
@@ -652,7 +676,8 @@ EOF
fifo? file-access-time file-change-time
file-creation-mode file-close file-control file-execute-access?
file-link file-lock file-lock/blocking file-mkstemp
- file-modification-time file-open file-owner file-permissions
+ file-modification-time file-open file-owner
+ file-permissions set-file-permissions!
file-position set-file-position! file-read file-read-access?
file-select file-size file-stat file-test-lock file-truncate
file-type file-unlock file-write file-write-access? fileno/stderr
diff --git a/types.db b/types.db
index d46c1e9f..ee326de4 100644
--- a/types.db
+++ b/types.db
@@ -1925,7 +1925,6 @@
(chicken.posix#call-with-output-pipe (#(procedure #:enforce) chicken.posix#call-with-output-pipe (string (procedure (input-port) . *) #!optional symbol) . *))
(chicken.posix#change-directory (#(procedure #:clean #:enforce) chicken.posix#change-directory (string) string))
(chicken.posix#change-directory* (#(procedure #:clean #:enforce) chicken.posix#change-directory* (fixnum) fixnum))
-(chicken.posix#change-file-mode (#(procedure #:clean #:enforce) chicken.posix#change-file-mode (string fixnum) undefined))
(chicken.posix#change-file-owner (#(procedure #:clean #:enforce) chicken.posix#change-file-owner (string fixnum fixnum) undefined))
(chicken.posix#close-input-pipe (#(procedure #:clean #:enforce) chicken.posix#close-input-pipe (input-port) fixnum))
(chicken.posix#close-output-pipe (#(procedure #:clean #:enforce) chicken.posix#close-output-pipe (output-port) fixnum))
@@ -2048,6 +2047,7 @@
(chicken.posix#seek/set fixnum)
(chicken.posix#set-alarm! (#(procedure #:clean #:enforce) chicken.posix#set-alarm! (integer) integer))
(chicken.posix#set-buffering-mode! (#(procedure #:clean #:enforce) chicken.posix#set-buffering-mode! (port symbol #!optional fixnum) undefined))
+(chicken.posix#set-file-permissions! (#(procedure #:clean #:enforce) chicken.posix#set-file-permissions! ((or string fixnum port) fixnum) undefined))
(chicken.posix#set-file-position! (#(procedure #:clean #:enforce) chicken.posix#set-file-position! ((or port fixnum) integer #!optional fixnum) undefined))
(chicken.posix#set-file-times! (#(procedure #:clean #:enforce) chicken.posix#set-file-times! (string #!optional (or false integer) (or false integer)) undefined))
(chicken.posix#set-root-directory! (#(procedure #:clean #:enforce) chicken.posix#set-root-directory! (string) undefined))
Trap