(format s "System call error ~A (~A)"
errno (sb-int:strerror errno))))))
-(defvar *errno-table*
- (let ((errno-max 0)
- list)
- (do-symbols (symbol (find-package "SB-POSIX"))
- (when (get symbol 'errno)
- (let ((errno (symbol-value symbol)))
- (setf errno-max (max errno errno-max))
- (push (cons errno
- (eval `(define-condition ,symbol (syscall-error) ())))
- list))))
- (let ((table (make-array (1+ errno-max))))
- (mapc #'(lambda (cons) (setf (elt table (car cons)) (cdr cons))) list)
- table)))
-
(defun syscall-error ()
- (let ((errno (get-errno)))
- (error (elt *errno-table* errno) :errno errno)))
+ (error 'sb-posix:syscall-error :errno (get-errno)))
(defun unsupported-error (lisp-name c-name)
(error "~S is unsupported by SBCL on this platform due to lack of ~A()."
(warn "~S is unsupported by SBCL on this platform due to lack of ~A()."
lisp-name c-name))
-;; Note that we inherit from SIMPLE-FILE-ERROR first, to get its
-;; error reporting, rather than SYSCALL-ERROR's.
-(define-condition file-syscall-error
- (sb-impl::simple-file-error syscall-error)
- ())
-
-(defvar *file-errno-table*
- (let ((array (copy-seq *errno-table*)))
- (map-into array
- (lambda (condition-class-name)
- (if (symbolp condition-class-name)
- (let ((file-condition-name
- (read-from-string
- (format nil "FILE-~A" condition-class-name))))
- ;; Should condition class names like FILE-ENOENT
- ;; and FILE-ENOTDIR be exported? I want to say
- ;; "no", since we already export ENOENT, ENOTDIR
- ;; et al, and so the user can write handlers
- ;; such as
- ;;
- ;; (handler-bind ((sb-posix:enoent ...)
- ;; (sb-posix:enotdir ...)
- ;; (file-error ...))
- ;; ...)
- ;;
- ;; which will do the right thing for all our
- ;; FILE-SYSCALL-ERRORs, without exposing this
- ;; implementation detail. (Recall that some
- ;; FILE-ERRORs don't strictly have to do with
- ;; the file system, e.g., supplying a wild
- ;; pathname to some functions.) But if the
- ;; prevailing opinion is otherwise, uncomment
- ;; the following.
- #| (export file-condition-name) |#
- (eval `(define-condition ,file-condition-name
- (,condition-class-name file-syscall-error)
- ())))
- condition-class-name))
- array)
- array))
-
-;; Note: do we have to declare SIMPLE-FILE-PERROR notinline in
-;; fd-stream.lisp?
-(sb-ext:without-package-locks
- (defun sb-impl::simple-file-perror (note-format pathname errno)
- (error (elt *file-errno-table* errno)
- :pathname pathname
- :errno errno
- :format-control "~@<~?: ~2I~_~A~:>"
- :format-arguments
- (list note-format (list pathname) (sb-int:strerror errno)))))
-
-;; Note: it might prove convenient to develop a parallel set of
-;; condition classes for STREAM-ERRORs, too.
(declaim (inline never-fails))
(defun never-fails (&rest args)
(declare (ignore args))
(let* ((external-format sb-alien::*default-c-string-external-format*)
(arg (sb-ext:string-to-octets
(filename template)
- :external-format external-format)))
+ :external-format external-format
+ :null-terminate t)))
(sb-sys:with-pinned-objects (arg)
;; accommodate for the call-by-reference
;; nature of mks/dtemp's template strings.
;; FIXME: We'd rather return pathnames, but other
;; SB-POSIX functions like this return strings...
(let ((pathname (sb-ext:octets-to-string
- arg :external-format external-format)))
+ arg :external-format external-format
+ :end (1- (length arg)))))
,(if values
'(values result pathname)
'pathname))))))
(define-call-internally fcntl-with-pointer-arg "fcntl" int minusp
(fd file-descriptor) (cmd int)
(arg alien-pointer-to-anything-or-nil))
+ (define-protocol-class flock alien-flock ()
+ ((type :initarg :type :accessor flock-type
+ :documentation "Type of lock; F_RDLCK, F_WRLCK, F_UNLCK.")
+ (whence :initarg :whence :accessor flock-whence
+ :documentation "Flag for starting offset.")
+ (start :initarg :start :accessor flock-start
+ :documentation "Relative offset in bytes.")
+ (len :initarg :len :accessor flock-len
+ :documentation "Size; if 0 then until EOF.")
+ ;; Note: PID isn't initable, and is read-only. But other stuff in
+ ;; SB-POSIX right now loses when a protocol-class slot is unbound,
+ ;; so we initialize it to 0.
+ (pid :initform 0 :reader flock-pid
+ :documentation
+ "Process ID of the process holding the lock; returned with F_GETLK."))
+ (:documentation "Class representing locks used in fcntl(2)."))
(define-entry-point "fcntl" (fd cmd &optional (arg nil argp))
(if argp
(etypecase arg
((alien int) (fcntl-with-int-arg fd cmd arg))
- ((or (alien (* t)) null) (fcntl-with-pointer-arg fd cmd arg)))
+ ((or (alien (* t)) null) (fcntl-with-pointer-arg fd cmd arg))
+ (flock (with-alien-flock a-flock ()
+ (flock-to-alien arg a-flock)
+ (let ((r (fcntl-with-pointer-arg fd cmd a-flock)))
+ (alien-to-flock a-flock arg)
+ r))))
(fcntl-without-arg fd cmd)))
;; uid, gid
(define-call "setup_mach_exceptions" void never-fails)
(define-call ("posix_fork" :c-name "fork") pid-t minusp)
(defun fork ()
- (let ((pid (posix-fork)))
- (when (= pid 0)
- (setup-mach-exceptions))
- pid))
+ (tagbody
+ (sb-thread::with-all-threads-lock
+ (when (cdr sb-thread::*all-threads*)
+ (go :error))
+ (let ((pid (posix-fork)))
+ (when (= pid 0)
+ (setup-mach-exceptions))
+ (return-from fork pid)))
+ :error
+ (error "Cannot fork with multiple threads running.")))
(export 'fork :sb-posix))
#-mach-exception-handler
(define-call "killpg" int minusp (pgrp int) (signal int))
(define-call "pause" int minusp)
(define-call "setpgid" int minusp (pid pid-t) (pgid pid-t))
- (define-call "setpgrp" int minusp))
+ (define-call "setpgrp" int minusp)
+ (define-call "setsid" pid-t minusp))
(defmacro with-growing-c-string ((buffer size) &body body)
(sb-int:with-unique-names (c-string-block)
(define-call "msync" int minusp
(addr sb-sys:system-area-pointer) (length unsigned) (flags int)))
+;;; mlockall, munlockall
+(define-call "mlockall" int minusp (flags int))
+(define-call "munlockall" int minusp)
+
#-win32
(define-call "getpagesize" int minusp)
#+win32
(:documentation "Instances of this class represent entries in
the system's user database."))
-(defmacro define-pw-call (name arg type)
- #-win32
- ;; FIXME: this isn't the documented way of doing this, surely?
- (let ((lisp-name (intern (string-upcase name) :sb-posix)))
- `(progn
- (export ',lisp-name :sb-posix)
- (declaim (inline ,lisp-name))
- (defun ,lisp-name (,arg)
- (let ((r (alien-funcall (extern-alien ,name ,type) ,arg)))
- (if (null-alien r)
- nil
- (alien-to-passwd r)))))))
-
-(define-pw-call "getpwnam" login-name (function (* alien-passwd) c-string))
-(define-pw-call "getpwuid" uid (function (* alien-passwd) uid-t))
-
;;; group database
#-win32
(define-protocol-class group alien-group ()
(passwd :initarg :passwd :accessor group-passwd)
(gid :initarg :gid :accessor group-gid)))
-(defmacro define-gr-call (name arg type)
+(defmacro define-obj-call (name arg type conv)
#-win32
;; FIXME: this isn't the documented way of doing this, surely?
(let ((lisp-name (intern (string-upcase name) :sb-posix)))
(let ((r (alien-funcall (extern-alien ,name ,type) ,arg)))
(if (null-alien r)
nil
- (alien-to-group r)))))))
+ (,conv r)))))))
-(define-gr-call "getgrnam" login-name (function (* alien-group) c-string))
-(define-gr-call "getgrgid" gid (function (* alien-group) gid-t))
+(define-obj-call "getpwnam" login-name (function (* alien-passwd) c-string) alien-to-passwd)
+(define-obj-call "getpwuid" uid (function (* alien-passwd) uid-t) alien-to-passwd)
+(define-obj-call "getgrnam" login-name (function (* alien-group) c-string) alien-to-group)
+(define-obj-call "getgrgid" gid (function (* alien-group) gid-t) alien-to-group)
#-win32
(syscall-error))
(setf termios (alien-to-termios a-termios termios))))
termios)
+ (define-call "tcdrain" int minusp (fd file-descriptor))
+ (define-call "tcflow" int minusp (fd file-descriptor) (action int))
+ (define-call "tcflush" int minusp (fd file-descriptor) (queue-selector int))
+ (define-call "tcgetsid" pid-t minusp (fd file-descriptor))
+ (define-call "tcsendbreak" int minusp (fd file-descriptor) (duration int))
(export 'cfsetispeed :sb-posix)
(declaim (inline cfsetispeed))
(defun cfsetispeed (speed &optional termios)
(declare (type (alien (* char)) r))
(unless (null-alien r)
(cast r c-string))))
-(define-call "putenv" int minusp (string c-string))
+#-win32
+(progn
+ (define-call "setenv" int minusp (name c-string) (value c-string) (overwrite int))
+ (define-call "unsetenv" int minusp (name c-string))
+ (export 'putenv :sb-posix)
+ (defun putenv (string)
+ (declare (string string))
+ ;; We don't want to call actual putenv: the string passed to putenv ends
+ ;; up in environ, and we any string we allocate GC might move.
+ ;;
+ ;; This makes our wrapper nonconformant if you squit hard enough, but
+ ;; users who care about that should really be calling putenv() directly in
+ ;; order to be able to manage memory sanely.
+ (let ((p (position #\= string))
+ (n (length string)))
+ (if p
+ (if (= p n)
+ (unsetenv (subseq string 0 p))
+ (setenv (subseq string 0 p) (subseq string (1+ p)) 1))
+ (error "Invalid argument to putenv: ~S" string)))))
+#+win32
+(progn
+ ;; Windows doesn't define a POSIX setenv, but happily their _putenv is sane.
+ (define-call* "putenv" int minusp (string c-string))
+ (defun setenv (name value overwrite)
+ (declare (string name value))
+ (if (and (zerop overwrite) (sb-posix:getenv name))
+ 0
+ (putenv (concatenate 'string name "=" value))))
+ (defun unsetenv (name)
+ (declare (string name))
+ (putenv (concatenate 'string name "="))))
;;; syslog
#-win32