(format s "System call error ~A (~A)"
errno (sb-int:strerror errno))))))
-(defun syscall-error ()
- (error 'sb-posix:syscall-error :errno (get-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)))
+
+(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))
+
+;; 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))
(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)))
+ (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)))
+ ,(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
(declaim (inline ,lisp-name))
(defun ,lisp-name (,arg)
(let ((r (alien-funcall (extern-alien ,name ,type) ,arg)))
- (if (null r)
- r
+ (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 ()
+ ((name :initarg :name :accessor group-name)
+ (passwd :initarg :passwd :accessor group-passwd)
+ (gid :initarg :gid :accessor group-gid)))
+
+(defmacro define-gr-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-group r)))))))
+
+(define-gr-call "getgrnam" login-name (function (* alien-group) c-string))
+(define-gr-call "getgrgid" gid (function (* alien-group) gid-t))
+
+
#-win32
(define-protocol-class timeval alien-timeval ()
((sec :initarg :tv-sec :accessor timeval-sec
projects / sbcl.git / blobdiff