~ chicken-core (chicken-5) 6810aaac5be163fb3092f51ffc72a0debbd28459

commit 6810aaac5be163fb3092f51ffc72a0debbd28459
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Wed May 10 22:06:13 2017 +0200
Commit:     Kooda <kooda@upyum.com>
CommitDate: Mon Jun 5 23:08:30 2017 +0200

    Replace file-modification-time setter with set-file-times! procedure
    
    This reduces several inconsistencies and any resulting confusion:
    
    - file-access-time and file-change-time have no associated setter
    - The setter for file-modification-time sets both mtime AND ctime
    - The getters all accept strings, ports and file descriptors; the
       setter only accepts a string.
    
    While at it, the new procedure also makes it possible to omit the
    timestamps (in which case the current time is assumed), supply only
    one (in which case the old behaviour stays: we set both timestamps to
    the supplied time) or both (in which case you can set either to a
    different value).  If #f is supplied, the specific time is unchanged.
    
    This behaviour is maximally compatible with the "specify both or none"
    behaviour from SCSH's "set-file-times" procedure (note the missing
    bang though), and with MIT Scheme's "set-file-times!" procedure where
    passing in #f means to avoid modifying the corresponding time.
    
    Signed-off-by: Kooda <kooda@upyum.com>

diff --git a/posix-common.scm b/posix-common.scm
index e3e67393..3475dda3 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -257,22 +257,22 @@ EOF
           _stat_st_dev _stat_st_rdev
           _stat_st_blksize _stat_st_blocks) )
 
-(define file-modification-time
-  (getter-with-setter 
-   (lambda (f)
-     (##sys#stat f #f #t 'file-modification-time) _stat_st_mtime)
-   (lambda (f t)
-     (##sys#check-exact-integer t 'set-file-modification-time)
-     (let ((r ((foreign-lambda int "set_file_mtime" c-string scheme-object)
-	       f t)))
-       (when (fx< r 0)
-	 (posix-error 
-	  #:file-error 'set-file-modification-time
-	  "cannot set file modification-time" f t))))
-   "(file-modification-time f)"))
-
+(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)
+
+(define (set-file-times! f . rest)
+  (let-optionals* rest ((atime (current-seconds)) (mtime atime))
+    (when atime (##sys#check-exact-integer atime 'set-file-times!))
+    (when mtime (##sys#check-exact-integer mtime 'set-file-times!))
+    (let ((r ((foreign-lambda int "set_file_mtime"
+		c-string scheme-object scheme-object)
+	      f atime mtime)))
+      (when (fx< r 0)
+	(apply posix-error
+	       #:file-error
+	       '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)
diff --git a/posix.scm b/posix.scm
index 63729d3f..0bb3818e 100644
--- a/posix.scm
+++ b/posix.scm
@@ -101,7 +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!)
+   port->fileno seek/cur seek/end seek/set set-file-position!
+   set-file-times!)
 (import chicken chicken.posix))
 
 (module chicken.time.posix
diff --git a/posixunix.scm b/posixunix.scm
index 60f547b2..d4541a44 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -60,7 +60,7 @@
    process-group-id process-run process-signal process-sleep process-wait
    read-symbolic-link regular-file? seconds->local-time seconds->string
    seconds->utc-time seek/cur seek/end seek/set set-alarm!
-   set-buffering-mode! set-root-directory!
+   set-buffering-mode! set-file-times! set-root-directory!
    set-signal-handler! set-signal-mask! signal-handler
    signal-mask signal-mask! signal-masked? signal-unmask! signal/abrt
    signal/alrm signal/break signal/chld signal/cont signal/fpe
@@ -353,11 +353,26 @@ static int get_tty_size(int p, int *rows, int *cols)
 }
 #endif
 
-static int set_file_mtime(char *filename, C_word tm)
+static int set_file_mtime(char *filename, C_word atime, C_word mtime)
 {
+  struct stat sb;
   struct utimbuf tb;
 
-  tb.actime = tb.modtime = C_num_to_int(tm);
+  /* Only lstat if needed */
+  if (atime == C_SCHEME_FALSE || mtime == C_SCHEME_FALSE) {
+    if (lstat(filename, &sb) == -1) return -1;
+  }
+
+  if (atime == C_SCHEME_FALSE) {
+    tb.actime = sb.st_atime;
+  } else {
+    tb.actime = C_num_to_int(atime);
+  }
+  if (mtime == C_SCHEME_FALSE) {
+    tb.modtime = sb.st_mtime;
+  } else {
+    tb.modtime = C_num_to_int(mtime);
+  }
   return utime(filename, &tb);
 }
 
diff --git a/posixwin.scm b/posixwin.scm
index 23e2f369..9685b635 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -611,11 +611,26 @@ C_process(const char *app, const char *cmdlin, const char **env,
     return success;
 }
 
-static int set_file_mtime(char *filename, C_word tm)
+static int set_file_mtime(char *filename, C_word atime, C_word mtime)
 {
+  struct stat sb;
   struct _utimbuf tb;
 
-  tb.actime = tb.modtime = C_num_to_int(tm);
+  /* Only lstat if needed */
+  if (atime == C_SCHEME_FALSE || mtime == C_SCHEME_FALSE) {
+    if (lstat(filename, &sb) == -1) return -1;
+  }
+
+  if (atime == C_SCHEME_FALSE) {
+    tb.actime = sb.st_atime;
+  } else {
+    tb.actime = C_num_to_int(atime);
+  }
+  if (mtime == C_SCHEME_FALSE) {
+    tb.modtime = sb.st_mtime;
+  } else {
+    tb.modtime = C_num_to_int(mtime);
+  }
   return _utime(filename, &tb);
 }
 EOF
@@ -655,7 +670,7 @@ EOF
    process-spawn process-wait read-symbolic-link regular-file?
    seconds->local-time seconds->string seconds->utc-time seek/cur
    seek/end seek/set set-alarm! set-buffering-mode! set-root-directory!
-   set-signal-handler! set-signal-mask! signal-handler
+   set-file-times! set-signal-handler! set-signal-mask! signal-handler
    signal-mask signal-mask! signal-masked? signal-unmask! signal/abrt
    signal/alrm signal/break signal/chld signal/cont signal/fpe
    signal/bus signal/hup signal/ill signal/int signal/io signal/kill
diff --git a/types.db b/types.db
index 004d531d..e7e2770d 100644
--- a/types.db
+++ b/types.db
@@ -2049,6 +2049,7 @@
 (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-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))
 (chicken.posix#set-signal-handler! (#(procedure #:clean #:enforce) chicken.posix#set-signal-handler! (fixnum (or false (procedure (fixnum) . *))) undefined))
 (chicken.posix#set-signal-mask! (#(procedure #:clean #:enforce) chicken.posix#set-signal-mask! ((list-of fixnum)) undefined))