posixunix.scm

Scheme跨平台编译器

    "if(C_groups == NULL) return(0);"
    "else return(1);") )

(define (get-groups)
  (let ([n (foreign-value "getgroups(0, C_groups)" int)])
    (when (fx< n 0)
      (##sys#update-errno)
      (##sys#error 'get-groups "cannot retrieve supplementary group ids") )
    (unless (_ensure-groups n)
      (##sys#error 'get-groups "out of memory") )
    (when (fx< (_get-groups n) 0)
      (##sys#update-errno)
      (##sys#error 'get-groups "cannot retrieve supplementary group ids") )
    (let loop ([i 0])
      (if (fx>= i n)
          '()
          (cons (##core#inline "C_get_gid" i) (loop (fx+ i 1))) ) ) ) )

(define (set-groups! lst0)
  (unless (_ensure-groups (length lst0))
    (##sys#error 'set-groups! "out of memory") )
  (do ([lst lst0 (##sys#slot lst 1)]
       [i 0 (fx+ i 1)] )
      ((null? lst)
       (when (fx< (##core#inline "C_set_groups" i) 0)
       (##sys#update-errno)
       (##sys#error 'set-groups! "cannot set supplementary group ids" lst0) ) )
    (let ([n (##sys#slot lst 0)])
      (##sys#check-exact n 'set-groups!)
      (##core#inline "C_set_gid" i n) ) ) )

(define initialize-groups
  (let ([init (foreign-lambda int "initgroups" c-string int)])
    (lambda (user id)
      (##sys#check-string user 'initialize-groups)
      (##sys#check-exact id 'initialize-groups)
      (when (fx< (init user id) 0)
      (##sys#update-errno)
      (##sys#error 'initialize-groups "cannot initialize supplementary group ids" user id) ) ) ) )


;;; More errno codes:

(define-foreign-variable _errno int "errno")

(define-foreign-variable _eperm int "EPERM")
(define-foreign-variable _enoent int "ENOENT")
(define-foreign-variable _esrch int "ESRCH")
(define-foreign-variable _eintr int "EINTR")
(define-foreign-variable _eio int "EIO")
(define-foreign-variable _efault int "EFAULT")
(define-foreign-variable _echild int "ECHILD")
(define-foreign-variable _enoexec int "ENOEXEC")
(define-foreign-variable _ebadf int "EBADF")
(define-foreign-variable _enomem int "ENOMEM")
(define-foreign-variable _eacces int "EACCES")
(define-foreign-variable _ebusy int "EBUSY")
(define-foreign-variable _eexist int "EEXIST")
(define-foreign-variable _enotdir int "ENOTDIR")
(define-foreign-variable _eisdir int "EISDIR")
(define-foreign-variable _einval int "EINVAL")
(define-foreign-variable _emfile int "EMFILE")
(define-foreign-variable _enospc int "ENOSPC")
(define-foreign-variable _espipe int "ESPIPE")
(define-foreign-variable _epipe int "EPIPE")
(define-foreign-variable _eagain int "EAGAIN")
(define-foreign-variable _erofs int "EROFS")
(define-foreign-variable _ewouldblock int "EWOULDBLOCK")

(define errno/perm _eperm)
(define errno/noent _enoent)
(define errno/srch _esrch)
(define errno/intr _eintr)
(define errno/io _eio)
(define errno/noexec _enoexec)
(define errno/badf _ebadf)
(define errno/child _echild)
(define errno/nomem _enomem)
(define errno/acces _eacces)
(define errno/fault _efault)
(define errno/busy _ebusy)
(define errno/notdir _enotdir)
(define errno/isdir _eisdir)
(define errno/inval _einval)
(define errno/mfile _emfile)
(define errno/nospc _enospc)
(define errno/spipe _espipe)
(define errno/pipe _epipe)
(define errno/again _eagain)
(define errno/rofs _erofs)
(define errno/exist _eexist)
(define errno/wouldblock _ewouldblock)

(define errno/2big 0)
(define errno/deadlk 0)
(define errno/dom 0)
(define errno/fbig 0)
(define errno/ilseq 0)
(define errno/mlink 0)
(define errno/nametoolong 0)
(define errno/nfile 0)
(define errno/nodev 0)
(define errno/nolck 0)
(define errno/nosys 0)
(define errno/notempty 0)
(define errno/notty 0)
(define errno/nxio 0)
(define errno/range 0)
(define errno/xdev 0)

;;; Permissions and owners:

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

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

(define-foreign-variable _r_ok int "R_OK")
(define-foreign-variable _w_ok int "W_OK")
(define-foreign-variable _x_ok int "X_OK")

(let ()
  (define (check filename acc loc)
    (##sys#check-string filename loc)
    (let ([r (fx= 0 (##core#inline "C_access" (##sys#make-c-string (##sys#expand-home-path filename)) acc))])
      (unless r (##sys#update-errno))
      r) )
  (set! file-read-access? (lambda (filename) (check filename _r_ok 'file-read-access?)))
  (set! file-write-access? (lambda (filename) (check filename _w_ok 'file-write-access?)))
  (set! file-execute-access? (lambda (filename) (check filename _x_ok 'file-execute-access?))) )

(define (create-session)
  (let ([a (##core#inline "C_setsid" #f)])
    (when (fx< a 0)
      (##sys#update-errno)
      (##sys#error 'create-session "cannot create session") )
    a) )

(define (set-process-group-id! pid pgid) ; DEPRECATED
  (##sys#check-exact pid 'set-process-group-id!)
  (##sys#check-exact pgid 'set-process-group-id!)
  (when (fx< (##core#inline "C_setpgid" pid pgid) 0)
    (##sys#update-errno)
    (##sys#error 'set-process-group-id! "cannot set process group ID" pid pgid) ) )

(define process-group-id
  (getter-with-setter
   (lambda (pid)
     (##sys#check-exact pid 'process-group-id)
     (let ([a (##core#inline "C_getpgid" pid)])
       (when (fx< a 0)
         (##sys#update-errno)
         (##sys#error 'process-group-id "cannot retrieve process group ID" pid) )
    a) )
   set-process-group-id!) )

;;; Hard and symbolic links:

(define create-symbolic-link
  (lambda (old new)
    (##sys#check-string old 'create-symbolic-link)
    (##sys#check-string new 'create-symbolic-link)
    (when (fx< (##core#inline
              "C_symlink"
              (##sys#make-c-string (##sys#expand-home-path old))
              (##sys#make-c-string (##sys#expand-home-path new)) )
             0)
      (posix-error #:file-error 'create-symbol-link "cannot create symbolic link" old new) ) ) )

(define-foreign-variable _filename_max int "FILENAME_MAX")

(define read-symbolic-link
  (let ([substring substring]
      [buf (make-string (fx+ _filename_max 1))] )
    (lambda (fname)
      (##sys#check-string fname 'read-symbolic-link)
      (let ([len (##core#inline "C_readlink" (##sys#make-c-string (##sys#expand-home-path fname)) buf)])
      (when (fx< len 0)
        (posix-error #:file-error 'read-symbolic-link "cannot read symbolic link" fname) )
      (substring buf 0 len) ) ) ) )

(define file-link
  (let ([link (foreign-lambda int "link" c-string c-string)])
    (lambda (old new)
      (##sys#check-string old 'file-link)
      (##sys#check-string new 'file-link)
      (when (fx< (link old new) 0)
      (posix-error #:file-error 'hard-link "could not create hard link" old new) ) ) ) )


;;; Using file-descriptors:

(define-foreign-variable _stdin_fileno int "STDIN_FILENO")
(define-foreign-variable _stdout_fileno int "STDOUT_FILENO")
(define-foreign-variable _stderr_fileno int "STDERR_FILENO")

(define fileno/stdin _stdin_fileno)
(define fileno/stdout _stdout_fileno)
(define fileno/stderr _stderr_fileno)

(let ()
  (define (mode inp m)
    (##sys#make-c-string
     (cond [(pair? m)
            (let ([m (car m)])
              (case m
                [(###append) (if (not inp) "a" (##sys#error "invalid mode for input file" m))]
                [else (##sys#error "invalid mode argument" m)] ) ) ]
           [inp "r"]
           [else "w"] ) ) )
  (define (check loc fd inp r)
    (if (##sys#null-pointer? r)
        (posix-error #:file-error loc "cannot open file" fd)
        (let ([port (##sys#make-port inp ##sys#stream-port-class "(fdport)" 'stream)])
          (##core#inline "C_set_file_ptr" port r)
          port) ) )
  (set! open-input-file*
    (lambda (fd . m)
      (##sys#check-exact fd 'open-input-file*)
      (check 'open-input-file* fd #t (##core#inline_allocate ("C_fdopen" 2) fd (mode #t m))) ) )
  (set! open-output-file*
    (lambda (fd . m)
      (##sys#check-exact fd 'open-output-file*)
      (check 'open-output-file* fd #f (##core#inline_allocate ("C_fdopen" 2) fd (mode #f m)) ) ) ) )

(define port->fileno
  (lambda (port)
    (##sys#check-port port 'port->fileno)
    (cond [(eq? 'socket (##sys#slot port 7)) (##sys#tcp-port->fileno port)]
          [(not (zero? (##sys#peek-unsigned-integer port 0)))
           (let ([fd (##core#inline "C_C_fileno" port)])
             (when (fx< fd 0)
               (posix-error #:file-error 'port->fileno "cannot access file-descriptor of port" port) )
             fd) ]
          [else (posix-error #:type-error 'port->fileno "port has no attached file" port)] ) ) )

(define duplicate-fileno
  (lambda (old . new)
    (##sys#check-exact old duplicate-fileno)
    (let ([fd (if (null? new)
                  (##core#inline "C_dup" old)
                  (let ([n (car new)])
                    (##sys#check-exact n 'duplicate-fileno)
                    (##core#inline "C_dup2" old n) ) ) ] )
      (when (fx< fd 0)
        (posix-error #:file-error 'duplicate-fileno "cannot duplicate file-descriptor" old) )
      fd) ) )

(define ##sys#custom-input-port
  (let ([make-input-port make-input-port]
        [set-port-name! set-port-name!] )
    (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 1) (on-close noop) (more? #f))
      (when nonblocking? (##sys#file-nonblocking! fd) )
      (let ([bufsiz (if (fixnum? bufi) bufi (##sys#size bufi))]
            [buf (if (fixnum? bufi) (##sys#make-string bufi) bufi)]
            [buflen 0]
            [bufpos 0] )
        (let (
            [ready?
              (lambda ()
                (when (fx= -1 (##sys#file-select-one fd))
                  (posix-error #:file-error loc "cannot select" fd nam) ) )]
            [peek
              (lambda ()
                (if (fx>= bufpos buflen)
                    #!eof
                    (##core#inline "C_subchar" buf bufpos)) )]
            [fetch
              (lambda ()
                (when (fx>= bufpos buflen)
                  (let loop ()
                    (let ([cnt (##core#inline "C_read" fd buf bufsiz)])
                      (cond [(fx= cnt -1)
                              (if (fx= _errno _ewouldblock)
                                  (begin
                                    (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
                                    (##sys#thread-yield!)
                                    (loop) )
                                  (posix-error #:file-error loc "cannot read" fd nam) )]
                            [(and more? (fx= cnt 0))
                              ; When "more" keep trying, otherwise read once more
                              ; to guard against race conditions
                              (if (more?)
                                  (begin
                                    (##sys#thread-yield!)
                                    (loop) )
                                  (let ([cnt (##core#inline "C_read" fd buf bufsiz)])
                                    (when (fx= cnt -1)
                                      (if (fx= _errno _ewouldblock)
                                          (set! cnt 0)
                                          (posix-error #:file-error loc "cannot read" fd nam) ) )
                                    (set! buflen cnt)
                                    (set! bufpos 0) ) )]
                            [else
                              (set! buflen cnt)
                              (set! bufpos 0)]) ) ) ) )] )
          (letrec (
              [this-port
                (make-input-port
                  (lambda ()                    ; read-char
                    (fetch)
                    (let ([ch (peek)])
                      #; ; Allow increment since overflow is far, far away
                      (unless (eof-object? ch) (set! bufpos (fx+ bufpos 1)))
                      (set! bufpos (fx+ bufpos 1))
                      ch ) )
                  (lambda ()                    ; char-ready?
                    (or (fx< bufpos buflen)
                        (ready?)) )
                  (lambda ()                    ; close
                    ; Do nothing when closed already
                    (unless (##sys#slot this-port 8)
                      (when (fx< (##core#inline "C_close" fd) 0)
                        (posix-error #:file-error loc "cannot close" fd nam) )
                      (on-close) ) )
                  (lambda ()                    ; peek-char
                    (fetch)
                    (peek) )
                  (lambda (port n dest start)   ; read-string!
                    (let loop ([n (or n (fx- (##sys#size dest) start))] [m 0] [start start])
                      (cond [(eq? 0 n) m]
                            [(fx< bufpos buflen)
                              (let* ([rest (fx- buflen bufpos)]
                                     [n2 (if (fx< n rest) n rest)])
                                (##core#inline "C_substring_copy" buf dest bufpos (fx+ bufpos n2) start)
                                (set! bufpos (fx+ bufpos n2))
                                (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) ]
                            [else
                              (fetch