From 134ff4ce1d4af3ad416874cfada02df485496049 Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Wed, 10 May 2017 22:06:13 +0200
Subject: [PATCH] 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.
---
 posix-common.scm | 28 ++++++++++++++--------------
 posix.scm        |  3 ++-
 posixunix.scm    | 21 ++++++++++++++++++---
 posixwin.scm     | 21 ++++++++++++++++++---
 types.db         |  1 +
 5 files changed, 53 insertions(+), 21 deletions(-)

diff --git a/posix-common.scm b/posix-common.scm
index e3e6739..3475dda 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 96c932a..2bc058e 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 40b5b75..3c5df86 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
@@ -352,11 +352,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 02fc62f..7b549e4 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -612,11 +612,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
@@ -656,7 +671,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 13b911b..180cae2 100644
--- a/types.db
+++ b/types.db
@@ -2046,6 +2046,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))
-- 
2.1.4