Add more SRFI-170 procedures

Makefile

@@ -18,18 +18,14 @@ SFX=sps
 endif
 
 DOCKER_TAG=head
-ifeq "${SCHEME}" "chicken"
-DOCKER_TAG=5
-endif
 
 all: package
 
 package: srfi/${SRFI}/LICENSE srfi/${SRFI}/VERSION
-	echo "<pre>$$(cat srfi/${SRFI}/README.md)</pre>" > ${README}
 	snow-chibi package \
 		--version=${VERSION} \
 		--authors=${AUTHOR} \
-		--doc=${README} \
+		--doc-from-scribble=1 \
 		--description="${DESCRIPTION}" \
 		${SRFI_FILE}
 

srfi/170.scm

@@ -48,10 +48,44 @@
 (define-c-procedure c-slink libc 'link 'int '(pointer pointer))
 (define-c-procedure c-chown libc 'chown 'int '(pointer int int))
 (define-c-procedure c-clock-gettime libc 'clock_gettime 'int '(int pointer))
+(define-c-procedure c-nice libc 'nice 'int '(int))
 
 (define slash (cond-expand (windows "\\") (else "/")))
 (define randomized? #f)
 
+(define (string-split str mark)
+  (let* ((str-l (string->list str))
+         (res (list))
+         (last-index 0)
+         (index 0)
+         (splitter
+           (lambda (c)
+             (cond ((char=? c mark)
+                    (begin
+                      (set! res
+                        (append res
+                                (list (string-copy str last-index index))))
+                      (set! last-index (+ index 1))))
+                   ((equal? (length str-l) (+ index 1))
+                    (set! res
+                      (append res
+                              (list (string-copy str
+                                                 last-index
+                                                 (+ index 1)))))))
+             (set! index (+ index 1)))))
+    (for-each splitter str-l)
+    res))
+
+(define (string-char-replace replace-in replace-this replace-with)
+  (let ((result ""))
+    (string-for-each
+      (lambda (c)
+        (if (char=? c replace-this)
+          (set! result (string-append result replace-with))
+          (set! result (string-append result (string c)))))
+      replace-in)
+    result))
+
 (define (random-to max)
   (when (not randomized?)
     (c-srand (c-time (c-bytevector-null)))
@@ -77,7 +111,21 @@
     (looper "" (random-to 128))))
 
 (define-record-type file-info-record
-  (make-file-info-record device inode mode nlinks uid gid rdev size blksize blocks atime mtime ctime fname/port follow?)
+  (make-file-info-record device
+                         inode
+                         mode
+                         nlinks
+                         uid
+                         gid
+                         rdev
+                         size
+                         blksize
+                         blocks
+                         atime
+                         mtime
+                         ctime
+                         fname/port
+                         follow?)
   file-info?
   (device file-info:device)
   (inode file-info:inode)
@@ -96,10 +144,16 @@
   (follow? file-info:follow?))
 
 (define (file-info-directory? file-info)
-  (let ((handle (c-open (string->c-bytevector (file-info:fname/port file-info)) 2)))
+  (let ((handle (c-open (string->c-bytevector
+                          (file-info:fname/port file-info)) 2)))
     (cond ((> handle 0) (c-close handle) #f)
           (else #t))))
 
+;;> The file-info procedure returns a file-info record containing useful
+;;> information about a file. If the follow? flag is true the procedure will
+;;> follow symlinks and report on the file to which they refer. If follow? is
+;;> false the procedure checks the actual file itself, even if it's a symlink.
+;;> The follow? flag is ignored if the file argument is a port.
 (define (file-info fname/port follow?)
   (when (port? fname/port)
     (error "file-info implementation does not support ports as arguments"))
@@ -131,7 +185,8 @@
                            #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 12) (native-endianness))
                            fname/port
                            follow?)))
-
+;;> The permission-bits for create-directory default to #o775 but are masked
+;;> by the current umask.
 (define create-directory
   (lambda (fname . permission-bits)
     (let* ((fname-pointer (string->c-bytevector fname))
@@ -151,6 +206,8 @@
         (error error-message))
       (c-bytevector-free error-pointer))))
 
+;;> The permission-bits for create-directory default to #o664, but are masked
+;;> by the current umask.
 (define (create-fifo fname . permission-bits)
   (let* ((fname-pointer (string->c-bytevector fname))
          (mode (if (null? permission-bits)
@@ -198,12 +255,27 @@
               (c-bytevector-free buffer)
               name)))))
 
+;;> Return the filename referenced by the symlink fname.
 (define (read-symlink fname) (internal-read-symlink fname 128))
 
+;;> If you override an existing object, then old-fname and new-fname must
+;;> type-match — either both directories, or both non-directories.
+;;> This is required by the semantics of POSIX rename().
+;;>
+;;> Calling rename-file on a symbolic link will rename the symbolic link,
+;;> not the file it refers to.
+;;>
+;;> Remark: There is an unfortunate atomicity problem with the rename-file
+;;> procedure: if you create file new-fname sometime between rename-file's
+;;> existence check and the actual rename operation, your file will be
+;;> clobbered with old-fname. There is no way to prevent this problem; at
+;;> least it is highly unlikely to occur in practice.
 (define (rename-file old-fname new-fname)
   (c-rename (string->c-bytevector old-fname)
             (string->c-bytevector new-fname)))
 
+;;> This procedure deletes directories from the file system. An error is
+;;> signaled if fname is not a directory or is not empty.
 (define (delete-directory fname)
   (let* ((fname-pointer (string->c-bytevector fname))
          (result (c-rmdir fname-pointer)))
@@ -215,6 +287,12 @@
         (c-bytevector-free error-pointer)
         (error error-message)))))
 
+;;> This procedure sets the owner and group of a file specified by supplying
+;;> the filename. If the uid argument is the constant owner/unchanged, the
+;;> owner is not changed; if the gid argument is the constant group/unchanged,
+;;> the group is not changed. Setting file ownership usually requires root
+;;> privileges. This procedure follows symlinks and changes the files to which
+;;> they refer.
 (define (set-file-owner fname uid gid)
   (let ((fname-pointer (string->c-bytevector fname)))
     (c-chown fname-pointer uid gid)
@@ -234,6 +312,26 @@
 ; struct dirent d_name offset on linux
 (define d-name-offset 19)
 
+;;> Return a list of filenames in directory dir. The dotfiles? flag
+;;> (default #f) causes files beginning with . to be included in the list.
+;;> Regardless of the value of dotfiles?, the two files . and .. are never
+;;> returned.
+;;> The directory dir is not prepended to each filename in the result list.
+;;> That is,
+;;>
+;;>    (directory-files "/etc")
+;;>
+;;>returns
+;;>
+;;>    ("chown" "exports" "fstab" ...)
+;;>
+;;>not
+;;>
+;;>    ("/etc/chown" "/etc/exports" "/etc/fstab" ...)
+;;>
+;;> To use the filenames in the returned list, the programmer can either
+;;> manually prepend the directory, or change to the directory before using
+;;> the filenames.
 (define directory-files
   (lambda (dir . dotfiles?)
     (letrec* ((include-dotfiles? (if (null? dotfiles?) #f (car dotfiles?)))
@@ -269,15 +367,9 @@
         (c-closedir directory-pointer)
         files))))
 
-(define real-path
-  (lambda (path)
-    (let* ((path-pointer (string->c-bytevector path))
-           (real-path-pointer (c-realpath path-pointer (c-bytevector-null)))
-           (real-path (string-copy (c-bytevector->string real-path-pointer))))
-      (c-bytevector-free path-pointer)
-      (c-bytevector-free real-path-pointer)
-      real-path)))
-
+;;> This procedure sets the mode bits of a file specified by supplying the
+;;> filename. This procedure follows symlinks and changes the files to which
+;;> they refer.
 (define (set-file-mode path mode)
   (c-chmod (string->c-bytevector path)
            (string->number (string-append "#o" (number->string mode)))))
@@ -288,12 +380,24 @@
   (handle directory:handle)
   (dot-files? directory:dot-files?))
 
+;;> Opens the directory with the specified pathname for reading, returning an
+;;> opaque directory object.
+
+;;> The dot-files? argument controls whether filenames beginning with "." are
+;;> returned. If it is #f, which is the default, they are not. The filenames
+;;> . and .. are never returned.
 (define (open-directory path . dot-files?)
   (make-directory (c-opendir (string->c-bytevector path))
                   (if (null? dot-files?)
                     #f
                     (car dot-files?))))
 
+;;> Returns the name of the next available file, or the end-of-file object if
+;;> there are no more files.
+
+;;> The dot-files? argument controls whether filenames beginning with "." are
+;;> returned. If it is #f, which is the default, they are not. The filenames
+;;> . and .. are never returned.
 (define (read-directory directory-object)
   (let ((directory-entity (c-readdir (directory:handle directory-object))))
     (if (c-bytevector-null? directory-entity)
@@ -309,9 +413,26 @@
                (read-directory directory-object))
               (else name))))))
 
+;;> Closes a directory object.
 (define (close-directory directory-object)
   (c-closedir (directory:handle directory-object)))
 
+;;> Returns an absolute pathname derived from pathname that names the same
+;;> file and whose resolution does not involve dot (.), dot-dot (..), or
+;;> symlinks.
+(define real-path
+  (lambda (path)
+    (let* ((path-pointer (string->c-bytevector path))
+           (real-path-pointer (c-realpath path-pointer (c-bytevector-null)))
+           (real-path (string-copy (c-bytevector->string real-path-pointer))))
+      (c-bytevector-free path-pointer)
+      (c-bytevector-free real-path-pointer)
+      real-path)))
+
+;;> SRFI 39 or R7RS parameter that returns a string when invoked. Its initial
+;;> value is the value of the environment variable TMPDIR concatenated with
+;;> "/pid" if TMPDIR is set and to "/tmp/pid" otherwise, where pid is the id
+;;> of the current process.
 (define temp-file-prefix
   (make-parameter
     (if (get-environment-variable "TMPDIR")
@@ -323,14 +444,34 @@
         slash
         (number->string (c-getpid))))))
 
+;;> Creates a new temporary file and returns its name. The optional argument
+;;> specifies the filename prefix to use, and defaults to the result of
+;;> invoking temp-file-prefix. The procedure generates a sequence of filenames
+;;> that have prefix as a common prefix, looking for a filename that doesn't
+;;> already exist in the file system. When it finds one, it creates it with
+;;> permission #o600 and returns the filename. (The file permission can be
+;;> changed to a more permissive permission with set-file-mode after being
+;;> created.)
+
+;;> This file is guaranteed to be brand new. No other process will have it
+;;> open. This procedure does not simply return a filename that is very likely
+;;> to be unused. It returns a filename that definitely did not exist at the
+;;> moment create-temp-file created it.
+
+;;> It is not necessary for the process's pid to be a part of the filename
+;;> for the uniqueness guarantees to hold. The pid component of the default
+;;> prefix simply serves to scatter the name searches into sparse regions, so
+;;> that collisions are less likely to occur. This speeds things up, but does
+;;> not affect correctness.
 (define create-temp-file
   (lambda prefix
     (let* ((tmpdir (cond-expand
                      (windows (get-environment-variable "TMP"))
                      (else "/tmp")))
-           (real-prefix (if (null? prefix)
-                          (string-append tmpdir slash (number->string (c-getpid)))
-                          (car prefix)))
+           (real-prefix
+             (if (null? prefix)
+               (string-append tmpdir slash (number->string (c-getpid)))
+               (car prefix)))
            (path (string-append real-prefix "-" (random-string 6))))
       (if (file-exists? path)
         (create-temp-file real-prefix)
@@ -339,15 +480,66 @@
           (set-file-mode path 600)
           path)))))
 
+;;> This procedure can be used to perform certain atomic transactions on the
+;;> file system involving filenames. Some examples:
+;;>
+;;>     Linking a file to a fresh backup temp name.
+;;>     Creating and opening an unused, secure temp file.
+;;>     Creating an unused temporary directory. 
+;;>
+;;> This procedure uses prefix to generate a series of trial filenames. Prefix
+;;> is a string, and defaults to the value of invoking temp-file-prefix. File
+;;> names are generated by concatenating prefix with a varying string.
+;;>
+;;> The maker procedure is called serially on each filename generated. It must
+;;> return at least one value; it may return multiple values. If the first
+;;> return value is #f or if maker signals an exception indicating that the
+;;> file exists, call-with-temporary-filename will loop, generating a new
+;;> filename and calling maker again. If the first return value is true, the
+;;> loop is terminated, returning whatever value(s) maker returned.
+;;>
+;;> After a number of unsuccessful trials, call-with-temporary-filename may
+;;> give up, in which case an exception is signaled or propagated.
+;;>
+;;> To rename a file to a temporary name:
+;;>
+;;>     (call-with-temporary-filename
+;;>       (lambda (backup)
+;;>         (create-hard-link old-file backup)
+;;>         backup)
+;;>       ".temp.") ; Keep link in current working directory
+;;>     (delete-file old-file)
+;;>
+;;> Recall that this SRFI reports procedure failure by signaling an error.
+;;> This is critical for this example — the programmer can assume that if the
+;;> call-with-temporary-filename call returns, it returns successfully. So the
+;;> following delete-file call can be reliably invoked, safe in the knowledge
+;;> that the backup link has definitely been established.
+;;>
+;;> To create a unique temporary directory:
+;;>
+;;>     (call-with-temporary-filename
+;;>       (lambda (dir)
+;;>         (create-directory dir)
+;;>         dir)
+;;>       "/tmp/tempdir.")
+;;>
+;;> Similar operations can be used to generate unique fifos, or to return
+;;> values other than the new filename (for example, an open port).
 (define (call-with-temporary-filename maker . prefix)
   (let* ((tmpdir (cond-expand (windows (get-environment-variable "TMP"))
                               (else "/tmp")))
          (real-prefix (if (null? prefix)
-                        (string-append tmpdir slash (number->string (c-getpid)))
+                        (string-append tmpdir
+                                       slash
+                                       (number->string (c-getpid)))
                         (car prefix)))
          (path (string-append real-prefix "-" (random-string 6))))
     (apply maker (list path))))
 
+;;> Returns the current directory as a string containing an absolute pathname.
+;;> Whenever a file is referenced with a relative path, it is interpreted as
+;;> relative to this directory.
 (define (current-directory)
   (let* ((path-pointer (make-c-bytevector 1024))
          (path (begin
@@ -356,23 +548,34 @@
     (c-bytevector-free path-pointer)
     path))
 
+;;> Sets the current directory to new-directory and returns an unspecified
+;;> value.
 (define (set-current-directory! path)
   (c-chdir (string->c-bytevector path)))
 
-(define (pid)
-  (c-getpid))
+;;> Retrieves the process id for the current process.
+(define (pid) (c-getpid))
 
-(define (user-uid)
-  (c-getuid))
+;;> Increments the niceness of the current process by delta. The lower the
+;;> niceness value is, the more the process is favored during scheduling.
+;;> If delta is not specified, the increment is 1.
 
-(define (user-gid)
-  (c-getgid))
-
-(define (user-effective-uid)
-  (c-geteuid))
-
-(define (user-effective-gid)
-  (c-getegid))
+;;> Real-time processes are not affected by nice.
+(define nice
+  (lambda args
+    (let ((result (if (null? args) (c-nice 1) (c-nice (car args)))))
+      (when (< result 0)
+        (let* ((error-message "nice error")
+               (error-pointer (string->c-bytevector error-message)))
+          (c-perror error-pointer)
+          (c-bytevector-free timespec)
+          (c-bytevector-free error-pointer)
+          (error error-message)))
+      result)))
+(define (user-uid) (c-getuid))
+(define (user-gid) (c-getgid))
+(define (user-effective-uid) (c-geteuid))
+(define (user-effective-gid) (c-getegid))
 
 (define (groups-loop max-count count groups-pointer result)
   (if (>= count max-count)
@@ -395,13 +598,70 @@
 (define-record-type <user-info>
   (make-user-info name uid gid home-dir shell full-name)
   user-info?
-  (name user-info:name)
-  (uid user-info:uid)
-  (gid user-info:gid)
-  (home-dir user-info:home-dir)
-  (shell user-info:shell)
-  (full-name user-info:full-name))
+  (name internal-user-info:name)
+  (uid internal-user-info:uid)
+  (gid internal-user-info:gid)
+  (home-dir internal-user-info:home-dir)
+  (shell internal-user-info:shell)
+  (full-name internal-user-info:full-name))
 
+;;> Returns the user name stored in user-info respectively.
+;;> An implementation returns #f for any unavailable items.
+(define (user-info:name user-info) (internal-user-info:name user-info))
+;;> Returns the user uid stored in user-info respectively.
+;;> An implementation returns #f for any unavailable items.
+(define (user-info:uid user-info) (internal-user-info:uid user-info))
+;;> Returns the user gid stored in user-info respectively.
+;;> An implementation returns #f for any unavailable items.
+(define (user-info:gid user-info) (internal-user-info:gid user-info))
+;;> Returns the user home directory stored in user-info respectively.
+;;> An implementation returns #f for any unavailable items.
+(define (user-info:home-dir user-info) (internal-user-info:home-dir user-info))
+;;> Returns the shell path stored in user-info respectively.
+;;> An implementation returns #f for any unavailable items.
+(define (user-info:shell user-info) (internal-user-info:shell user-info))
+
+;;> Returns the contents of the pw_gecos field stored in user-info. Although
+;;> this field is not part of POSIX, it has been part of all Unix variants
+;;> since at least the Sixth Edition of Research Unix. It normally contains
+;;> the user's full name, but may contain additional system-specific
+;;> information; on Windows, it contains exactly the full name.
+(define (user-info:full-name user-info)
+  (internal-user-info:full-name user-info))
+
+;;> Returns a parsed and expanded version of the raw string returned by
+;;> user-info:full-name. The raw value is split on commas, creating a list of
+;;> strings to be returned. All ampersands in the first element of the list
+;;> are replaced by user-info:name, which is capitalized if it starts with an
+;;> ASCII lowercase letter.
+
+;;> However, on Windows the implementation is completely different:
+;;> user-info:parsed-full-name returns a list with a single element, the
+;;> result of user-info:full-name. No comma splitting or ampersand
+;;> substitution is performed.
+
+;;> The meaning of the first element of the returned list is the user's full
+;;> name on all known systems. The remaining elements have varying meaning.
+;;> For example, on BSD systems, the second through fourth elements are the
+;;> user's work location, the user's work phone number, and the user's home
+;;> phone number, respectively. On Cygwin, the second element is the Windows
+;;> SID corresponding to this user; further elements depend on Cygwin-specific
+;;> entries in the /etc/nsswitch.conf file.
+(define (user-info:parsed-full-name user-info)
+  (let* ((parsed-list
+           (string-split (internal-user-info:full-name user-info) #\,))
+         (first
+           (string-append
+             (string (char-upcase (string-ref (car parsed-list) 0)))
+             (string-copy (car parsed-list) 1))))
+    (cons (string-char-replace first #\& (user-info:name user-info))
+          (cdr parsed-list))))
+
+;;> Return a user-info record giving the recorded information for a particular
+;;> user. The uid/name argument is either an exact integer user id or a string
+;;> user name. If uid/name does not identify an existing user, #f is returned;
+;;> this does not constitute an error situation, and callers must be prepared
+;;> to handle it.
 (define (user-info uid/name)
   (let ((password-struct (if (number? uid/name)
                            (c-getpwuid uid/name)
@@ -446,10 +706,26 @@
                         'int
                         (* (c-type-size 'pointer) 2)))))
 
+;;> Change the value of the environment variable name to be value. Both name
+;;> and value are strings. If name is not defined at the time of call, a new
+;;> variable is added; if name is defined, its old value is discarded and
+;;> replaced by value. If name or value are invalid according to the operating
+;;> system, an exception is signaled. Mutating name or value after the call
+;;> must not change the name or value of the environment variable.
 (define (set-environment-variable! name value)
+  (when (not (string? name))
+    (error "set-environment-variable! error: name must be string"))
+  (when (not (string? value))
+    (error "set-environment-variable! error: value must be string"))
   (c-setenv (string->c-bytevector name) (string->c-bytevector value) 1))
 
+;;> Remove the environment variable name such that a subsequent
+;;> (get-environment-variable name) would return #f. If the variable cannot
+;;> be removed, an exception is signaled. If name does not currently have a
+;;> value, the call silently succeeds.
 (define (delete-environment-variable! name)
+  (when (not (string? name))
+    (error "delete-environment-variable! error: Name must be string"))
   (c-unsetenv (string->c-bytevector name)))
 
 (define CLOCK_REALTIME 0)
@@ -457,6 +733,11 @@
 (define tv_sec-type 'long)
 (define tv_nsec-type 'long)
 (define timespec (make-c-bytevector (c-type-size+ tv_sec-type tv_nsec-type)))
+
+;;> Returns the current time as a time object of type time-utc, which
+;;> represents the time since the POSIX epoch (midnight January 1, 1970
+;;> Universal Time), excluding leap seconds. It uses the POSIX CLOCK_REALTIME
+;;> clock.
 (define (posix-time)
   (let* ((result (c-clock-gettime CLOCK_REALTIME timespec)))
     (cond
@@ -473,3 +754,28 @@
                                      tv_nsec-type
                                      (c-type-size tv_sec-type))
                    (c-bytevector-ref timespec tv_sec-type 0))))))
+
+;;> Returns the current time as a time object of type time-monotonic, which
+;;> represents the time since an arbitrary epoch. This epoch is arbitrary,
+;;> but cannot change after the current program begins to run. It is
+;;> guaranteed that a call to monotonic-time cannot return a time earlier
+;;> than a previous call to monotonic-time. This is not guaranteed for
+;;> posix-time because the system's POSIX clock is sometimes turned backward
+;;> to correct local clock drift. It uses the POSIX CLOCK_MONOTONIC clock.
+(define (monotonic-time)
+  (let* ((result (c-clock-gettime CLOCK_MONOTONIC timespec)))
+    (cond
+      ((< result 0)
+       (let* ((error-message "posix-time error")
+              (error-pointer (string->c-bytevector error-message)))
+         (c-perror error-pointer)
+         (c-bytevector-free timespec)
+         (c-bytevector-free error-pointer)
+         (error error-message)))
+      (else
+        (make-time time-utc
+                   (c-bytevector-ref timespec
+                                     tv_nsec-type
+                                     (c-type-size tv_sec-type))
+                   (c-bytevector-ref timespec tv_sec-type 0))))))
+

srfi/170.sld

@@ -49,7 +49,7 @@
           open-directory
           read-directory
           close-directory
-          ;real-path
+          real-path
           ;file-space
           temp-file-prefix
           create-temp-file
@@ -59,7 +59,7 @@
           current-directory
           set-current-directory!
           pid
-          ;nice
+          nice
           user-uid
           user-gid
           user-effective-uid
@@ -73,13 +73,13 @@
           user-info:home-dir
           user-info:shell
           user-info:full-name
-          ;user-info:parsed-full-name
+          user-info:parsed-full-name
           group-info
           group-info?
           group-info:name
           group-info:gid
           posix-time
-          ;monotonic-time
+          monotonic-time
           set-environment-variable!
           delete-environment-variable!
           ;terminal?

srfi/170/VERSION

@@ -1 +1 @@
-0.1.4
+0.2.0

srfi/170/test.scm

@@ -1,5 +1,23 @@
 (test-begin "srfi-170")
 
+(write (posix-time))
+(newline)
+
+(write (monotonic-time))
+(newline)
+
+(define niceness (nice 1))
+(test-assert (number? niceness))
+(test-assert (> niceness 0))
+
+(define ui (user-info "retropikzel"))
+(write ui)
+(newline)
+
+(write (user-info:parsed-full-name ui))
+(newline)
+
+#|
 (define tmp-dir "/tmp/foreign-c-srfi-170")
 (for-each
   (lambda (file)
@@ -145,8 +163,7 @@
 (display "file-info-directory? on file: ")
 (write (file-info-directory? tmp-file-info))
 (newline)
+|#
 
-(write (posix-time))
-(newline)
 
 (test-end "srfi-170")