posixunix.scm

Scheme跨平台编译器

;;; Pipes:

(let ()
  (define (mode arg) (if (pair? arg) (##sys#slot arg 0) '###text))
  (define (badmode m) (##sys#error "illegal input/output mode specifier" m))
  (define (check loc cmd inp r)
    (if (##sys#null-pointer? r)
	(posix-error #:file-error loc "cannot open pipe" cmd)
	(let ([port (##sys#make-port inp ##sys#stream-port-class "(pipe)" 'stream)])
	  (##core#inline "C_set_file_ptr" port r)
	  port) ) )
  (set! open-input-pipe
    (lambda (cmd . m)
      (##sys#check-string cmd 'open-input-pipe)
      (let ([m (mode m)])
	(check
	 'open-input-pipe
	 cmd #t
	 (case m
	   ((#:text) (##core#inline_allocate ("open_text_input_pipe" 2) (##sys#make-c-string cmd)))
	   ((#:binary) (##core#inline_allocate ("open_binary_input_pipe" 2) (##sys#make-c-string cmd)))
	   (else (badmode m)) ) ) ) ) )
  (set! open-output-pipe
    (lambda (cmd . m)
      (##sys#check-string cmd 'open-output-pipe)
      (let ((m (mode m)))
	(check
	 'open-output-pipe
	 cmd #f
	 (case m
	   ((#:text) (##core#inline_allocate ("open_text_output_pipe" 2) (##sys#make-c-string cmd)))
	   ((#:binary) (##core#inline_allocate ("open_binary_output_pipe" 2) (##sys#make-c-string cmd)))
	   (else (badmode m)) ) ) ) ) )
  (set! close-input-pipe
    (lambda (port)
      (##sys#check-port port 'close-input-pipe)
      (let ((r (##core#inline "close_pipe" port)))
	(when (eq? -1 r) (posix-error #:file-error 'close-input/output-pipe "error while closing pipe" port))
	r) ) )
  (set! close-output-pipe close-input-pipe) )

(let ([open-input-pipe open-input-pipe]
      [open-output-pipe open-output-pipe]
      [close-input-pipe close-input-pipe]
      [close-output-pipe close-output-pipe] )
  (set! call-with-input-pipe
    (lambda (cmd proc . mode)
      (let ([p (apply open-input-pipe cmd mode)])
	(##sys#call-with-values
	 (lambda () (proc p))
	 (lambda results
	   (close-input-pipe p)
	   (apply values results) ) ) ) ) )
  (set! call-with-output-pipe
    (lambda (cmd proc . mode)
      (let ([p (apply open-output-pipe cmd mode)])
	(##sys#call-with-values
	 (lambda () (proc p))
	 (lambda results
	   (close-output-pipe p)
	   (apply values results) ) ) ) ) )
  (set! with-input-from-pipe
    (lambda (cmd thunk . mode)
      (let ([old ##sys#standard-input]
	    [p (apply open-input-pipe cmd mode)] )
	(set! ##sys#standard-input p)
	(##sys#call-with-values thunk
				(lambda results
				  (close-input-pipe p)
				  (set! ##sys#standard-input old)
				  (apply values results) ) ) ) ) )
  (set! with-output-to-pipe
    (lambda (cmd thunk . mode)
      (let ([old ##sys#standard-output]
	    [p (apply open-output-pipe cmd mode)] )
	(set! ##sys#standard-output p)
	(##sys#call-with-values thunk
				(lambda results
				  (close-output-pipe p)
				  (set! ##sys#standard-output old)
				  (apply values results) ) ) ) ) ) )

(define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]")
(define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]")

(define create-pipe
  (lambda ()
    (when (fx< (##core#inline "C_pipe" #f) 0)
      (posix-error #:file-error 'create-pipe "cannot create pipe") )
    (values _pipefd0 _pipefd1) ) )


;;; Signal processing:

(define-foreign-variable _nsig int "NSIG")
(define-foreign-variable _sigterm int "SIGTERM")
(define-foreign-variable _sigkill int "SIGKILL")
(define-foreign-variable _sigint int "SIGINT")
(define-foreign-variable _sighup int "SIGHUP")
(define-foreign-variable _sigfpe int "SIGFPE")
(define-foreign-variable _sigill int "SIGILL")
(define-foreign-variable _sigsegv int "SIGSEGV")
(define-foreign-variable _sigabrt int "SIGABRT")
(define-foreign-variable _sigtrap int "SIGTRAP")
(define-foreign-variable _sigquit int "SIGQUIT")
(define-foreign-variable _sigalrm int "SIGALRM")
(define-foreign-variable _sigpipe int "SIGPIPE")
(define-foreign-variable _sigusr1 int "SIGUSR1")
(define-foreign-variable _sigusr2 int "SIGUSR2")
(define-foreign-variable _sigvtalrm int "SIGVTALRM")
(define-foreign-variable _sigprof int "SIGPROF")
(define-foreign-variable _sigio int "SIGIO")
(define-foreign-variable _sigurg int "SIGURG")
(define-foreign-variable _sigchld int "SIGCHLD")
(define-foreign-variable _sigcont int "SIGCONT")
(define-foreign-variable _sigstop int "SIGSTOP")
(define-foreign-variable _sigtstp int "SIGTSTP")
(define-foreign-variable _sigxcpu int "SIGXCPU")
(define-foreign-variable _sigxfsz int "SIGXFSZ")
(define-foreign-variable _sigwinch int "SIGWINCH")

(define signal/term _sigterm)
(define signal/kill _sigkill)
(define signal/int _sigint)
(define signal/hup _sighup)
(define signal/fpe _sigfpe)
(define signal/ill _sigill)
(define signal/segv _sigsegv)
(define signal/abrt _sigabrt)
(define signal/trap _sigtrap)
(define signal/quit _sigquit)
(define signal/alrm _sigalrm)
(define signal/vtalrm _sigvtalrm)
(define signal/prof _sigprof)
(define signal/io _sigio)
(define signal/urg _sigurg)
(define signal/chld _sigchld)
(define signal/cont _sigcont)
(define signal/stop _sigstop)
(define signal/tstp _sigtstp)
(define signal/pipe _sigpipe)
(define signal/xcpu _sigxcpu)
(define signal/xfsz _sigxfsz)
(define signal/usr1 _sigusr1)
(define signal/usr2 _sigusr2)
(define signal/winch _sigwinch)

(define signals-list
  (list
    signal/term signal/kill signal/int signal/hup signal/fpe signal/ill
    signal/segv signal/abrt signal/trap signal/quit signal/alrm signal/vtalrm
    signal/prof signal/io signal/urg signal/chld signal/cont signal/stop
    signal/tstp signal/pipe signal/xcpu signal/xfsz signal/usr1 signal/usr2
    signal/winch))

(let ([oldhook ##sys#interrupt-hook]
      [sigvector (make-vector 256 #f)] )
  (set! signal-handler
    (lambda (sig)
      (##sys#check-exact sig 'signal-handler)
      (##sys#slot sigvector sig) ) )
  (set! set-signal-handler!
    (lambda (sig proc)
      (##sys#check-exact sig 'set-signal-handler!)
      (##core#inline "C_establish_signal_handler" sig (and proc sig))
      (vector-set! sigvector sig proc) ) )
  (set! ##sys#interrupt-hook
    (lambda (reason state)
      (let ([h (##sys#slot sigvector reason)])
        (if h
            (begin
              (h reason)
              (##sys#context-switch state) )
            (oldhook reason state) ) ) ) ) )

(define set-signal-mask!
  (lambda (sigs)
    (##sys#check-list sigs 'set-signal-mask!)
    (##core#inline "C_sigemptyset" 0)
    (for-each
      (lambda (s)
        (##sys#check-exact s 'set-signal-mask!)
        (##core#inline "C_sigaddset" s) )
      sigs)
    (when (fx< (##core#inline "C_sigprocmask_set" 0) 0)
      (posix-error #:process-error 'set-signal-mask! "cannot set signal mask") ) ) )

(define (signal-mask)
  (let loop ([sigs signals-list] [mask '()])
    (if (null? sigs)
        mask
        (let ([sig (car sigs)])
          (loop (cdr sigs) (if (##core#inline "C_sigismember" sig) (cons sig mask) mask)) ) ) ) )

(define (signal-masked? sig)
  (##sys#check-exact sig 'signal-masked?)
  (##core#inline "C_sigismember" sig) )

(define (signal-mask! sig)
  (##sys#check-exact sig 'signal-mask!)
  (##core#inline "C_sigaddset" sig)
  (when (fx< (##core#inline "C_sigprocmask_block" 0) 0)
      (posix-error #:process-error 'signal-mask! "cannot block signal") )  )

(define (signal-unmask! sig)
  (##sys#check-exact sig 'signal-unmask!)
  (##core#inline "C_sigdelset" sig)
  (when (fx< (##core#inline "C_sigprocmask_unblock" 0) 0)
      (posix-error #:process-error 'signal-unmask! "cannot unblock signal") )  )

;;; Set SIGINT handler:

(set-signal-handler!
 signal/int
 (lambda (n) (##sys#user-interrupt-hook)) )


;;; Getting system-, group- and user-information:

(define-foreign-variable _uname int "C_uname")
(define-foreign-variable _uname-sysname nonnull-c-string "C_utsname.sysname")
(define-foreign-variable _uname-nodename nonnull-c-string "C_utsname.nodename")
(define-foreign-variable _uname-release nonnull-c-string "C_utsname.release")
(define-foreign-variable _uname-version nonnull-c-string "C_utsname.version")
(define-foreign-variable _uname-machine nonnull-c-string "C_utsname.machine")

(define system-information
  (lambda ()
    (when (fx< _uname 0)
      (##sys#update-errno)
      (##sys#error 'system-information "cannot retrieve system information") )
    (list _uname-sysname
          _uname-nodename
          _uname-release
          _uname-version
          _uname-machine) ) )

(define set-user-id!                  ; DEPRECATED
  (lambda (id)
    (when (fx< (##core#inline "C_setuid" id) 0)
      (##sys#update-errno)
      (##sys#error 'set-user-id! "cannot set user ID" id) ) ) )

(define current-user-id
  (getter-with-setter
   (foreign-lambda int "C_getuid")
   set-user-id!) )

(define current-effective-user-id
  (getter-with-setter
   (foreign-lambda int "C_geteuid")
   (lambda (id)
    (when (fx< (##core#inline "C_seteuid" id) 0)
      (##sys#update-errno)
      (##sys#error 
	 'effective-user-id!-setter "cannot set effective user ID" id) ) ) ) )

(define set-group-id!                 ; DEPRECATED
  (lambda (id)
    (when (fx< (##core#inline "C_setgid" id) 0)
      (##sys#update-errno)
      (##sys#error 'set-user-id! "cannot set group ID" id) ) ) )

(define current-group-id
  (getter-with-setter
   (foreign-lambda int "C_getgid")
   set-group-id!) )

(define current-effective-group-id
  (getter-with-setter 
   (foreign-lambda int "C_getegid")
   (lambda (id)
    (when (fx< (##core#inline "C_setegid" id) 0)
      (##sys#update-errno)
      (##sys#error 
	 'effective-group-id!-setter "cannot set effective group ID" id) ) ) ) )

(define-foreign-variable _user-name nonnull-c-string "C_user->pw_name")
(define-foreign-variable _user-passwd nonnull-c-string "C_user->pw_passwd")
(define-foreign-variable _user-uid int "C_user->pw_uid")
(define-foreign-variable _user-gid int "C_user->pw_gid")
(define-foreign-variable _user-gecos nonnull-c-string "C_user->pw_gecos")
(define-foreign-variable _user-dir c-string "C_user->pw_dir")
(define-foreign-variable _user-shell c-string "C_user->pw_shell")

(define (user-information user #!optional as-vector)
  (let ([r (if (fixnum? user)
               (##core#inline "C_getpwuid" user)
               (begin
                 (##sys#check-string user 'user-information)
                 (##core#inline "C_getpwnam" (##sys#make-c-string user)) ) ) ] )
    (and r
         ((if as-vector vector list)
          _user-name
          _user-passwd
          _user-uid
          _user-gid
          _user-gecos
          _user-dir
          _user-shell) ) ) )

(define (current-user-name)
  (list-ref (user-information (current-user-id)) 0) )

(define (current-effective-user-name)
  (list-ref (user-information (current-effective-user-id)) 0) )

(define-foreign-variable _group-name nonnull-c-string "C_group->gr_name")
(define-foreign-variable _group-passwd nonnull-c-string "C_group->gr_passwd")
(define-foreign-variable _group-gid int "C_group->gr_gid")

(define group-member
  (foreign-lambda* c-string ([int i])
    "return(C_group->gr_mem[ i ]);") )

(define (group-information group #!optional as-vector)
  (let ([r (if (fixnum? group)
               (##core#inline "C_getgrgid" group)
               (begin
                 (##sys#check-string group 'group-information)
                 (##core#inline "C_getgrnam" (##sys#make-c-string group)) ) ) ] )
    (and r
         ((if as-vector vector list)
          _group-name
          _group-passwd
          _group-gid
          (let loop ([i 0])
            (let ([n (group-member i)])
              (if n
                  (cons n (loop (fx+ i 1)))
                  '() ) ) ) ) ) ) )

(define _get-groups
  (foreign-lambda* int ([int n])
    "return(getgroups(n, C_groups));") )

(define _ensure-groups
  (foreign-lambda* bool ([int n])
    "if(C_groups != NULL) C_free(C_groups);"
    "C_groups = (gid_t *)C_malloc(sizeof(gid_t) * n);"