;; posix-extras: "Things that the posix unit forgot"

;; Taken from ugarit egg; modularized, improved portability, added stuff.
;; Additions: added stat operations; removed change-file-times
;;            added create-{block,character}-device
;;            added device-{major,minor,number}
;;            create-special-file accepts optional minor number

;; This would benefit from the feature-test egg.

;; FIXME: May need to disable interrupts to avoid clobbering errno.

;; Copyright (c) 2012, Ursetto Consulting, Inc.
;; Copyright (c) 2008-2009, Warhead.org.uk Ltd
;;
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
;; Redistributions of source code must retain the above copyright notice, this
;; list of conditions and the following disclaimer.
;;
;; Redistributions in binary form must reproduce the above copyright notice, this
;; list of conditions and the following disclaimer in the documentation and/or
;; other materials provided with the distribution.
;;
;; Neither the names of Warhead.org.uk Ltd, Snell Systems, nor Kitten
;; Technologies, nor the names of their contributors may be used to endorse or
;; promote products derived from this software without specific prior written
;; permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
;; ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(module posix-extras
 (change-link-mode change-link-owner change-file-times
  create-special-file create-character-device create-block-device
  file-access-time
  device-major device-minor make-device-number
  stat/ifmt stat/ififo stat/ifchr stat/ifdir
  stat/ifblk stat/ifreg stat/iflnk stat/ifsock

  stat-inode
  stat-permissions stat-mode stat-mode-type
  stat-links
  stat-owner
  stat-group
  stat-size
  stat-access-time
  stat-change-time
  stat-modification-time
  stat-device
  stat-device-number
  stat-block-size
  stat-blocks

  stat-type
  stat-regular-file?
  stat-symbolic-link?
  stat-block-device?
  stat-character-device?
  stat-fifo?
  stat-socket?
  stat-directory?

  resolve-pathname

  sleep
  
  )

(import scheme chicken foreign)
(require-library posix)
(import (prefix (only posix file-access-time file-modification-time)
                posix:))

(foreign-declare #<<EOF

#include <sys/stat.h>
#include <errno.h>

static int C_not_implemented(void) {
  errno = EINVAL;
  return -EINVAL;
}
static void *C_not_implemented_ptr(void) {
  errno = EINVAL;
  return 0;
}

#if defined (C_XXXBSD) && !defined(__OpenBSD__)
/* OpenBSD is the last of the BSDs that does not come with lchmod/lchown */
/* lchmod probably not available on OS X < 10.4.  Could simulate like */
/* http://www.mail-archive.com/rsync@lists.samba.org/msg19681.html */
/* and if so look into "#pragma weak lchmod". */
#define C_lchmod(fn, m)      C_fix(lchmod(C_data_pointer(fn), C_unfix(m)))
#define C_lchown(fn, u, g)   C_fix(lchown(C_data_pointer(fn), C_unfix(u), C_unfix(g)))
#else
#define C_lchmod(fn, m)     C_not_implemented()
#define C_lchown(fn, u, g) C_not_implemented()
#endif

#if defined (__unix__) || defined (C_XXXBSD)
#include <sys/types.h>
#define C_mknod(fn, m, d) C_fix(mknod(C_data_pointer(fn), C_unfix(m), C_unfix(d)))
#define C_mknod64(fn, m, maj, min) C_fix(mknod(C_data_pointer(fn), C_unfix(m), makedev(C_num_to_int(maj), C_num_to_int(min))))
/* music */
#define C_major(d) C_fix((unsigned int) major(C_num_to_unsigned_long(d)))  /* uint64 not avail until 4.6.4 */
#define C_minor(d) C_fix((unsigned int) minor(C_num_to_unsigned_long(d)))
C_inline unsigned int C_makedev (unsigned int maj, unsigned int min) {
  /* note: cannot be ulong return, because makedev may be int32,
     and int32->uint64 cast will blow up */
  return makedev(maj,min);
}
#define C_realpath(p,buf) realpath(p,buf)
#else
#define C_mknod(fn, m, d) C_not_implemented()
#define C_mknod64(fn, m, maj, min) C_not_implemented()
#define C_major(d) (C_SCHEME_FALSE)
#define C_minor(d) (C_SCHEME_FALSE)
#define C_makedev(maj,min) C_unfix(0)
#define C_realpath(p,buf) C_not_implemented_ptr()
#endif


#include <utime.h>

#ifdef _WIN32
#define utimbuf _utimbuf
#define utime _utime
#endif

static int set_file_atime_mtime(char *filename, C_word atm, C_word mtm)
{
  struct utimbuf tb;

  tb.actime = atm;
  tb.modtime = mtm;
  return utime(filename, &tb);
}

#ifdef _WIN32
#include <windows.h>
C_inline double C_sleep(double t) {
  Sleep(t*1000);
  return 0.0;
}
#else

/* We can assume nanosleep since the core scheduler.scm uses it, but
 * I'll leave the sleep+usleep variant here just in case. */
#define HAVE_NANOSLEEP 1

# ifdef HAVE_NANOSLEEP

#include <time.h>
C_inline double C_sleep(double t) {
  struct timespec rqts, rmts;
  time_t s = (time_t) t;
  rqts.tv_sec = s;
  rqts.tv_nsec = (t - s) * 1e9;
  if (nanosleep (&rqts, &rmts) == 0) {
    return 0.0;
  } else {
    return (rmts.tv_sec + 1e-9 * rmts.tv_nsec);
  }
}

# else

/* usleep cannot portably sleep for > 1 second.  Use sleep (3) for the seconds portion, or nanosleep. */
/* gettimeofday needed for usleep as it does not return remaining time on interrupt */
/* Note that perl's Time::HiRes returns elapsed time, not remaining time */
#include <sys/time.h>
C_inline double C_sleep(double t) {
  struct timeval tva, tvb;
  int s = (int)t;
  double us = t-s;
  if (us==0.0)
    return sleep(s);
  C_gettimeofday (&tva, NULL);
  s = sleep(s);
  if (s != 0) return s+us;
  if (usleep(us*1000000) == 0)
    return 0;
  C_gettimeofday (&tvb, NULL);
  return tvb.tv_sec - tva.tv_sec + 1e-6 * (tvb.tv_usec - tva.tv_usec);
}

# endif       /* HAVE_NANOSLEEP */
#endif       /* _WIN32 */

EOF
)

;; (define-foreign-variable _utime_atime double "C_utime_atime")
;; (define-foreign-variable _utime_mtime double "C_utime_mtime")

(define posix-error
  (let ([strerror (foreign-lambda c-string "strerror" int)]
        [string-append string-append] )
    (lambda (type loc msg . args)
      (let ([rn (##sys#update-errno)])
        (apply ##sys#signal-hook type loc (string-append msg " - " (strerror rn)) args) ) ) ) )

;; Declare stat mode variable, setting to 0 if nonexistent.  Under all known platforms,
;; 0 will not match any valid mode
(define-syntax (statmode x r c)
  ;; no need to rename here
  (let ((name (cadr x)))
    `(##core#begin
      (declare
	(foreign-declare
	 ,(sprintf "#ifndef ~a~%#define ~a 0~%#endif~%" name name)))
      (define-foreign-variable ,name unsigned-int))))

(statmode S_IFMT)
(statmode S_IFREG)
(statmode S_IFDIR)
(statmode S_IFLNK)
(statmode S_IFCHR)
(statmode S_IFBLK)
(statmode S_IFSOCK) ;; warning: posix-common.scm manually defines this
(statmode S_IFIFO)

(define stat/ifmt S_IFMT)
(define stat/ifreg S_IFREG)
(define stat/ifdir S_IFDIR)
(define stat/ififo S_IFIFO)
(define stat/ifchr S_IFCHR)
(define stat/ifblk S_IFBLK)
(define stat/iflnk S_IFLNK)
(define stat/ifsock S_IFSOCK)

(define change-link-mode
   (lambda (fname m)
      (##sys#check-string fname 'change-link-mode)
      (##sys#check-exact m 'change-link-mode)
      (when (fx< (##core#inline "C_lchmod" (##sys#make-c-string (##sys#expand-home-path fname)) m) 0)
        (posix-error #:file-error 'change-link-mode "cannot change link mode" fname m))))

(define change-link-owner
   (lambda (fn uid gid)
      (##sys#check-string fn 'change-link-owner)
      (##sys#check-exact uid 'change-link-owner)
      (##sys#check-exact gid 'change-link-owner)
      (when (fx< (##core#inline "C_lchown" (##sys#make-c-string (##sys#expand-home-path fn)) uid gid) 0)
         (posix-error #:file-error 'change-link-owner "cannot change link owner" fn uid gid))))

(define create-special-file
   (lambda (fn mode devnum #!optional minor)
     (##sys#check-string fn 'create-special-file)
     (##sys#check-exact mode 'create-special-file)     
     (cond (minor
            (##sys#check-number devnum 'create-special-file)
            (##sys#check-number minor 'create-special-file)            
            (when (fx< (##core#inline "C_mknod64" (##sys#make-c-string (##sys#expand-home-path fn))
                                      mode devnum minor) 0)
              (posix-error #:file-error 'create-special-file "cannot create special file" fn mode devnum minor)))
           (else
            (##sys#check-exact devnum 'create-special-file)
            (when (fx< (##core#inline "C_mknod" (##sys#make-c-string (##sys#expand-home-path fn))
                                      mode devnum) 0)
              (posix-error #:file-error 'create-special-file "cannot create special file" fn mode devnum))))))

(define (create-character-device fn major minor #!optional (mode #o666))
  (create-special-file fn (bitwise-ior stat/ifchr
                                       (bitwise-and mode (bitwise-not stat/ifmt)))
                       major minor))
(define (create-block-device fn major minor #!optional (mode #o666))
  (create-special-file fn (bitwise-ior stat/ifblk
                                       (bitwise-and mode (bitwise-not stat/ifmt)))
                       major minor))

;; Note: Chicken core uses unsigned-int (i.e. 30 bits) for dev_t in stat vector.
;; We force everything to 32-bit unsigned because it is least likely to cause
;; casting issues (int32->uint64 = boom).  Using dev_t requires detection of its width
;; to cast properly, otherwise sign extension kills us.
(define (device-major d)
  (##sys#check-number d 'device-major)
  (##core#inline "C_major" d))
(define (device-minor d)
  (##sys#check-number d 'device-minor)
  (##core#inline "C_minor" d))
(define (make-device-number maj min)
  (##sys#check-exact maj 'make-device-number)
  (##sys#check-exact min 'make-device-number)
  ((foreign-lambda unsigned-integer "C_makedev" int int)
   maj min))

;; (set! (file-modification-time fn) mtime) can also set mtime (git c3c499c [4.3.5]).
;; Like that setter, these time arguments are limited to 32-bit ints.
(define (change-file-times fn atime mtime)
   (##sys#check-string fn 'change-file-times)
   (##sys#check-number atime 'change-file-times)
   (##sys#check-number mtime 'change-file-times)

   (let ((r ((foreign-lambda int "set_file_atime_mtime" c-string integer integer)
             fn atime mtime)))
     (when (fx< r 0)
       (posix-error #:file-error 'change-file-times "cannot change file times"
                    fn atime mtime))))

;; Shadow posix's file-access-time with one that adds a setter.  Note that a stat is
;; required to get the current mtime first.
(define file-access-time
  (getter-with-setter
   posix:file-access-time
   (lambda (f t)
     (##sys#check-number t 'set-file-access-time)
     (let ((fn (##sys#expand-home-path f)))
              (let ((r ((foreign-lambda int "set_file_atime_mtime" c-string integer integer)
                 fn t (posix:file-modification-time fn))))
         (when (fx< r 0)
           (posix-error #:file-error 'set-file-access-time
                        "cannot set file access-time" f t)))))
   "(file-access-time f)"))

;; Solaris: reported to return a relative pathname sometimes
;; Passing NULL for backing store is an extension and may not be available everywhere.
(define (resolve-pathname p)
  (or ((foreign-lambda c-string* C_realpath c-string c-pointer)
       (##sys#expand-home-path p) #f)
      (posix-error #:file-error 'resolve-pathname "cannot resolve pathname" p)))

;;; Get me that file, stat

(define (stat-inode s) (vector-ref s 0))
;; for compatibility with file-permissions, we do not mask off with stat/ifmt,
;; but we provide stat-mode which does.
(define (stat-permissions s) (vector-ref s 1))
(define stat-mode
  (let ((mask (bitwise-not stat/ifmt)))
    (lambda (s)
      (bitwise-and (vector-ref s 1) mask))))
(define stat-mode-type
  (lambda (s)
    (bitwise-and (vector-ref s 1) stat/ifmt)))
(define (stat-links s) (vector-ref s 2))
(define (stat-owner s) (vector-ref s 3))
(define (stat-group s) (vector-ref s 4))           ;; oddly no file-group call in Unit posix
(define (stat-size s) (vector-ref s 5))
(define (stat-access-time s) (vector-ref s 6))
(define (stat-change-time s) (vector-ref s 7))
(define (stat-modification-time s) (vector-ref s 8))
(define (stat-device s) (vector-ref s 9))
(define (stat-device-number s) (vector-ref s 10))
(define (stat-block-size s) (vector-ref s 11))
(define (stat-blocks s) (vector-ref s 12))

;;; Helpers which work on stat vectors

;; Note: Might be nice to have analogue to stat-mode which masks off the file-type bits,
;; but can't figure out what to call it.
(define (stat-type s)
  (select (bitwise-and (stat-permissions s) stat/ifmt)
          ((S_IFLNK) 'symbolic-link)
          ((S_IFDIR) 'directory)
          ((S_IFCHR) 'character-device)
          ((S_IFBLK) 'block-device)
          ((S_IFIFO) 'fifo)
          ((S_IFSOCK) 'socket)
          (else 'regular-file)))

(define (stat-regular-file? s)
  (eq? 'regular-file (stat-type s)))

(define (stat-symbolic-link? s)
  (eq? 'symbolic-link (stat-type s)))

(define (stat-block-device? s)
  (eq? 'block-device (stat-type s)))

(define (stat-character-device? s)
  (eq? 'character-device (stat-type s)))

(define (stat-fifo? s)
  (eq? 'fifo (stat-type s)))

(define (stat-socket? s)
  (eq? 'socket (stat-type s)))

(define (stat-directory? s)
  (eq? 'directory (stat-type s)))

;;; Processes

(define sleep (foreign-lambda double C_sleep double))

)