;;; **********************************************************************
;;; This code was written by Paul Foley and has been placed in the public
;;; domain.
-;;;
+;;;
;;; Sbcl port by Rudi Schlatte.
;;;
;;; Various functions needed by simple-streams
(declaim (inline buffer-sap bref (setf bref) buffer-copy
- allocate-buffer free-buffer))
+ allocate-buffer free-buffer))
(defun buffer-sap (thing &optional offset)
(declare (type simple-stream-buffer thing) (type (or fixnum null) offset)
- (optimize (speed 3) (space 2) (debug 0) (safety 0)
- ;; Suppress the note about having to box up the return:
- (sb-ext:inhibit-warnings 3)))
+ (optimize (speed 3) (space 2) (debug 0) (safety 0)
+ ;; Suppress the note about having to box up the return:
+ (sb-ext:inhibit-warnings 3)))
(let ((sap (if (vectorp thing) (sb-sys:vector-sap thing) thing)))
(if offset (sb-sys:sap+ sap offset) sap)))
(defun bref (buffer index)
(declare (type simple-stream-buffer buffer)
- (type (integer 0 #.most-positive-fixnum) index))
+ (type (integer 0 #.most-positive-fixnum) index))
(if (vectorp buffer)
(sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index)
(sb-sys:sap-ref-8 buffer index)))
(defun (setf bref) (octet buffer index)
(declare (type (unsigned-byte 8) octet)
- (type simple-stream-buffer buffer)
- (type (integer 0 #.most-positive-fixnum) index))
+ (type simple-stream-buffer buffer)
+ (type (integer 0 #.most-positive-fixnum) index))
(if (vectorp buffer)
(setf (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index) octet)
(setf (sb-sys:sap-ref-8 buffer index) octet)))
(defun buffer-copy (src soff dst doff length)
(declare (type simple-stream-buffer src dst)
- (type fixnum soff doff length))
+ (type fixnum soff doff length))
(sb-sys:without-gcing ;; is this necessary??
(sb-kernel:system-area-ub8-copy (buffer-sap src) soff
(buffer-sap dst) doff
(defun make-control-table (&rest inits)
(let ((table (make-array 32 :initial-element nil)))
(do* ((char (pop inits) (pop inits))
- (func (pop inits) (pop inits)))
- ((null char))
+ (func (pop inits) (pop inits)))
+ ((null char))
(when (< (char-code char) 32)
- (setf (aref table (char-code char)) func)))
+ (setf (aref table (char-code char)) func)))
table))
(defun std-newline-out-handler (stream character)
(with-stream-class (simple-stream stream)
(let ((col (sm charpos stream)))
(when col
- (setf (sm charpos stream) (1- (* 8 (1+ (floor col 8)))))))
+ (setf (sm charpos stream) (1- (* 8 (1+ (floor col 8)))))))
nil))
(defun std-dc-newline-in-handler (stream character)
(defvar *std-control-out-table*
(make-control-table #\Newline #'std-newline-out-handler
- #\Tab #'std-tab-out-handler))
+ #\Tab #'std-tab-out-handler))
(defvar *default-external-format* :iso8859-1)
(defvar *external-format-aliases* (make-hash-table))
(defstruct (external-format
- (:conc-name ef-)
- (:print-function %print-external-format)
+ (:conc-name ef-)
+ (:print-function %print-external-format)
(:constructor make-external-format (name octets-to-char
char-to-octets)))
(name (sb-int:missing-arg) :type keyword :read-only t)
(defmacro define-external-format (name octets-to-char char-to-octets)
`(macrolet ((octets-to-char ((state input unput) &body body)
- `(lambda (,state ,input ,unput)
- (declare (type (function () (unsigned-byte 8)) ,input)
- (type (function (sb-int:index) t) ,unput)
- (ignorable ,state ,input ,unput)
- (values character sb-int:index t))
- ,@body))
- (char-to-octets ((char state output) &body body)
- `(lambda (,char ,state ,output)
- (declare (type character ,char)
- (type (function ((unsigned-byte 8)) t) ,output)
- (ignorable state ,output)
- (values t))
- ,@body)))
+ `(lambda (,state ,input ,unput)
+ (declare (type (function () (unsigned-byte 8)) ,input)
+ (type (function (sb-int:index) t) ,unput)
+ (ignorable ,state ,input ,unput)
+ (values character sb-int:index t))
+ ,@body))
+ (char-to-octets ((char state output) &body body)
+ `(lambda (,char ,state ,output)
+ (declare (type character ,char)
+ (type (function ((unsigned-byte 8)) t) ,output)
+ (ignorable state ,output)
+ (values t))
+ ,@body)))
(setf (gethash ,name *external-formats*)
- (make-external-format ,name ,octets-to-char ,char-to-octets))))
+ (make-external-format ,name ,octets-to-char ,char-to-octets))))
;;; TODO: make this work
(defun load-external-format-aliases ()
(let ((*package* (find-package "KEYWORD")))
(with-open-file (stm "ef:aliases" :if-does-not-exist nil)
(when stm
- (do ((alias (read stm nil stm) (read stm nil stm))
- (value (read stm nil stm) (read stm nil stm)))
- ((or (eq alias stm) (eq value stm))
- (unless (eq alias stm)
- (warn "External-format aliases file ends early.")))
- (if (and (keywordp alias) (keywordp value))
- (setf (gethash alias *external-format-aliases*) value)
- (warn "Bad entry in external-format aliases file: ~S => ~S."
- alias value)))))))
+ (do ((alias (read stm nil stm) (read stm nil stm))
+ (value (read stm nil stm) (read stm nil stm)))
+ ((or (eq alias stm) (eq value stm))
+ (unless (eq alias stm)
+ (warn "External-format aliases file ends early.")))
+ (if (and (keywordp alias) (keywordp value))
+ (setf (gethash alias *external-format-aliases*) value)
+ (warn "Bad entry in external-format aliases file: ~S => ~S."
+ alias value)))))))
(defun find-external-format (name &optional (error-p t))
(when (external-format-p name)
(load-external-format-aliases))
(do ((tmp (gethash name *external-format-aliases*)
- (gethash tmp *external-format-aliases*))
+ (gethash tmp *external-format-aliases*))
(cnt 0 (1+ cnt)))
((or (null tmp) (= cnt 50))
(unless (null tmp)
- (error "External-format aliasing depth exceeded.")))
+ (error "External-format aliasing depth exceeded.")))
(setq name tmp))
(or (gethash name *external-formats*)
(and (let ((*package* (find-package "SB-SIMPLE-STREAMS")))
- (load (format nil "ef:~(~A~)" name) :if-does-not-exist nil))
- (gethash name *external-formats*))
+ (load (format nil "ef:~(~A~)" name) :if-does-not-exist nil))
+ (gethash name *external-formats*))
(if error-p (error "External format ~S not found." name) nil)))
(define-condition void-external-format (error)
(funcall output code)
#+(or)
(if (< code 256)
- (funcall output code)
- (funcall output (char-code #\?))))
+ (funcall output code)
+ (funcall output (char-code #\?))))
state))
(defmacro octets-to-char (external-format state count input unput)
(let ((tmp1 (gensym)) (tmp2 (gensym)) (tmp3 (gensym)))
`(multiple-value-bind (,tmp1 ,tmp2 ,tmp3)
- (funcall (ef-octets-to-char ,external-format) ,state ,input ,unput)
+ (funcall (ef-octets-to-char ,external-format) ,state ,input ,unput)
(setf ,state ,tmp3 ,count ,tmp2)
,tmp1)))
(defmacro char-to-octets (external-format char state output)
`(progn
(setf ,state (funcall (ef-char-to-octets ,external-format)
- ,char ,state ,output))
+ ,char ,state ,output))
nil))
(defun string-to-octets (string &key (start 0) end (external-format :default))
(declare (type string string)
- (type sb-int:index start)
- (type (or null sb-int:index) end))
+ (type sb-int:index start)
+ (type (or null sb-int:index) end))
(let ((ef (find-external-format external-format))
- (buffer (make-array (length string) :element-type '(unsigned-byte 8)))
- (ptr 0)
- (state nil))
+ (buffer (make-array (length string) :element-type '(unsigned-byte 8)))
+ (ptr 0)
+ (state nil))
(flet ((out (b)
- (setf (aref buffer ptr) b)
- (when (= (incf ptr) (length buffer))
- (setq buffer (adjust-array buffer (* 2 ptr))))))
+ (setf (aref buffer ptr) b)
+ (when (= (incf ptr) (length buffer))
+ (setq buffer (adjust-array buffer (* 2 ptr))))))
(dotimes (i (- (or end (length string)) start))
- (declare (type sb-int:index i))
- (char-to-octets ef (char string (+ start i)) state #'out))
+ (declare (type sb-int:index i))
+ (char-to-octets ef (char string (+ start i)) state #'out))
(sb-kernel:shrink-vector buffer ptr))))
(defun octets-to-string (octets &key (start 0) end (external-format :default))
(declare (type vector octets)
- (type sb-int:index start)
- (type (or null sb-int:index) end))
+ (type sb-int:index start)
+ (type (or null sb-int:index) end))
(let ((ef (find-external-format external-format))
- (end (1- (or end (length octets))))
- (string (make-string (length octets)))
- (ptr (1- start))
- (pos -1)
- (count 0)
- (state nil))
+ (end (1- (or end (length octets))))
+ (string (make-string (length octets)))
+ (ptr (1- start))
+ (pos -1)
+ (count 0)
+ (state nil))
(flet ((input ()
- (aref octets (incf ptr)))
- (unput (n)
- (decf ptr n)))
+ (aref octets (incf ptr)))
+ (unput (n)
+ (decf ptr n)))
(loop until (>= ptr end)
- do (setf (schar string (incf pos))
- (octets-to-char ef state count #'input #'unput))))
+ do (setf (schar string (incf pos))
+ (octets-to-char ef state count #'input #'unput))))
(sb-kernel:shrink-vector string (1+ pos))))
(defun vector-elt-width (vector)
#+big-endian (declare (ignore vector))
(case endian-swap
(:network-order #+big-endian 0
- #+little-endian (1- (vector-elt-width vector)))
+ #+little-endian (1- (vector-elt-width vector)))
(:byte-8 0)
(:byte-16 1)
(:byte-32 3)
#+(or)
(defun %read-vector (vector stream start end endian-swap blocking)
(declare (type (kernel:simple-unboxed-array (*)) vector)
- (type stream stream))
+ (type stream stream))
;; move code from read-vector
)
(defun read-octets (stream buffer start end blocking)
(declare (type simple-stream stream)
- (type (or null simple-stream-buffer) buffer)
- (type fixnum start)
- (type (or null fixnum) end)
+ (type (or null simple-stream-buffer) buffer)
+ (type fixnum start)
+ (type (or null fixnum) end)
(type blocking blocking)
- (optimize (speed 3) (space 2) (safety 0) (debug 0)))
+ (optimize (speed 3) (space 2) (safety 0) (debug 0)))
(with-stream-class (simple-stream stream)
(let ((fd (sm input-handle stream))
- (end (or end (sm buf-len stream)))
- (buffer (or buffer (sm buffer stream))))
+ (end (or end (sm buf-len stream)))
+ (buffer (or buffer (sm buffer stream))))
(declare (fixnum end))
(typecase fd
- (fixnum
- (let ((flag (sb-sys:wait-until-fd-usable fd :input
+ (fixnum
+ (let ((flag (sb-sys:wait-until-fd-usable fd :input
(if blocking nil 0))))
- (cond
- ((and (not blocking) (= start end)) (if flag -3 0))
- ((and (not blocking) (not flag)) 0)
- (t (block nil
- (let ((count 0))
- (declare (type fixnum count))
- (tagbody
- again
- ;; Avoid CMUCL gengc write barrier
- (do ((i start (+ i (the fixnum #.(sb-posix:getpagesize)))))
- ((>= i end))
- (declare (type fixnum i))
- (setf (bref buffer i) 0))
- (setf (bref buffer (1- end)) 0)
- (multiple-value-bind (bytes errno)
- (sb-unix:unix-read fd (buffer-sap buffer start)
+ (cond
+ ((and (not blocking) (= start end)) (if flag -3 0))
+ ((and (not blocking) (not flag)) 0)
+ (t (block nil
+ (let ((count 0))
+ (declare (type fixnum count))
+ (tagbody
+ again
+ ;; Avoid CMUCL gengc write barrier
+ (do ((i start (+ i (the fixnum #.(sb-posix:getpagesize)))))
+ ((>= i end))
+ (declare (type fixnum i))
+ (setf (bref buffer i) 0))
+ (setf (bref buffer (1- end)) 0)
+ (multiple-value-bind (bytes errno)
+ (sb-unix:unix-read fd (buffer-sap buffer start)
(the fixnum (- end start)))
- (declare (type (or null fixnum) bytes)
- (type (integer 0 100) errno))
- (when bytes
- (incf count bytes)
- (incf start bytes))
- (cond ((null bytes)
- (format *debug-io* "~&;; UNIX-READ: errno=~D~%" errno)
- (cond ((= errno sb-unix:eintr) (go again))
- ((and blocking
- (or (= errno ;;sb-unix:eagain
+ (declare (type (or null fixnum) bytes)
+ (type (integer 0 100) errno))
+ (when bytes
+ (incf count bytes)
+ (incf start bytes))
+ (cond ((null bytes)
+ (format *debug-io* "~&;; UNIX-READ: errno=~D~%" errno)
+ (cond ((= errno sb-unix:eintr) (go again))
+ ((and blocking
+ (or (= errno ;;sb-unix:eagain
;; TODO: move
;; eagain into
;; sb-unix
11)
- (= errno sb-unix:ewouldblock)))
- (sb-sys:wait-until-fd-usable fd :input nil)
- (go again))
- (t (return (- -10 errno)))))
- ((zerop count) (return -1))
- (t (return count)))))))))))
- (t (%read-vector buffer fd start end :byte-8
- (if blocking :bnb nil)))))))
+ (= errno sb-unix:ewouldblock)))
+ (sb-sys:wait-until-fd-usable fd :input nil)
+ (go again))
+ (t (return (- -10 errno)))))
+ ((zerop count) (return -1))
+ (t (return count)))))))))))
+ (t (%read-vector buffer fd start end :byte-8
+ (if blocking :bnb nil)))))))
(defun write-octets (stream buffer start end blocking)
(declare (type simple-stream stream)
- (type simple-stream-buffer buffer)
- (type fixnum start)
- (type (or null fixnum) end))
+ (type simple-stream-buffer buffer)
+ (type fixnum start)
+ (type (or null fixnum) end))
(with-stream-class (simple-stream stream)
(when (sm handler stream)
(do ()
- ((null (sm pending stream)))
- (sb-sys:serve-all-events)))
+ ((null (sm pending stream)))
+ (sb-sys:serve-all-events)))
(let ((fd (sm output-handle stream))
- (end (or end (length buffer))))
+ (end (or end (length buffer))))
(typecase fd
- (fixnum
- (let ((flag (sb-sys:wait-until-fd-usable fd :output
+ (fixnum
+ (let ((flag (sb-sys:wait-until-fd-usable fd :output
(if blocking nil 0))))
- (cond
- ((and (not blocking) (= start end)) (if flag -3 0))
- ((and (not blocking) (not flag)) 0)
- (t
- (block nil
- (let ((count 0))
- (tagbody again
- (multiple-value-bind (bytes errno)
- (sb-unix:unix-write fd (buffer-sap buffer) start
- (- end start))
- (when bytes
- (incf count bytes)
- (incf start bytes))
- (cond ((null bytes)
- (format *debug-io* "~&;; UNIX-WRITE: errno=~D~%" errno)
- (cond ((= errno sb-unix:eintr) (go again))
- ;; don't block for subsequent chars
- (t (return (- -10 errno)))))
- (t (return count)))))))))))
- (t (error "implement me"))))))
+ (cond
+ ((and (not blocking) (= start end)) (if flag -3 0))
+ ((and (not blocking) (not flag)) 0)
+ (t
+ (block nil
+ (let ((count 0))
+ (tagbody again
+ (multiple-value-bind (bytes errno)
+ (sb-unix:unix-write fd (buffer-sap buffer) start
+ (- end start))
+ (when bytes
+ (incf count bytes)
+ (incf start bytes))
+ (cond ((null bytes)
+ (format *debug-io* "~&;; UNIX-WRITE: errno=~D~%" errno)
+ (cond ((= errno sb-unix:eintr) (go again))
+ ;; don't block for subsequent chars
+ (t (return (- -10 errno)))))
+ (t (return count)))))))))))
+ (t (error "implement me"))))))
(defun do-some-output (stream)
;; Do some pending output; return T if completed, NIL if more to do
(with-stream-class (simple-stream stream)
(let ((fd (sm output-handle stream)))
(loop
- (let ((list (pop (sm pending stream))))
- (unless list
- (sb-sys:remove-fd-handler (sm handler stream))
- (setf (sm handler stream) nil)
- (return t))
- (let* ((buffer (first list))
- (start (second list))
- (end (third list))
- (len (- end start)))
- (declare (type simple-stream-buffer buffer)
- (type sb-int:index start end len))
- (tagbody again
- (multiple-value-bind (bytes errno)
- (sb-unix:unix-write fd (buffer-sap buffer) start len)
- (cond ((null bytes)
- (if (= errno sb-unix:eintr)
- (go again)
- (progn (push list (sm pending stream))
- (return nil))))
- ((< bytes len)
- (setf (second list) (+ start bytes))
- (push list (sm pending stream))
- (return nil))
- ((= bytes len)
- (free-buffer buffer)))))))))))
+ (let ((list (pop (sm pending stream))))
+ (unless list
+ (sb-sys:remove-fd-handler (sm handler stream))
+ (setf (sm handler stream) nil)
+ (return t))
+ (let* ((buffer (first list))
+ (start (second list))
+ (end (third list))
+ (len (- end start)))
+ (declare (type simple-stream-buffer buffer)
+ (type sb-int:index start end len))
+ (tagbody again
+ (multiple-value-bind (bytes errno)
+ (sb-unix:unix-write fd (buffer-sap buffer) start len)
+ (cond ((null bytes)
+ (if (= errno sb-unix:eintr)
+ (go again)
+ (progn (push list (sm pending stream))
+ (return nil))))
+ ((< bytes len)
+ (setf (second list) (+ start bytes))
+ (push list (sm pending stream))
+ (return nil))
+ ((= bytes len)
+ (free-buffer buffer)))))))))))
(defun queue-write (stream buffer start end)
;; Queue a write; return T if buffer needs changing, NIL otherwise
(declare (type simple-stream stream)
- (type simple-stream-buffer buffer)
- (type sb-int:index start end))
+ (type simple-stream-buffer buffer)
+ (type sb-int:index start end))
(with-stream-class (simple-stream stream)
(when (sm handler stream)
(unless (do-some-output stream)
- (let ((last (last (sm pending stream))))
- (setf (cdr last) (list (list buffer start end)))
- (return-from queue-write t))))
+ (let ((last (last (sm pending stream))))
+ (setf (cdr last) (list (list buffer start end)))
+ (return-from queue-write t))))
(let ((bytes (write-octets stream buffer start end nil)))
(unless (or (= bytes (- end start)) ; completed
- (= bytes -3)) ; empty buffer; shouldn't happen
- (setf (sm pending stream) (list (list buffer start end)))
- (setf (sm handler stream)
- (sb-sys:add-fd-handler (sm output-handle stream) :output
+ (= bytes -3)) ; empty buffer; shouldn't happen
+ (setf (sm pending stream) (list (list buffer start end)))
+ (setf (sm handler stream)
+ (sb-sys:add-fd-handler (sm output-handle stream) :output
(lambda (fd)
(declare (ignore fd))
(do-some-output stream))))
- t))))
+ t))))
(defun %fd-open (pathname direction if-exists if-exists-given
- if-does-not-exist if-does-not-exist-given)
+ if-does-not-exist if-does-not-exist-given)
(declare (type pathname pathname)
- (type (member :input :output :io :probe) direction)
- (type (member :error :new-version :rename :rename-and-delete
- :overwrite :append :supersede nil) if-exists)
- (type (member :error :create nil) if-does-not-exist))
+ (type (member :input :output :io :probe) direction)
+ (type (member :error :new-version :rename :rename-and-delete
+ :overwrite :append :supersede nil) if-exists)
+ (type (member :error :create nil) if-does-not-exist))
(multiple-value-bind (input output mask)
(ecase direction
- (:input (values t nil sb-unix:o_rdonly))
- (:output (values nil t sb-unix:o_wronly))
- (:io (values t t sb-unix:o_rdwr))
- (:probe (values t nil sb-unix:o_rdonly)))
+ (:input (values t nil sb-unix:o_rdonly))
+ (:output (values nil t sb-unix:o_wronly))
+ (:io (values t t sb-unix:o_rdwr))
+ (:probe (values t nil sb-unix:o_rdonly)))
(declare (type sb-int:index mask))
(let ((name (cond ((sb-int:unix-namestring pathname input))
- ((and input (eq if-does-not-exist :create))
- (sb-int:unix-namestring pathname nil))
- ((and (eq direction :io) (not if-does-not-exist-given))
- (sb-int:unix-namestring pathname nil)))))
+ ((and input (eq if-does-not-exist :create))
+ (sb-int:unix-namestring pathname nil))
+ ((and (eq direction :io) (not if-does-not-exist-given))
+ (sb-int:unix-namestring pathname nil)))))
;; Process if-exists argument if we are doing any output.
(cond (output
- (unless if-exists-given
- (setf if-exists
- (if (eq (pathname-version pathname) :newest)
- :new-version
- :error)))
- (case if-exists
- ((:error nil :new-version)
- (setf mask (logior mask sb-unix:o_excl)))
- ((:rename :rename-and-delete)
- (setf mask (logior mask sb-unix:o_creat)))
- ((:supersede)
- (setf mask (logior mask sb-unix:o_trunc)))))
- (t
- (setf if-exists nil))) ; :ignore-this-arg
+ (unless if-exists-given
+ (setf if-exists
+ (if (eq (pathname-version pathname) :newest)
+ :new-version
+ :error)))
+ (case if-exists
+ ((:error nil :new-version)
+ (setf mask (logior mask sb-unix:o_excl)))
+ ((:rename :rename-and-delete)
+ (setf mask (logior mask sb-unix:o_creat)))
+ ((:supersede)
+ (setf mask (logior mask sb-unix:o_trunc)))))
+ (t
+ (setf if-exists nil))) ; :ignore-this-arg
(unless if-does-not-exist-given
- (setf if-does-not-exist
- (cond ((eq direction :input) :error)
- ((and output
- (member if-exists '(:overwrite :append)))
- :error)
- ((eq direction :probe)
- nil)
- (t
- :create))))
+ (setf if-does-not-exist
+ (cond ((eq direction :input) :error)
+ ((and output
+ (member if-exists '(:overwrite :append)))
+ :error)
+ ((eq direction :probe)
+ nil)
+ (t
+ :create))))
(if (eq if-does-not-exist :create)
- (setf mask (logior mask sb-unix:o_creat)))
+ (setf mask (logior mask sb-unix:o_creat)))
(let ((original (if (member if-exists
'(:rename :rename-and-delete))
(sb-impl::pick-backup-name name)
nil))
- (delete-original (eq if-exists :rename-and-delete))
- (mode #o666))
- (when original
- ;; We are doing a :rename or :rename-and-delete.
- ;; Determine if the file already exists, make sure the original
- ;; file is not a directory and keep the mode
- (let ((exists
- (and name
- (multiple-value-bind
- (okay err/dev inode orig-mode)
- (sb-unix:unix-stat name)
- (declare (ignore inode)
- (type (or sb-int:index null) orig-mode))
- (cond
- (okay
- (when (and output (= (logand orig-mode #o170000)
- #o40000))
- (error 'sb-int:simple-file-error
- :pathname pathname
- :format-control
- "Cannot open ~S for output: Is a directory."
- :format-arguments (list name)))
- (setf mode (logand orig-mode #o777))
- t)
- ((eql err/dev sb-unix:enoent)
- nil)
- (t
- (error 'sb-int:simple-file-error
- :pathname pathname
- :format-control "Cannot find ~S: ~A"
- :format-arguments
- (list name
- (sb-int:strerror err/dev)))))))))
- (unless (and exists
- (rename-file name original))
- (setf original nil)
- (setf delete-original nil)
- ;; In order to use SUPERSEDE instead, we have
- ;; to make sure unix:o_creat corresponds to
- ;; if-does-not-exist. unix:o_creat was set
- ;; before because of if-exists being :rename.
- (unless (eq if-does-not-exist :create)
- (setf mask (logior (logandc2 mask sb-unix:o_creat)
- sb-unix:o_trunc)))
- (setf if-exists :supersede))))
-
- ;; Okay, now we can try the actual open.
- (loop
- (multiple-value-bind (fd errno)
- (if name
- (sb-unix:unix-open name mask mode)
- (values nil sb-unix:enoent))
- (cond ((sb-int:fixnump fd)
+ (delete-original (eq if-exists :rename-and-delete))
+ (mode #o666))
+ (when original
+ ;; We are doing a :rename or :rename-and-delete.
+ ;; Determine if the file already exists, make sure the original
+ ;; file is not a directory and keep the mode
+ (let ((exists
+ (and name
+ (multiple-value-bind
+ (okay err/dev inode orig-mode)
+ (sb-unix:unix-stat name)
+ (declare (ignore inode)
+ (type (or sb-int:index null) orig-mode))
+ (cond
+ (okay
+ (when (and output (= (logand orig-mode #o170000)
+ #o40000))
+ (error 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control
+ "Cannot open ~S for output: Is a directory."
+ :format-arguments (list name)))
+ (setf mode (logand orig-mode #o777))
+ t)
+ ((eql err/dev sb-unix:enoent)
+ nil)
+ (t
+ (error 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control "Cannot find ~S: ~A"
+ :format-arguments
+ (list name
+ (sb-int:strerror err/dev)))))))))
+ (unless (and exists
+ (rename-file name original))
+ (setf original nil)
+ (setf delete-original nil)
+ ;; In order to use SUPERSEDE instead, we have
+ ;; to make sure unix:o_creat corresponds to
+ ;; if-does-not-exist. unix:o_creat was set
+ ;; before because of if-exists being :rename.
+ (unless (eq if-does-not-exist :create)
+ (setf mask (logior (logandc2 mask sb-unix:o_creat)
+ sb-unix:o_trunc)))
+ (setf if-exists :supersede))))
+
+ ;; Okay, now we can try the actual open.
+ (loop
+ (multiple-value-bind (fd errno)
+ (if name
+ (sb-unix:unix-open name mask mode)
+ (values nil sb-unix:enoent))
+ (cond ((sb-int:fixnump fd)
(when (eql if-exists :append)
(sb-unix:unix-lseek fd 0 sb-unix:l_xtnd))
- (return (values fd name original delete-original)))
- ((eql errno sb-unix:enoent)
- (case if-does-not-exist
- (:error
- (cerror "Return NIL."
- 'sb-int:simple-file-error
- :pathname pathname
- :format-control "Error opening ~S, ~A."
- :format-arguments
- (list pathname
- (sb-int:strerror errno))))
- (:create
+ (return (values fd name original delete-original)))
+ ((eql errno sb-unix:enoent)
+ (case if-does-not-exist
+ (:error
+ (cerror "Return NIL."
+ 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control "Error opening ~S, ~A."
+ :format-arguments
+ (list pathname
+ (sb-int:strerror errno))))
+ (:create
(cerror "Return NIL."
- 'sb-int:simple-file-error
- :pathname pathname
- :format-control
- "Error creating ~S, path does not exist."
- :format-arguments (list pathname))))
- (return nil))
- ((eql errno sb-unix:eexist)
- (unless (eq nil if-exists)
- (cerror "Return NIL."
- 'sb-int:simple-file-error
- :pathname pathname
- :format-control "Error opening ~S, ~A."
- :format-arguments
- (list pathname
- (sb-int:strerror errno))))
- (return nil))
+ 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control
+ "Error creating ~S, path does not exist."
+ :format-arguments (list pathname))))
+ (return nil))
+ ((eql errno sb-unix:eexist)
+ (unless (eq nil if-exists)
+ (cerror "Return NIL."
+ 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control "Error opening ~S, ~A."
+ :format-arguments
+ (list pathname
+ (sb-int:strerror errno))))
+ (return nil))
#+nil ; FIXME: reinstate this; error reporting is nice.
- ((eql errno sb-unix:eacces)
- (cerror "Try again."
- 'sb-int:simple-file-error
- :pathname pathname
- :format-control "Error opening ~S, ~A."
- :format-arguments
- (list pathname
- (sb-int:strerror errno))))
- (t
- (cerror "Return NIL."
- 'sb-int:simple-file-error
- :pathname pathname
- :format-control "Error opening ~S, ~A."
- :format-arguments
- (list pathname
- (sb-int:strerror errno)))
- (return nil)))))))))
+ ((eql errno sb-unix:eacces)
+ (cerror "Try again."
+ 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control "Error opening ~S, ~A."
+ :format-arguments
+ (list pathname
+ (sb-int:strerror errno))))
+ (t
+ (cerror "Return NIL."
+ 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control "Error opening ~S, ~A."
+ :format-arguments
+ (list pathname
+ (sb-int:strerror errno)))
+ (return nil)))))))))
(defun open-fd-stream (pathname &key (direction :input)
- (element-type 'base-char)
- (if-exists nil if-exists-given)
- (if-does-not-exist nil if-does-not-exist-given)
- (external-format :default))
+ (element-type 'base-char)
+ (if-exists nil if-exists-given)
+ (if-does-not-exist nil if-does-not-exist-given)
+ (external-format :default))
(declare (type (or pathname string stream) pathname)
- (type (member :input :output :io :probe) direction)
- (type (member :error :new-version :rename :rename-and-delete
- :overwrite :append :supersede nil) if-exists)
- (type (member :error :create nil) if-does-not-exist)
- (ignore external-format))
+ (type (member :input :output :io :probe) direction)
+ (type (member :error :new-version :rename :rename-and-delete
+ :overwrite :append :supersede nil) if-exists)
+ (type (member :error :create nil) if-does-not-exist)
+ (ignore external-format))
(let ((filespec (merge-pathnames pathname)))
(multiple-value-bind (fd namestring original delete-original)
(%fd-open filespec direction if-exists if-exists-given
:original original
:delete-original delete-original
:pathname pathname
- :dual-channel-p nil
+ :dual-channel-p nil
:input-buffer-p t
:auto-close t))
(:probe
;; sat: Hooks to parse URIs etc apparently go here
(defstruct (filespec-parser
- (:constructor make-filespec-parser (name priority function)))
+ (:constructor make-filespec-parser (name priority function)))
name
priority
function)
(defun add-filespec (name priority function)
(let ((filespec (make-filespec-parser name priority function)))
(setf *filespec-parsers*
- (stable-sort (cons filespec (delete name *filespec-parsers*
- :key #'filespec-parser-name))
- #'>
- :key #'filespec-parser-priority)))
+ (stable-sort (cons filespec (delete name *filespec-parsers*
+ :key #'filespec-parser-name))
+ #'>
+ :key #'filespec-parser-priority)))
t)
(defmacro define-filespec (name lambda-list &body body)
(let ((truename (if (consp name) (first name) name))
- (priority (if (consp name) (second name) 0)))
+ (priority (if (consp name) (second name) 0)))
`(add-filespec ',truename ,priority (lambda ,lambda-list
- (block ,truename
- ,@body)))))
+ (block ,truename
+ ,@body)))))
(defun parse-filespec (string &optional (errorp t))
(dolist (i *filespec-parsers* (when errorp
- (error "~S not recognised." string)))
+ (error "~S not recognised." string)))
(let ((result (ignore-errors
- (funcall (filespec-parser-function i) string))))
+ (funcall (filespec-parser-function i) string))))
(when result (return result)))))
(define-filespec pathname (string)
projects / sbcl.git / blobdiff