posixunix.scm

Scheme跨平台编译器

(define file-select
  (let ([fd_zero (foreign-lambda void "C_zero_fd_set" int)]
        [fd_set (foreign-lambda void "C_set_fd_set" int int)]
        [fd_test (foreign-lambda bool "C_test_fd_set" int int)] )
    (lambda (fdsr fdsw . timeout)
      (let ([fdmax 0]
            [tm (if (pair? timeout) (car timeout) #f)] )
        (fd_zero 0)
        (fd_zero 1)
        (cond [(not fdsr)]
              [(fixnum? fdsr)
               (set! fdmax fdsr)
               (fd_set 0 fdsr) ]
              [else
               (##sys#check-list fdsr 'file-select)
               (for-each
                (lambda (fd)
                  (##sys#check-exact fd 'file-select)
                  (set! fdmax (##core#inline "C_i_fixnum_max" fdmax fd))
                  (fd_set 0 fd) )
                fdsr) ] )
        (cond [(not fdsw)]
              [(fixnum? fdsw)
               (set! fdmax fdsw)
               (fd_set 1 fdsw) ]
              [else
               (##sys#check-list fdsw 'file-select)
               (for-each
                (lambda (fd)
                  (##sys#check-exact fd 'file-select)
                  (set! fdmax (##core#inline "C_i_fixnum_max" fdmax fd))
                  (fd_set 1 fd) )
                fdsw) ] )
        (let ([n (cond [tm
                        (##sys#check-number tm 'file-select)
                        (##core#inline "C_C_select_t" (fx+ fdmax 1) tm) ]
                       [else (##core#inline "C_C_select" (fx+ fdmax 1))] ) ] )
          (cond [(fx< n 0)
                 (posix-error #:file-error 'file-select "failed" fdsr fdsw) ]
                [(fx= n 0) (values (if (pair? fdsr) '() #f) (if (pair? fdsw) '() #f))]
                [else
                 (values
                  (and fdsr
                       (if (fixnum? fdsr)
                           (fd_test 0 fdsr)
                           (let ([lstr '()])
                             (for-each (lambda (fd) (when (fd_test 0 fd) (set! lstr (cons fd lstr)))) fdsr)
                             lstr) ) )
                  (and fdsw
                       (if (fixnum? fdsw)
                           (fd_test 1 fdsw)
                           (let ([lstw '()])
                             (for-each (lambda (fd) (when (fd_test 1 fd) (set! lstw (cons fd lstw)))) fdsw)
                             lstw) ) ) ) ] ) ) ) ) ) )


;;; File attribute access:

(define-foreign-variable _seek_set int "SEEK_SET")
(define-foreign-variable _seek_cur int "SEEK_CUR")
(define-foreign-variable _seek_end int "SEEK_END")

(define seek/set _seek_set)
(define seek/end _seek_end)
(define seek/cur _seek_cur)

(define-foreign-variable _stat_st_ino unsigned-int "C_statbuf.st_ino")
(define-foreign-variable _stat_st_nlink unsigned-int "C_statbuf.st_nlink")
(define-foreign-variable _stat_st_gid unsigned-int "C_statbuf.st_gid")
(define-foreign-variable _stat_st_size integer64 "C_statbuf.st_size")
(define-foreign-variable _stat_st_mtime double "C_statbuf.st_mtime")
(define-foreign-variable _stat_st_atime double "C_statbuf.st_atime")
(define-foreign-variable _stat_st_ctime double "C_statbuf.st_ctime")
(define-foreign-variable _stat_st_uid unsigned-int "C_statbuf.st_uid")
(define-foreign-variable _stat_st_mode unsigned-int "C_statbuf.st_mode")
(define-foreign-variable _stat_st_dev unsigned-int "C_statbuf.st_dev")
(define-foreign-variable _stat_st_rdev unsigned-int "C_statbuf.st_rdev")
(define-foreign-variable _stat_st_blksize unsigned-int "C_statbuf.st_blksize")
(define-foreign-variable _stat_st_blocks unsigned-int "C_statbuf.st_blocks")

(define (##sys#stat file link loc)
  (let ([r (cond [(fixnum? file) (##core#inline "C_fstat" file)]
                 [(string? file)
                  (let ([path (##sys#make-c-string (##sys#expand-home-path file))])
		    (if link
			(##core#inline "C_lstat" path)
			(##core#inline "C_stat" path) ) ) ]
                 [else (##sys#signal-hook #:type-error "bad argument type - not a fixnum or string" file)] ) ] )
    (when (fx< r 0)
      (posix-error #:file-error loc "cannot access file" file) ) ) )

(define (file-stat f . link)
  (##sys#stat f (:optional link #f) 'file-stat)
  (vector _stat_st_ino _stat_st_mode _stat_st_nlink
          _stat_st_uid _stat_st_gid _stat_st_size
          _stat_st_atime _stat_st_ctime _stat_st_mtime
          _stat_st_dev _stat_st_rdev
          _stat_st_blksize _stat_st_blocks) )

(define (file-size f) (##sys#stat f #f 'file-size) _stat_st_size)
(define (file-modification-time f) (##sys#stat f #f 'file-modification-time) _stat_st_mtime)
(define (file-access-time f) (##sys#stat f #f 'file-access-time) _stat_st_atime)
(define (file-change-time f) (##sys#stat f #f 'file-change-time) _stat_st_ctime)
(define (file-owner f) (##sys#stat f #f 'file-owner) _stat_st_uid)
(define (file-permissions f) (##sys#stat f #f 'file-permissions) _stat_st_mode)

(define (regular-file? fname)
  (##sys#check-string fname 'regular-file?)
  (##sys#stat fname #t 'regular-file?)
  (foreign-value "C_isreg" bool) )

(define (symbolic-link? fname)
  (##sys#check-string fname 'symbolic-link?)
  (##sys#stat fname #t 'symbolic-link?)
  (foreign-value "C_islink" bool) )

(define (stat-regular? fname)
    (##sys#check-string fname 'stat-regular?)
    (##sys#stat fname #f 'stat-regular?)
    (foreign-value "C_isreg" bool))

(define (stat-directory? fname)
    (##sys#check-string fname 'stat-directory?)
    (##sys#stat fname #f 'stat-directory?)
    (foreign-value "C_isdir" bool))

(define (stat-char-device? fname)
    (##sys#check-string fname 'stat-char-device?)
    (##sys#stat fname #f 'stat-char-device?)
    (foreign-value "C_ischr" bool))

(define (stat-block-device? fname)
    (##sys#check-string fname 'stat-block-device?)
    (##sys#stat fname #f 'stat-block-device?)
    (foreign-value "C_isblk" bool))

(define (stat-fifo? fname)
    (##sys#check-string fname 'stat-fifo?)
    (##sys#stat fname #f 'stat-fifo?)
    (foreign-value "C_isfifo" bool))

(define (stat-symlink? fname)
    (##sys#check-string fname 'stat-symlink?)
    (##sys#stat fname #t 'stat-symlink?)
    (foreign-value "C_islink" bool))

(define (stat-socket? fname)
    (##sys#check-string fname 'stat-socket?)
    (##sys#stat fname #f 'stat-socket?)
    (foreign-value "C_issock" bool))

(define set-file-position!              ; DEPRECATED
  (lambda (port pos . whence)
    (let ([whence (if (pair? whence) (car whence) _seek_set)])
      (##sys#check-exact pos 'set-file-position!)
      (##sys#check-exact whence 'set-file-position!)
      (when (fx< pos 0) (##sys#signal-hook #:bounds-error 'set-file-position! "invalid negative port position" pos port))
      (unless (cond [(port? port)
                     (and (eq? (##sys#slot port 7) 'stream)
                          (##core#inline "C_fseek" port pos whence) ) ]
                    [(fixnum? port) (##core#inline "C_lseek" port pos whence)]
                    [else (##sys#signal-hook #:type-error 'set-file-position! "invalid file" port)] )
        (posix-error #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) )

(define file-position
  (getter-with-setter
   (lambda (port)
    (let ([pos (cond [(port? port)
                      (if (eq? (##sys#slot port 7) 'stream)
                          (##core#inline "C_ftell" port)
                          -1) ]
                     [(fixnum? port) (##core#inline "C_lseek" port 0 _seek_cur)]
                     [else (##sys#signal-hook #:type-error 'file-position "invalid file" port)] ) ] )
      (when (fx< pos 0)
        (posix-error #:file-error 'file-position "cannot retrieve file position of port" port) )
      pos) )
   set-file-position!) )


;;; Directory stuff:

(define-inline (create-directory-helper name)
    (unless (zero? (##core#inline "C_mkdir" (##sys#make-c-string name)))
            (posix-error #:file-error 'create-directory
                         "cannot create directory" name)))

(define-inline (create-directory-check name)
    (if (file-exists? name)
        (if (fx< (##core#inline "C_stat" (##sys#make-c-string name)) 0)
            (posix-error #:file-error 'create-directory
                         "cannot stat file" name)
            (or (foreign-value "C_isdir" bool)
                (posix-error #:file-error 'create-directory
                             "path segment is a file" name)))
        #f))

(define-inline (create-directory-helper-silent name)
    (unless (create-directory-check name)
            (create-directory-helper name)))

(define-inline (create-directory-helper-parents name)
    (let ((c   ""))
        (for-each
             (lambda (x)
                 (set! c (string-append c "/" x))
                 (create-directory-helper-silent c))
             (string-split name "/"))))

(define create-directory
  (lambda (name #!optional parents?)
    (##sys#check-string name 'create-directory)
    (if parents?
        (create-directory-helper-parents (canonical-path name))
        (create-directory-helper (canonical-path name)))))
;    (unless (zero? (##core#inline "C_mkdir" (##sys#make-c-string (##sys#expand-home-path name))))
;      (posix-error #:file-error 'create-directory "cannot create directory" name) ) ) )

(define change-directory
  (lambda (name)
    (##sys#check-string name 'change-directory)
    (unless (zero? (##core#inline "C_chdir" (##sys#make-c-string (##sys#expand-home-path name))))
      (posix-error #:file-error 'change-directory "cannot change current directory" name) ) ) )

(define delete-directory
  (lambda (name)
    (##sys#check-string name 'delete-directory)
    (unless (zero? (##core#inline "C_rmdir" (##sys#make-c-string (##sys#expand-home-path name))))
      (posix-error #:file-error 'delete-directory "cannot delete directory" name) ) ) )

(define directory
  (let ([string-ref string-ref]
        [make-string make-string]
        [string string] )
    (lambda (#!optional (spec (current-directory)) show-dotfiles?)
      (##sys#check-string spec 'directory)
      (let ([buffer (make-string 256)]
            [handle (##sys#make-pointer)]
            [entry (##sys#make-pointer)] )
        (##core#inline "C_opendir" (##sys#make-c-string (##sys#expand-home-path spec)) handle)
        (if (##sys#null-pointer? handle)
            (posix-error #:file-error 'directory "cannot open directory" spec)
            (let loop ()
              (##core#inline "C_readdir" handle entry)
              (if (##sys#null-pointer? entry)
                  (begin
                    (##core#inline "C_closedir" handle)
                    '() )
                  (let* ([flen (##core#inline "C_foundfile" entry buffer)]
                         [file (##sys#substring buffer 0 flen)]
                         [char1 (string-ref file 0)]
                         [char2 (and (fx> flen 1) (string-ref file 1))] )
                    (if (and (eq? #\. char1)
                             (or (not char2)
                                 (and (eq? #\. char2) (eq? 2 flen))
                                 (not show-dotfiles?) ) )
                        (loop)
                        (cons file (loop)) ) ) ) ) ) ) ) ) )

(define (directory? fname)
  (##sys#check-string fname 'directory?)
  (let ((info (##sys#file-info (##sys#expand-home-path fname))))
    (and info (fx= 1 (##sys#slot info 4))) ) )

(define current-directory
  (let ([make-string make-string])
    (lambda (#!optional dir)
      (if dir
          (change-directory dir)
          (let* ([buffer (make-string 256)]
                 [len (##core#inline "C_curdir" buffer)] )
            (if len
                (##sys#substring buffer 0 len)
                (posix-error #:file-error 'current-directory "cannot retrieve current directory") ) ) ) ) ) )


(define canonical-path
    (let ((null?      null?)
          (char=?     char=?)
          (string=?   string=?)
          (alpha?     char-alphabetic?)
          (sref       string-ref)
          (ssplit     (cut string-split <> "/\\"))
          (sappend    string-append)
          (isperse    (cut string-intersperse <> "/"))
          (sep?       (lambda (c) (or (char=? #\/ c) (char=? #\\ c))))
          (getenv     getenv)
          (user       current-user-name)
          (cwd        (let ((cw   current-directory))
                          (lambda ()
                              (condition-case (cw)
                                  (var ()    "/"))))))
        (lambda (path)
            (##sys#check-string path 'canonical-path)
            (let ((p   (cond ((fx= 0 (##sys#size path))
                                 (sappend (cwd) "/"))
                             ((and (fx< (##sys#size path) 3)
                                   (sep? (sref path 0)))
                                 path)
                             ((fx= 1 (##sys#size path))
                                 (sappend (cwd) "/" path))
                             ((and (char=? #\~ (sref path 0))
                                   (sep? (sref path 1)))
                                 (sappend
                                     (or (getenv "HOME")
                                         (sappend "/home/" (user)))
                                     (##sys#substring path 1
                                         (##sys#size path))))
                             ((fx= 2 (##sys#size path))
                                 (sappend (cwd) "/" path))
                             ((and (alpha? (sref path 0))
                                   (char=? #\: (sref path 1))
                                   (sep? (sref path 2)))
                                 (##sys#substring path 3 (##sys#size path)))
                             ((and (char=? #\/ (sref path 0))
                                   (alpha? (sref path 1))
                                   (char=? #\: (sref path 2)))
                                 (##sys#substring path 3 (##sys#size path)))
                             ((sep? (sref path 0))
                                 path)
                             (else
                                 (sappend (cwd) "/" path)))))
                (let loop ((l   (ssplit p))
                           (r   '()))
                    (if (null? l)
                        (if (null? r)
                            "/"
                            (if (sep? (sref p (- (##sys#size p) 1)))
                                (sappend
                                    "/"
                                    (isperse (reverse (cons "" r))))
                                (sappend
                                    "/"
                                    (isperse (reverse r)))))
                        (loop
                            (cdr l)
                            (if (string=? ".." (car l))
                                (cdr r)
                                (if (string=? "." (car l))
                                    r
                                    (cons (car l) r))))))))))