From 1673e3d1a52eb270e08912f4105d2f6d986053ab Mon Sep 17 00:00:00 2001 From: Stelian Ionescu Date: Sat, 23 Aug 2008 12:09:13 +0200 Subject: [PATCH] Port ZETA-STREAMS to IOLIB.SYSCALLS. Signed-off-by: Stelian Ionescu --- io.streams/zeta/conditions.lisp | 14 +-- io.streams/zeta/device.lisp | 121 ++------------------------ io.streams/zeta/ffi-functions-unix.lisp | 117 ++++++++++++++++++++++++- io.streams/zeta/{file.lisp => file-unix.lisp} | 85 +++++++++++++----- io.zeta-streams.asd | 15 ++-- 5 files changed, 199 insertions(+), 153 deletions(-) rename io.streams/zeta/{file.lisp => file-unix.lisp} (73%) diff --git a/io.streams/zeta/conditions.lisp b/io.streams/zeta/conditions.lisp index f58db52..8ca111a 100644 --- a/io.streams/zeta/conditions.lisp +++ b/io.streams/zeta/conditions.lisp @@ -6,17 +6,17 @@ (in-package :io.zeta-streams) (define-condition posix-file-error (file-error) - ((action :initarg :action :reader posix-file-error-action) - (code :initarg :code :reader posix-file-error-code) - (identifier :initarg :identifier :reader posix-file-error-identifier)) + ((action :initarg :action :reader action-of) + (code :initarg :code :reader code-of) + (identifier :initarg :identifier :reader identifier-of)) (:report (lambda (condition stream) (format stream "Error while ~A ~S: ~A" - (posix-file-error-action condition) + (action-of condition) (file-error-pathname condition) - (nix:strerror (posix-file-error-code condition)))))) + (%sys-strerror (code-of condition)))))) (defun posix-file-error (posix-error filename action) (error 'posix-file-error - :code (osicat-sys:system-error-code posix-error) - :identifier (osicat-sys:system-error-identifier posix-error) + :code (code-of posix-error) + :identifier (identifier-of posix-error) :pathname filename :action action)) diff --git a/io.streams/zeta/device.lisp b/io.streams/zeta/device.lisp index 606ca7e..fdf858b 100644 --- a/io.streams/zeta/device.lisp +++ b/io.streams/zeta/device.lisp @@ -42,8 +42,16 @@ (defgeneric device-read (device vector start end &optional timeout)) +(defgeneric read-octets/non-blocking (device vector start end)) + +(defgeneric read-octets/timeout (device vector start end timeout)) + (defgeneric device-write (device vector start end &optional timeout)) +(defgeneric write-octets/non-blocking (device vector start end)) + +(defgeneric write-octets/timeout (device vector start end timeout)) + (defgeneric device-position (device)) (defgeneric (setf device-position) (position device &rest args)) @@ -81,47 +89,6 @@ ;;;----------------------------------------------------------------------------- -;;; Get and Set O_NONBLOCK -;;;----------------------------------------------------------------------------- - -(defun %get-fd-nonblock-mode (fd) - (declare (special *device*)) - (handler-case - (let ((current-flags (nix:fcntl fd nix:f-getfl))) - (logtest nix:o-nonblock current-flags)) - (nix:posix-error (err) - (posix-file-error err *device* "getting O_NONBLOCK from")))) - -(defun %set-fd-nonblock-mode (fd mode) - (declare (special *device*)) - (let* ((current-flags - (handler-case - (nix:fcntl fd nix:f-getfl) - (nix:posix-error (err) - (posix-file-error err *device* "getting O_NONBLOCK from")))) - (new-flags (if mode - (logior current-flags nix:o-nonblock) - (logandc2 current-flags nix:o-nonblock)))) - (when (/= new-flags current-flags) - (handler-case - (nix:fcntl fd nix:f-setfl new-flags) - (nix:posix-error (err) - (posix-file-error err *device* "setting O_NONBLOCK on")))) - (values mode))) - - -;;;----------------------------------------------------------------------------- -;;; I/O WAIT -;;;----------------------------------------------------------------------------- - -(defmethod device-poll-input ((device device) &optional timeout) - (iomux:wait-until-fd-ready (input-handle-of device) :input timeout)) - -(defmethod device-poll-output ((device device) &optional timeout) - (iomux:wait-until-fd-ready (output-handle-of device) :output timeout)) - - -;;;----------------------------------------------------------------------------- ;;; Default DEVICE-READ ;;;----------------------------------------------------------------------------- @@ -133,41 +100,6 @@ (if (and timeout (zerop timeout)) (read-octets/non-blocking device vector start end) (read-octets/timeout device vector start end timeout))) - -(defun read-octets/non-blocking (device vector start end) - (declare (type device device) - (type ub8-simple-vector vector) - (type iobuf-index start end)) - (with-pointer-to-vector-data (buf vector) - (handler-case - (nix:repeat-upon-eintr - (nix:read (input-handle-of device) (inc-pointer buf start) (- end start))) - (nix:ewouldblock () 0) - (nix:posix-error (err) - (posix-file-error err device "reading data from")) - (:no-error (nbytes) - (if (zerop nbytes) :eof nbytes))))) - -(defun read-octets/timeout (device vector start end timeout) - (declare (type device device) - (type ub8-simple-vector vector) - (type iobuf-index start end) - (type device-timeout timeout)) - (with-pointer-to-vector-data (buf vector) - (nix:repeat-decreasing-timeout (remaining timeout :rloop) - (flet ((check-timeout () - (if (plusp remaining) - (device-poll-input device remaining) - (return-from :rloop 0)))) - (handler-case - (nix:read (input-handle-of device) (inc-pointer buf start) (- end start)) - (nix:eintr () (check-timeout)) - (nix:ewouldblock () (check-timeout)) - (nix:posix-error (err) - (posix-file-error err device "reading data from")) - (:no-error (nbytes) - (return-from :rloop - (if (zerop nbytes) :eof nbytes)))))))) ;;;----------------------------------------------------------------------------- @@ -182,40 +114,3 @@ (if (and timeout (zerop timeout)) (write-octets/non-blocking device vector start end) (write-octets/timeout device vector start end timeout))) - -(defun write-octets/non-blocking (device vector start end) - (declare (type device device) - (type ub8-simple-vector vector) - (type iobuf-index start end)) - (with-pointer-to-vector-data (buf vector) - (handler-case - (osicat-posix:repeat-upon-eintr - (nix:write (output-handle-of device) (inc-pointer buf start) (- end start))) - (nix:ewouldblock () 0) - (nix:epipe () :eof) - (nix:posix-error (err) - (posix-file-error err device "writing data to")) - (:no-error (nbytes) - (if (zerop nbytes) :eof nbytes))))) - -(defun write-octets/timeout (device vector start end timeout) - (declare (type device device) - (type ub8-simple-vector vector) - (type iobuf-index start end) - (type device-timeout timeout)) - (with-pointer-to-vector-data (buf vector) - (nix:repeat-decreasing-timeout (remaining timeout :rloop) - (flet ((check-timeout () - (if (plusp remaining) - (device-poll-output device remaining) - (return-from :rloop 0)))) - (handler-case - (nix:write (output-handle-of device) (inc-pointer buf start) (- end start)) - (nix:eintr () (check-timeout)) - (nix:ewouldblock () (check-timeout)) - (nix:epipe () (return-from :rloop :eof)) - (nix:posix-error (err) - (posix-file-error err device "writing data to")) - (:no-error (nbytes) - (return-from :rloop - (if (zerop nbytes) :eof nbytes)))))))) diff --git a/io.streams/zeta/ffi-functions-unix.lisp b/io.streams/zeta/ffi-functions-unix.lisp index 64c6679..cc36fd7 100644 --- a/io.streams/zeta/ffi-functions-unix.lisp +++ b/io.streams/zeta/ffi-functions-unix.lisp @@ -33,11 +33,11 @@ -1)) (defun %poll (fds timeout) - (isys:repeat-upon-condition-decreasing-timeout + (repeat-upon-condition-decreasing-timeout ((eintr) remaining-time timeout) (%sys-poll fds 1 (timeout->milisec remaining-time)))) -(defun poll (fd event-type timeout) +(defun poll-fd (fd event-type timeout) "Poll file descriptor `FD' for I/O readiness. `EVENT-TYPE' must be either :INPUT, :OUTPUT or :IO. `TIMEOUT' must be either a non-negative integer measured in seconds, or `NIL' meaning no timeout at all. If a timeout occurs `POLL-TIMEOUT' is signaled. @@ -60,5 +60,114 @@ Returns two boolean values indicating readability and writeability of `FD'." (error 'poll-timeout :os-handle fd :event-type event-type))) (posix-error (err) (poll-error err))))))) -(defun poll-file (file-descriptor event-type &optional timeout) - (poll file-descriptor event-type timeout)) +(defun poll-file (file-descriptor event-type timeout) + (poll-fd file-descriptor event-type timeout)) + + +;;;----------------------------------------------------------------------------- +;;; Set FD nonblocking +;;;----------------------------------------------------------------------------- + +(defun %set-fd-nonblock (fd) + (declare (special *device*)) + (handler-case + (with-foreign-object (arg :int) + (setf (mem-aref arg :int) 1) + (%sys-ioctl/3 fd fionbio arg)) + (posix-error (err) + (posix-file-error err *device* "issuing FIONBIO IOCTL on"))) + (values)) + + +;;;----------------------------------------------------------------------------- +;;; Get number of bytes availabe on FD +;;;----------------------------------------------------------------------------- + +(defun %get-fd-nbytes (fd) + (declare (special *device*)) + (handler-case + (with-foreign-object (arg :int) + (%sys-ioctl/3 fd fionread arg) + (mem-aref arg :int)) + (posix-error (err) + (posix-file-error err *device* "issuing FIONREAD IOCTL on")))) + + +;;;----------------------------------------------------------------------------- +;;; File Descriptor reading +;;;----------------------------------------------------------------------------- + +(defun %read-octets/non-blocking (fd vector start end) + (declare (type ub8-simple-vector vector) + (type iobuf-index start end) + (special *device*)) + (with-pointer-to-vector-data (buf vector) + (handler-case + (%sys-read fd (inc-pointer buf start) (- end start)) + (ewouldblock () 0) + (posix-error (err) + (posix-file-error err *device* "reading data from")) + (:no-error (nbytes) + (if (zerop nbytes) :eof nbytes))))) + +(defun %read-octets/timeout (fd vector start end timeout) + (declare (type ub8-simple-vector vector) + (type iobuf-index start end) + (type device-timeout timeout) + (special *device*)) + (with-pointer-to-vector-data (buf vector) + (repeat-decreasing-timeout (remaining timeout :rloop) + (flet ((check-timeout () + (if (plusp remaining) + (poll fd :input remaining) + (return-from :rloop 0)))) + (handler-case + (%sys-read fd (inc-pointer buf start) (- end start)) + (eintr () (check-timeout)) + (ewouldblock () (check-timeout)) + (posix-error (err) + (posix-file-error err *device* "reading data from")) + (:no-error (nbytes) + (return-from :rloop + (if (zerop nbytes) :eof nbytes)))))))) + + +;;;----------------------------------------------------------------------------- +;;; File Descriptor writing +;;;----------------------------------------------------------------------------- + +(defun %write-octets/non-blocking (fd vector start end) + (declare (type ub8-simple-vector vector) + (type iobuf-index start end) + (special *device*)) + (with-pointer-to-vector-data (buf vector) + (handler-case + (%sys-write fd (inc-pointer buf start) (- end start)) + (ewouldblock () 0) + (epipe () :eof) + (posix-error (err) + (posix-file-error err *device* "writing data to")) + (:no-error (nbytes) + (if (zerop nbytes) :eof nbytes))))) + +(defun %write-octets/timeout (fd vector start end timeout) + (declare (type ub8-simple-vector vector) + (type iobuf-index start end) + (type device-timeout timeout) + (special *device*)) + (with-pointer-to-vector-data (buf vector) + (repeat-decreasing-timeout (remaining timeout :rloop) + (flet ((check-timeout () + (if (plusp remaining) + (poll-fd fd :output remaining) + (return-from :rloop 0)))) + (handler-case + (%sys-write fd (inc-pointer buf start) (- end start)) + (eintr () (check-timeout)) + (ewouldblock () (check-timeout)) + (epipe () (return-from :rloop :eof)) + (posix-error (err) + (posix-file-error err *device* "writing data to")) + (:no-error (nbytes) + (return-from :rloop + (if (zerop nbytes) :eof nbytes)))))))) diff --git a/io.streams/zeta/file.lisp b/io.streams/zeta/file-unix.lisp similarity index 73% rename from io.streams/zeta/file.lisp rename to io.streams/zeta/file-unix.lisp index 7fd48ae..1528ae0 100644 --- a/io.streams/zeta/file.lisp +++ b/io.streams/zeta/file-unix.lisp @@ -75,20 +75,20 @@ (posix-file-error c filename "opening")) (try-unlink () (handler-case - (nix:unlink filename) - (nix:posix-error (c) (handle-error c)))) + (%sys-unlink filename) + (posix-error (c) (handle-error c)))) (try-open (&optional (retry-on-unlink t)) (handler-case - (nix:open filename flags mode) - (nix:eexist (c) + (%sys-open filename flags mode) + (eexist (c) (cond ((and retry-on-unlink (eql :unlink if-exists)) (try-unlink) (try-open nil)) (t (handle-error c)))) - (nix:posix-error (c) + (posix-error (c) (handle-error c)) (:no-error (fd) fd)))) (let ((fd (try-open))) - (%set-fd-nonblock-mode fd t) + (%set-fd-nonblock fd) (setf (input-handle-of device) fd (output-handle-of device) fd))) (values device)) @@ -99,12 +99,12 @@ (when (eql :default if-exists) (setf if-exists :overwrite)) (ecase direction (:input - (add-flags nix:o-rdonly) + (add-flags o-rdonly) (check-type if-exists (member :overwrite :error-if-symlink)) (check-type if-does-not-exist (member :default :error)) (when (eql :default if-does-not-exist) (setf if-does-not-exist :error))) ((:output :io) - (add-flags (if (eql :io direction) nix:o-rdwr nix:o-wronly)) + (add-flags (if (eql :io direction) o-rdwr o-wronly)) (check-type if-exists file-if-exists) (check-type if-does-not-exist file-if-does-not-exist) (when (eql :default if-does-not-exist) (setf if-does-not-exist :create)))) @@ -116,16 +116,16 @@ `(setf flags (logior flags ,@%flags)))) (case if-exists (:error - (unless (eql :input direction) (add-flags nix:o-excl))) + (unless (eql :input direction) (add-flags o-excl))) (:error-if-symlink - (add-flags nix:o-nofollow))) + (add-flags o-nofollow))) (case if-does-not-exist - (:create (add-flags nix:o-creat))) + (:create (add-flags o-creat))) (cond (truncate - (unless (eql :input direction) (add-flags nix:o-trunc))) + (unless (eql :input direction) (add-flags o-trunc))) (append - (when (eql :output direction) (add-flags nix:o-append))) + (when (eql :output direction) (add-flags o-append))) (extra-flags (add-flags extra-flags)))) (values flags if-exists if-does-not-exist)) @@ -137,7 +137,7 @@ (defmethod device-close ((device file-device) &optional abort) (declare (ignore abort)) - (ignore-errors (nix:close (input-handle-of device))) + (ignore-errors (%sys-close (input-handle-of device))) (setf (input-handle-of device) nil (output-handle-of device) nil) (values device)) @@ -149,18 +149,18 @@ (defmethod device-position ((device file-device)) (handler-case - (nix:lseek (input-handle-of device) 0 nix:seek-cur) - (nix:posix-error (err) + (%sys-lseek (input-handle-of device) 0 seek-cur) + (posix-error (err) (posix-file-error err device "seeking on")))) (defmethod (setf device-position) (position (device file-device) &key (from :start)) (handler-case - (nix:lseek (input-handle-of device) position - (ecase from - (:start nix:seek-set) - (:current nix:seek-cur) - (:end nix:seek-end))) - (nix:posix-error (err) + (%sys-lseek (input-handle-of device) position + (ecase from + (:start seek-set) + (:current seek-cur) + (:end seek-end))) + (posix-error (err) (posix-file-error err device "seeking on")))) @@ -170,12 +170,49 @@ (defmethod device-length ((device file-device)) (handler-case - (nix:stat-size (nix:fstat (input-handle-of device))) - (nix:posix-error (err) + (%sys-fstat (input-handle-of device)) + (posix-error (err) (posix-file-error err device "getting status of")))) ;;;----------------------------------------------------------------------------- +;;; I/O WAIT +;;;----------------------------------------------------------------------------- + +(defmethod device-poll-input ((device file-device) &optional timeout) + (poll-fd (input-handle-of device) :input timeout)) + +(defmethod device-poll-output ((device file-device) &optional timeout) + (poll-fd (output-handle-of device) :output timeout)) + + +;;;----------------------------------------------------------------------------- +;;; File DEVICE-READ +;;;----------------------------------------------------------------------------- + +(defmethod read-octets/non-blocking ((device file-device) vector start end) + (with-device (device) + (%read-octets/non-blocking (input-handle-of device) vector start end))) + +(defmethod read-octets/timeout ((device file-device) vector start end timeout) + (with-device (device) + (%read-octets/timeout (input-handle-of device) vector start end timeout))) + + +;;;----------------------------------------------------------------------------- +;;; File DEVICE-WRITE +;;;----------------------------------------------------------------------------- + +(defmethod write-octets/non-blocking ((device file-device) vector start end) + (with-device (device) + (%write-octets/non-blocking (output-handle-of device) vector start end))) + +(defmethod write-octets/timeout ((device file-device) vector start end timeout) + (with-device (device) + (%write-octets/timeout (output-handle-of device) vector start end timeout))) + + +;;;----------------------------------------------------------------------------- ;;; OPEN-FILE ;;;----------------------------------------------------------------------------- diff --git a/io.zeta-streams.asd b/io.zeta-streams.asd index 8a1584c..0b94c4c 100644 --- a/io.zeta-streams.asd +++ b/io.zeta-streams.asd @@ -3,22 +3,27 @@ ;;; --- ASDF system definition. ;;; -(in-package :common-lisp-user) - (asdf:defsystem :io.zeta-streams :description "Zeta streams." :maintainer "Stelian Ionescu " :licence "MIT" - :depends-on (:iolib.base :cffi :osicat :io.multiplex :bordeaux-threads) + :depends-on (:iolib.base :iolib.syscalls :cffi :bordeaux-threads) :pathname (merge-pathnames #p"io.streams/zeta/" *load-truename*) :components ((:file "pkgdcl") (:file "types" :depends-on ("pkgdcl")) (:file "conditions" :depends-on ("pkgdcl")) - (:file "device" :depends-on ("pkgdcl" "types" "conditions")) + + ;; Platform-specific files + (:file "ffi-functions" + :pathname #+unix "ffi-functions-unix" + :depends-on ("pkgdcl" "conditions")) ;; Devices - (:file "file" :depends-on ("pkgdcl" "types" "conditions" "device")) + (:file "device" :depends-on ("pkgdcl" "types" "conditions")) + (:file "file" + :pathname #+unix "file-unix" + :depends-on ("pkgdcl" "types" "conditions" "device" "ffi-functions")) ;; Buffers (:file "iobuf" :depends-on ("pkgdcl" "types" "conditions" "device")) -- 2.11.4.GIT