(let ((to-protocol (intern (format nil "ALIEN-TO-~A" name)))
(to-alien (intern (format nil "~A-TO-ALIEN" name))))
`(progn
+ (export ',name :sb-posix)
(defclass ,name ,superclasses
,(loop for slotd in slots
collect (ldiff slotd (member :array-length slotd)))
(defun syscall-error ()
(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()."
+ lisp-name c-name))
+
+(defun unsupported-warning (lisp-name c-name)
+ (warn "~S is unsupported by SBCL on this platform due to lack of ~A()."
+ lisp-name c-name))
+
(declaim (inline never-fails))
(defun never-fails (&rest args)
(declare (ignore args))
(define-call "sync" void never-fails)
(define-call ("truncate" :options :largefile)
int minusp (pathname filename) (length off-t))
- ;; FIXME: Windows does have _mktemp, which has a slightlty different
- ;; interface
- (defun mkstemp (template)
- ;; we are emulating sb-alien's charset conversion for strings
- ;; here, to accommodate for the call-by-reference nature of
- ;; mkstemp's template strings.
- (let ((arg (sb-ext:string-to-octets
- (filename template)
- :external-format sb-alien::*default-c-string-external-format*)))
- (sb-sys:with-pinned-objects (arg)
- (let ((result (alien-funcall (extern-alien "mkstemp"
- (function int c-string))
- (sap-alien (sb-alien::vector-sap arg)
- (* char)))))
- (when (minusp result)
- (syscall-error))
- (values result
- (sb-ext:octets-to-string
- arg
- :external-format sb-alien::*default-c-string-external-format*))))))
+ #-win32
+ (macrolet ((def-mk*temp (lisp-name c-name result-type errorp dirp values)
+ (declare (ignore dirp))
+ (if (sb-sys:find-foreign-symbol-address c-name)
+ `(progn
+ (defun ,lisp-name (template)
+ (let* ((external-format sb-alien::*default-c-string-external-format*)
+ (arg (sb-ext:string-to-octets
+ (filename template)
+ :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.
+ (let ((result (alien-funcall (extern-alien ,c-name
+ (function ,result-type system-area-pointer))
+ (sb-alien::vector-sap arg))))
+ (when (,errorp result)
+ (syscall-error))
+ ;; 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
+ :end (1- (length arg)))))
+ ,(if values
+ '(values result pathname)
+ 'pathname))))))
+ (export ',lisp-name))
+ `(progn
+ (defun ,lisp-name (template)
+ (declare (ignore template))
+ (unsupported-error ',lisp-name ,c-name))
+ (define-compiler-macro ,lisp-name (&whole form template)
+ (declare (ignore template))
+ (unsupported-warning ',lisp-name ,c-name)
+ form)
+ (export ',lisp-name)))))
+ (def-mk*temp mktemp "mktemp" (* char) null-alien nil nil)
+ ;; FIXME: Windows does have _mktemp, which has a slightly different
+ ;; interface
+ (def-mk*temp mkstemp "mkstemp" int minusp nil t)
+ ;; FIXME: What about Windows?
+ (def-mk*temp mkdtemp "mkdtemp" (* char) null-alien t nil))
(define-call-internally ioctl-without-arg "ioctl" int minusp
(fd file-descriptor) (cmd int))
(define-call-internally ioctl-with-int-arg "ioctl" int minusp
(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)
(progn
(export 'readlink :sb-posix)
(defun readlink (pathspec)
+ "Returns the resolved target of a symbolic link as a string."
(flet ((%readlink (path buf length)
(alien-funcall
(extern-alien "readlink" (function int c-string (* t) int))
(progn
(export 'getcwd :sb-posix)
(defun getcwd ()
+ "Returns the process's current working directory as a string."
(flet ((%getcwd (buffer size)
(alien-funcall
(extern-alien #-win32 "getcwd"
(defun wait (&optional statusptr)
(declare (type (or null (simple-array (signed-byte 32) (1))) statusptr))
(let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32))))
- (pid (alien-funcall
- (extern-alien "wait" (function pid-t (* int)))
- (sb-sys:vector-sap ptr))))
+ (pid (sb-sys:with-pinned-objects (ptr)
+ (alien-funcall
+ (extern-alien "wait" (function pid-t (* int)))
+ (sb-sys:vector-sap ptr)))))
(if (minusp pid)
(syscall-error)
(values pid (aref ptr 0))))))
(type (sb-alien:alien int) options)
(type (or null (simple-array (signed-byte 32) (1))) statusptr))
(let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32))))
- (pid (alien-funcall
- (extern-alien "waitpid" (function pid-t
- pid-t (* int) int))
- pid (sb-sys:vector-sap ptr) options)))
+ (pid (sb-sys:with-pinned-objects (ptr)
+ (alien-funcall
+ (extern-alien "waitpid" (function pid-t
+ pid-t (* int) int))
+ pid (sb-sys:vector-sap ptr) options))))
(if (minusp pid)
(syscall-error)
(values pid (aref ptr 0)))))
(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
(export (defun getpagesize () 4096))
;;; passwd database
+;; The docstrings are copied from the descriptions in SUSv3,
+;; where present.
#-win32
(define-protocol-class passwd alien-passwd ()
- ((name :initarg :name :accessor passwd-name)
- (passwd :initarg :passwd :accessor passwd-passwd)
- (uid :initarg :uid :accessor passwd-uid)
- (gid :initarg :gid :accessor passwd-gid)
- (gecos :initarg :gecos :accessor passwd-gecos)
- (dir :initarg :dir :accessor passwd-dir)
- (shell :initarg :shell :accessor passwd-shell)))
-
-(defmacro define-pw-call (name arg type)
+ ((name :initarg :name :accessor passwd-name
+ :documentation "User's login name.")
+ ;; Note: SUSv3 doesn't require this member.
+ (passwd :initarg :passwd :accessor passwd-passwd
+ :documentation "The account's encrypted password.")
+ (uid :initarg :uid :accessor passwd-uid
+ :documentation "Numerical user ID.")
+ (gid :initarg :gid :accessor passwd-gid
+ :documentation "Numerical group ID.")
+ ;; Note: SUSv3 doesn't require this member.
+ (gecos :initarg :gecos :accessor passwd-gecos
+ :documentation "User's name or comment field.")
+ (dir :initarg :dir :accessor passwd-dir
+ :documentation "Initial working directory.")
+ (shell :initarg :shell :accessor passwd-shell
+ :documentation "Program to use as shell."))
+ (:documentation "Instances of this class represent entries in
+ the system's user database."))
+
+;;; group database
+#-win32
+(define-protocol-class group alien-group ()
+ ((name :initarg :name :accessor group-name)
+ (passwd :initarg :passwd :accessor group-passwd)
+ (gid :initarg :gid :accessor group-gid)))
+
+(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)))
(declaim (inline ,lisp-name))
(defun ,lisp-name (,arg)
(let ((r (alien-funcall (extern-alien ,name ,type) ,arg)))
- (if (null r)
- r
- (alien-to-passwd r)))))))
+ (if (null-alien r)
+ nil
+ (,conv r)))))))
+
+(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)
-(define-pw-call "getpwnam" login-name (function (* alien-passwd) c-string))
-(define-pw-call "getpwuid" uid (function (* alien-passwd) uid-t))
#-win32
(define-protocol-class timeval alien-timeval ()
- ((sec :initarg :tv-sec :accessor timeval-sec)
- (usec :initarg :tv-usec :accessor timeval-usec)))
+ ((sec :initarg :tv-sec :accessor timeval-sec
+ :documentation "Seconds.")
+ (usec :initarg :tv-usec :accessor timeval-usec
+ :documentation "Microseconds."))
+ (:documentation "Instances of this class represent time values."))
(define-protocol-class stat alien-stat ()
- ((mode :initarg :mode :accessor stat-mode)
- (ino :initarg :ino :accessor stat-ino)
- (dev :initarg :dev :accessor stat-dev)
- (nlink :initarg :nlink :accessor stat-nlink)
- (uid :initarg :uid :accessor stat-uid)
- (gid :initarg :gid :accessor stat-gid)
- (size :initarg :size :accessor stat-size)
- (atime :initarg :atime :accessor stat-atime)
- (mtime :initarg :mtime :accessor stat-mtime)
- (ctime :initarg :ctime :accessor stat-ctime)))
+ ((mode :initarg :mode :reader stat-mode
+ :documentation "Mode of file.")
+ (ino :initarg :ino :reader stat-ino
+ :documentation "File serial number.")
+ (dev :initarg :dev :reader stat-dev
+ :documentation "Device ID of device containing file.")
+ (nlink :initarg :nlink :reader stat-nlink
+ :documentation "Number of hard links to the file.")
+ (uid :initarg :uid :reader stat-uid
+ :documentation "User ID of file.")
+ (gid :initarg :gid :reader stat-gid
+ :documentation "Group ID of file.")
+ (size :initarg :size :reader stat-size
+ :documentation "For regular files, the file size in
+ bytes. For symbolic links, the length
+ in bytes of the filename contained in
+ the symbolic link.")
+ (atime :initarg :atime :reader stat-atime
+ :documentation "Time of last access.")
+ (mtime :initarg :mtime :reader stat-mtime
+ :documentation "Time of last data modification.")
+ (ctime :initarg :ctime :reader stat-ctime
+ :documentation "Time of last status change"))
+ (:documentation "Instances of this class represent Posix file
+ metadata."))
(defmacro define-stat-call (name arg designator-fun type)
;; FIXME: this isn't the documented way of doing this, surely?
- (let ((lisp-name (lisp-for-c-symbol name)))
+ (let ((lisp-name (lisp-for-c-symbol name))
+ (real-name #+inode64 (format nil "~A$INODE64" name)
+ #-inode64 name))
`(progn
(export ',lisp-name :sb-posix)
(declaim (inline ,lisp-name))
(defun ,lisp-name (,arg &optional stat)
- (declare (type (or null (sb-alien:alien (* alien-stat))) stat))
+ (declare (type (or null stat) stat))
(with-alien-stat a-stat ()
(let ((r (alien-funcall
- (extern-alien ,(real-c-name (list name :options :largefile)) ,type)
+ (extern-alien ,(real-c-name (list real-name :options :largefile)) ,type)
(,designator-fun ,arg)
a-stat)))
(when (minusp r)
(declare (type (or null (simple-array (signed-byte 32) (2))) filedes2))
(unless filedes2
(setq filedes2 (make-array 2 :element-type '(signed-byte 32))))
- (let ((r (alien-funcall
- ;; FIXME: (* INT)? (ARRAY INT 2) would be better
- (extern-alien "pipe" (function int (* int)))
- (sb-sys:vector-sap filedes2))))
+ (let ((r (sb-sys:with-pinned-objects (filedes2)
+ (alien-funcall
+ ;; FIXME: (* INT)? (ARRAY INT 2) would be better
+ (extern-alien "pipe" (function int (* int)))
+ (sb-sys:vector-sap filedes2)))))
(when (minusp r)
(syscall-error)))
(values (aref filedes2 0) (aref filedes2 1))))
#-win32
(define-protocol-class termios alien-termios ()
- ((iflag :initarg :iflag :accessor sb-posix:termios-iflag)
- (oflag :initarg :oflag :accessor sb-posix:termios-oflag)
- (cflag :initarg :cflag :accessor sb-posix:termios-cflag)
- (lflag :initarg :lflag :accessor sb-posix:termios-lflag)
- (cc :initarg :cc :accessor sb-posix:termios-cc :array-length nccs)))
+ ((iflag :initarg :iflag :accessor sb-posix:termios-iflag
+ :documentation "Input modes.")
+ (oflag :initarg :oflag :accessor sb-posix:termios-oflag
+ :documentation "Output modes.")
+ (cflag :initarg :cflag :accessor sb-posix:termios-cflag
+ :documentation "Control modes.")
+ (lflag :initarg :lflag :accessor sb-posix:termios-lflag
+ :documentation "Local modes.")
+ (cc :initarg :cc :accessor sb-posix:termios-cc :array-length nccs
+ :documentation "Control characters"))
+ (:documentation "Instances of this class represent I/O
+ characteristics of the terminal."))
#-win32
(progn
(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)
;;; environment
-(export 'getenv :sb-posix)
+(eval-when (:compile-toplevel :load-toplevel)
+ ;; Do this at compile-time as Win32 code below refers to it as
+ ;; sb-posix:getenv.
+ (export 'getenv :sb-posix))
(defun getenv (name)
(let ((r (alien-funcall
(extern-alien "getenv" (function (* char) c-string))
(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))
+ (export 'setenv :sb-posix)
+ (defun setenv (name value overwrite)
+ (declare (string name value))
+ (if (and (zerop overwrite) (sb-posix:getenv name))
+ 0
+ (putenv (concatenate 'string name "=" value))))
+ (export 'unsetenv :sb-posix)
+ (defun unsetenv (name)
+ (declare (string name))
+ (putenv (concatenate 'string name "="))))
;;; syslog
#-win32