1 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*-
3 ;;; **********************************************************************
4 ;;; This code was written by Paul Foley and has been placed in the public
8 ;;; Sbcl port by Rudi Schlatte.
10 (in-package "SB-SIMPLE-STREAMS")
13 ;;; **********************************************************************
15 ;;; Various functions needed by simple-streams
16 (declaim (inline buffer-sap bref
(setf bref
) buffer-copy
17 allocate-buffer free-buffer
))
19 (defun buffer-sap (thing &optional offset
)
20 (declare (type simple-stream-buffer thing
) (type (or fixnum null
) offset
)
21 (optimize (speed 3) (space 2) (debug 0) (safety 0)
22 ;; Suppress the note about having to box up the return:
23 (sb-ext:inhibit-warnings
3)))
24 (let ((sap (if (vectorp thing
) (sb-sys:vector-sap thing
) thing
)))
25 (if offset
(sb-sys:sap
+ sap offset
) sap
)))
27 (defun bref (buffer index
)
28 (declare (type simple-stream-buffer buffer
)
29 (type (integer 0 #.most-positive-fixnum
) index
))
31 (sb-sys:with-pinned-objects
(buffer)
32 (sb-sys:sap-ref-8
(sb-sys:vector-sap buffer
) index
))
33 (sb-sys:sap-ref-8 buffer index
)))
35 (defun (setf bref
) (octet buffer index
)
36 (declare (type (unsigned-byte 8) octet
)
37 (type simple-stream-buffer buffer
)
38 (type (integer 0 #.most-positive-fixnum
) index
))
40 (sb-sys:with-pinned-objects
(buffer)
41 (setf (sb-sys:sap-ref-8
(sb-sys:vector-sap buffer
) index
) octet
))
42 (setf (sb-sys:sap-ref-8 buffer index
) octet
)))
44 (defun buffer-copy (src soff dst doff length
)
45 (declare (type simple-stream-buffer src dst
)
46 (type fixnum soff doff length
))
47 ;; FIXME: Should probably be with-pinned-objects
49 (sb-kernel:system-area-ub8-copy
(buffer-sap src
) soff
53 (defun allocate-buffer (size)
54 (make-array size
:element-type
'(unsigned-byte 8)))
56 (defun free-buffer (buffer)
57 (sb-int:aver
(typep buffer
'(simple-array (unsigned-byte 8) (*))))
60 (defun make-control-table (&rest inits
)
61 (let ((table (make-array 32 :initial-element nil
)))
62 (do* ((char (pop inits
) (pop inits
))
63 (func (pop inits
) (pop inits
)))
65 (when (< (char-code char
) 32)
66 (setf (aref table
(char-code char
)) func
)))
69 (defun std-newline-out-handler (stream character
)
70 (declare (ignore character
))
71 (with-stream-class (simple-stream stream
)
72 (setf (sm charpos stream
) -
1)
75 (defun std-tab-out-handler (stream character
)
76 (declare (ignore character
))
77 (with-stream-class (simple-stream stream
)
78 (let ((col (sm charpos stream
)))
80 (setf (sm charpos stream
) (1- (* 8 (1+ (floor col
8)))))))
83 (defun std-dc-newline-in-handler (stream character
)
84 (with-stream-class (dual-channel-simple-stream stream
)
85 ;; FIXME: Currently, -1 is wrong, since callers of CHARPOS expect
86 ;; a result in (or null (and fixnum unsigned-byte)), so they must
87 ;; never see this temporary value. Note that in
88 ;; STD-NEWLINE-OUT-HANDLER it is correct to use -1, since CHARPOS
89 ;; is incremented to zero before WRITE-CHAR returns. Perhaps the
90 ;; same should happen for input?
91 (setf (sm charpos stream
) 0) ; was -1
94 (defvar *std-control-out-table
*
95 (make-control-table #\Newline
#'std-newline-out-handler
96 #\Tab
#'std-tab-out-handler
))
98 (defvar *default-external-format
* :iso8859-1
)
100 (defvar *external-formats
* (make-hash-table))
101 (defvar *external-format-aliases
* (make-hash-table))
103 (defstruct (external-format
105 (:print-function %print-external-format
)
106 (:constructor make-external-format
(name octets-to-char
108 (name (sb-int:missing-arg
) :type keyword
:read-only t
)
109 (octets-to-char (sb-int:missing-arg
) :type function
:read-only t
)
110 (char-to-octets (sb-int:missing-arg
) :type function
:read-only t
))
112 (defun %print-external-format
(ef stream depth
)
113 (declare (ignore depth
))
114 (print-unreadable-object (ef stream
:type t
:identity t
)
115 (princ (ef-name ef
) stream
)))
117 (defmacro define-external-format
(name octets-to-char char-to-octets
)
118 `(macrolet ((octets-to-char ((state input unput
) &body body
)
119 `(lambda (,state
,input
,unput
)
120 (declare (type (function () (unsigned-byte 8)) ,input
)
121 (type (function (sb-int:index
) t
) ,unput
)
122 (ignorable ,state
,input
,unput
)
123 (values character sb-int
:index t
))
125 (char-to-octets ((char state output
) &body body
)
126 `(lambda (,char
,state
,output
)
127 (declare (type character
,char
)
128 (type (function ((unsigned-byte 8)) t
) ,output
)
129 (ignorable state
,output
)
132 (setf (gethash ,name
*external-formats
*)
133 (make-external-format ,name
,octets-to-char
,char-to-octets
))))
135 ;;; TODO: make this work
136 (defun load-external-format-aliases ()
137 (let ((*package
* (find-package "KEYWORD")))
138 (with-open-file (stm "ef:aliases" :if-does-not-exist nil
)
140 (do ((alias (read stm nil stm
) (read stm nil stm
))
141 (value (read stm nil stm
) (read stm nil stm
)))
142 ((or (eq alias stm
) (eq value stm
))
143 (unless (eq alias stm
)
144 (warn "External-format aliases file ends early.")))
145 (if (and (keywordp alias
) (keywordp value
))
146 (setf (gethash alias
*external-format-aliases
*) value
)
147 (warn "Bad entry in external-format aliases file: ~S => ~S."
150 (defun find-external-format (name &optional
(error-p t
))
151 (when (external-format-p name
)
152 (return-from find-external-format name
))
154 (when (eq name
:default
)
155 (setq name
*default-external-format
*))
157 ;; TODO: make this work
159 (unless (ext:search-list-defined-p
"ef:")
160 (setf (ext:search-list
"ef:") '("library:ef/")))
162 (when (zerop (hash-table-count *external-format-aliases
*))
163 (setf (gethash :latin1
*external-format-aliases
*) :iso8859-1
)
164 (setf (gethash :latin-1
*external-format-aliases
*) :iso8859-1
)
165 (setf (gethash :iso-8859-1
*external-format-aliases
*) :iso8859-1
)
166 (load-external-format-aliases))
168 (do ((tmp (gethash name
*external-format-aliases
*)
169 (gethash tmp
*external-format-aliases
*))
171 ((or (null tmp
) (= cnt
50))
173 (error "External-format aliasing depth exceeded.")))
176 (or (gethash name
*external-formats
*)
177 (and (let ((*package
* (find-package "SB-SIMPLE-STREAMS")))
178 (load (format nil
"ef:~(~A~)" name
) :if-does-not-exist nil
))
179 (gethash name
*external-formats
*))
180 (if error-p
(error "External format ~S not found." name
) nil
)))
182 (define-condition void-external-format
(error)
185 (lambda (condition stream
)
186 (declare (ignore condition
))
187 (format stream
"Attempting I/O through void external-format."))))
189 (define-external-format :void
190 (octets-to-char (state input unput
)
191 (declare (ignore state input unput
))
192 (error 'void-external-format
))
193 (char-to-octets (char state output
)
194 (declare (ignore char state output
))
195 (error 'void-external-format
)))
197 (define-external-format :iso8859-1
198 (octets-to-char (state input unput
)
199 (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
200 (values (code-char (funcall input
)) 1 state
))
201 (char-to-octets (char state output
)
202 (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
203 (let ((code (char-code char
)))
205 (funcall output code
)
208 (funcall output code
)
209 (funcall output
(char-code #\?))))
212 (defmacro octets-to-char
(external-format state count input unput
)
213 (let ((tmp1 (gensym)) (tmp2 (gensym)) (tmp3 (gensym)))
214 `(multiple-value-bind (,tmp1
,tmp2
,tmp3
)
215 (funcall (ef-octets-to-char ,external-format
) ,state
,input
,unput
)
216 (setf ,state
,tmp3
,count
,tmp2
)
219 (defmacro char-to-octets
(external-format char state output
)
221 (setf ,state
(funcall (ef-char-to-octets ,external-format
)
222 ,char
,state
,output
))
225 (defun string-to-octets (string &key
(start 0) end
(external-format :default
))
226 (declare (type string string
)
227 (type sb-int
:index start
)
228 (type (or null sb-int
:index
) end
))
229 (let ((ef (find-external-format external-format
))
230 (buffer (make-array (length string
) :element-type
'(unsigned-byte 8)))
234 (setf (aref buffer ptr
) b
)
235 (when (= (incf ptr
) (length buffer
))
236 (setq buffer
(adjust-array buffer
(* 2 ptr
))))))
237 (dotimes (i (- (or end
(length string
)) start
))
238 (declare (type sb-int
:index i
))
239 (char-to-octets ef
(char string
(+ start i
)) state
#'out
))
240 (sb-kernel:shrink-vector buffer ptr
))))
242 (defun octets-to-string (octets &key
(start 0) end
(external-format :default
))
243 (declare (type vector octets
)
244 (type sb-int
:index start
)
245 (type (or null sb-int
:index
) end
))
246 (let ((ef (find-external-format external-format
))
247 (end (1- (or end
(length octets
))))
248 (string (make-string (length octets
)))
254 (aref octets
(incf ptr
)))
257 (loop until
(>= ptr end
)
258 do
(setf (schar string
(incf pos
))
259 (octets-to-char ef state count
#'input
#'unput
))))
260 (sb-kernel:shrink-vector string
(1+ pos
))))
262 (defun vector-elt-width (vector)
263 ;; Return octet-width of vector elements
265 ;; (simple-array fixnum (*)) not supported
266 ;; (simple-array base-char (*)) treated specially; don't call this
267 ((simple-array bit
(*)) 1)
268 ((simple-array (unsigned-byte 2) (*)) 1)
269 ((simple-array (unsigned-byte 4) (*)) 1)
270 ((simple-array (signed-byte 8) (*)) 1)
271 ((simple-array (unsigned-byte 8) (*)) 1)
272 ((simple-array (signed-byte 16) (*)) 2)
273 ((simple-array (unsigned-byte 16) (*)) 2)
274 ((simple-array (signed-byte 32) (*)) 4)
275 ((simple-array (unsigned-byte 32) (*)) 4)
276 ((simple-array single-float
(*)) 4)
277 ((simple-array double-float
(*)) 8)
278 ((simple-array (complex single-float
) (*)) 8)
279 ((simple-array (complex double-float
) (*)) 16)))
281 #-
(or big-endian little-endian
)
282 (eval-when (:compile-toplevel
)
283 (push sb-c
::*backend-byte-order
* *features
*))
285 (defun endian-swap-value (vector endian-swap
)
286 #+big-endian
(declare (ignore vector
))
288 (:network-order
#+big-endian
0
289 #+little-endian
(1- (vector-elt-width vector
)))
295 (otherwise endian-swap
)))
298 (defun %read-vector
(vector stream start end endian-swap blocking
)
299 (declare (type (kernel:simple-unboxed-array
(*)) vector
)
300 (type stream stream
))
301 ;; move code from read-vector
305 (defun %write-vector
(... blocking
)
309 (defun read-octets (stream buffer start end blocking
)
310 (declare (type simple-stream stream
)
311 (type (or null simple-stream-buffer
) buffer
)
313 (type (or null fixnum
) end
)
314 (type blocking blocking
)
315 (optimize (speed 3) (space 2) (safety 0) (debug 0)))
316 (with-stream-class (simple-stream stream
)
317 (let ((fd (sm input-handle stream
))
318 (end (or end
(sm buf-len stream
)))
319 (buffer (or buffer
(sm buffer stream
))))
320 (declare (fixnum end
))
323 (let ((flag (sb-sys:wait-until-fd-usable fd
:input
324 (if blocking nil
0))))
326 ((and (not blocking
) (= start end
)) (if flag -
3 0))
327 ((and (not blocking
) (not flag
)) 0)
330 (declare (type fixnum count
))
333 ;; Avoid CMUCL gengc write barrier
334 (do ((i start
(+ i
#.
(sb-posix:getpagesize
))))
336 (declare (type fixnum i
))
337 (setf (bref buffer i
) 0))
338 (setf (bref buffer
(1- end
)) 0)
339 (multiple-value-bind (bytes errno
)
340 (sb-sys:with-pinned-objects
(buffer)
341 (sb-unix:unix-read fd
(buffer-sap buffer start
)
342 (the fixnum
(- end start
))))
343 (declare (type (or null fixnum
) bytes
)
344 (type (integer 0 100) errno
))
349 (format *debug-io
* "~&;; UNIX-READ: errno=~D~%" errno
)
350 (cond ((= errno sb-unix
:eintr
) (go again
))
352 (or (= errno
;;sb-unix:eagain
357 (= errno sb-unix
:ewouldblock
)))
358 (sb-sys:wait-until-fd-usable fd
:input nil
)
360 (t (return (- -
10 errno
)))))
361 ((zerop count
) (return -
1))
362 (t (return count
)))))))))))
363 (t (%read-vector buffer fd start end
:byte-8
364 (if blocking
:bnb nil
)))))))
366 (defun write-octets (stream buffer start end blocking
)
367 (declare (type simple-stream stream
)
368 (type simple-stream-buffer buffer
)
370 (type (or null fixnum
) end
))
371 (with-stream-class (simple-stream stream
)
372 (when (sm handler stream
)
374 ((null (sm pending stream
)))
375 (sb-sys:serve-all-events
)))
377 (let ((fd (sm output-handle stream
))
378 (end (or end
(length buffer
))))
381 (let ((flag (sb-sys:wait-until-fd-usable fd
:output
382 (if blocking nil
0))))
384 ((and (not blocking
) (= start end
)) (if flag -
3 0))
385 ((and (not blocking
) (not flag
)) 0)
390 (multiple-value-bind (bytes errno
)
391 (sb-sys:with-pinned-objects
(buffer)
392 (sb-unix:unix-write fd
(buffer-sap buffer
) start
398 (format *debug-io
* "~&;; UNIX-WRITE: errno=~D~%" errno
)
399 (cond ((= errno sb-unix
:eintr
) (go again
))
400 ;; don't block for subsequent chars
401 (t (return (- -
10 errno
)))))
402 (t (return count
)))))))))))
403 (t (error "implement me"))))))
405 (defun do-some-output (stream)
406 ;; Do some pending output; return T if completed, NIL if more to do
407 (with-stream-class (simple-stream stream
)
408 (let ((fd (sm output-handle stream
)))
410 (let ((list (pop (sm pending stream
))))
412 (sb-sys:remove-fd-handler
(sm handler stream
))
413 (setf (sm handler stream
) nil
)
415 (let* ((buffer (first list
))
416 (start (second list
))
419 (declare (type simple-stream-buffer buffer
)
420 (type sb-int
:index start end len
))
422 (multiple-value-bind (bytes errno
)
423 (sb-sys:with-pinned-objects
(buffer)
424 (sb-unix:unix-write fd
(buffer-sap buffer
) start len
))
426 (if (= errno sb-unix
:eintr
)
428 (progn (push list
(sm pending stream
))
431 (setf (second list
) (+ start bytes
))
432 (push list
(sm pending stream
))
435 (free-buffer buffer
)))))))))))
437 (defun queue-write (stream buffer start end
)
438 ;; Queue a write; return T if buffer needs changing, NIL otherwise
439 (declare (type simple-stream stream
)
440 (type simple-stream-buffer buffer
)
441 (type sb-int
:index start end
))
442 (with-stream-class (simple-stream stream
)
443 (when (sm handler stream
)
444 (unless (do-some-output stream
)
445 (let ((last (last (sm pending stream
))))
446 (setf (cdr last
) (list (list buffer start end
)))
447 (return-from queue-write t
))))
448 (let ((bytes (write-octets stream buffer start end nil
)))
449 (unless (or (= bytes
(- end start
)) ; completed
450 (= bytes -
3)) ; empty buffer; shouldn't happen
451 (setf (sm pending stream
) (list (list buffer start end
)))
452 (setf (sm handler stream
)
453 (sb-sys:add-fd-handler
(sm output-handle stream
) :output
455 (declare (ignore fd
))
456 (do-some-output stream
))))
462 (defun %fd-open
(pathname direction if-exists if-exists-given
463 if-does-not-exist if-does-not-exist-given
)
464 (declare (type pathname pathname
)
465 (type (member :input
:output
:io
:probe
) direction
)
466 (type (member :error
:new-version
:rename
:rename-and-delete
467 :overwrite
:append
:supersede nil
) if-exists
)
468 (type (member :error
:create nil
) if-does-not-exist
))
469 (multiple-value-bind (input output mask
)
471 (:input
(values t nil sb-unix
:o_rdonly
))
472 (:output
(values nil t sb-unix
:o_wronly
))
473 (:io
(values t t sb-unix
:o_rdwr
))
474 (:probe
(values t nil sb-unix
:o_rdonly
)))
475 (declare (type sb-int
:index mask
))
476 (let ((name (cond ((sb-int:unix-namestring pathname input
))
477 ((and input
(eq if-does-not-exist
:create
))
478 (sb-int:unix-namestring pathname nil
))
479 ((and (eq direction
:io
) (not if-does-not-exist-given
))
480 (sb-int:unix-namestring pathname nil
)))))
481 ;; Process if-exists argument if we are doing any output.
483 (unless if-exists-given
485 (if (eq (pathname-version pathname
) :newest
)
489 ((:error nil
:new-version
)
490 (setf mask
(logior mask sb-unix
:o_excl
)))
491 ((:rename
:rename-and-delete
)
492 (setf mask
(logior mask sb-unix
:o_creat
)))
494 (setf mask
(logior mask sb-unix
:o_trunc
)))))
496 (setf if-exists nil
))) ; :ignore-this-arg
497 (unless if-does-not-exist-given
498 (setf if-does-not-exist
499 (cond ((eq direction
:input
) :error
)
501 (member if-exists
'(:overwrite
:append
)))
503 ((eq direction
:probe
)
507 (if (eq if-does-not-exist
:create
)
508 (setf mask
(logior mask sb-unix
:o_creat
)))
510 (let ((original (if (member if-exists
511 '(:rename
:rename-and-delete
))
512 (sb-impl::pick-backup-name name
)
514 (delete-original (eq if-exists
:rename-and-delete
))
517 ;; We are doing a :rename or :rename-and-delete.
518 ;; Determine if the file already exists, make sure the original
519 ;; file is not a directory and keep the mode
523 (okay err
/dev inode orig-mode
)
524 (sb-unix:unix-stat name
)
525 (declare (ignore inode
)
526 (type (or sb-int
:index null
) orig-mode
))
529 (when (and output
(= (logand orig-mode
#o170000
)
531 (error 'sb-int
:simple-file-error
534 "Cannot open ~S for output: Is a directory."
535 :format-arguments
(list name
)))
536 (setf mode
(logand orig-mode
#o777
))
538 ((eql err
/dev sb-unix
:enoent
)
541 (error 'sb-int
:simple-file-error
543 :format-control
"Cannot find ~S: ~A"
546 (sb-int:strerror err
/dev
)))))))))
548 (rename-file name original
))
550 (setf delete-original nil
)
551 ;; In order to use SUPERSEDE instead, we have
552 ;; to make sure unix:o_creat corresponds to
553 ;; if-does-not-exist. unix:o_creat was set
554 ;; before because of if-exists being :rename.
555 (unless (eq if-does-not-exist
:create
)
556 (setf mask
(logior (logandc2 mask sb-unix
:o_creat
)
558 (setf if-exists
:supersede
))))
560 ;; Okay, now we can try the actual open.
562 (multiple-value-bind (fd errno
)
564 (sb-unix:unix-open name mask mode
)
565 (values nil sb-unix
:enoent
))
566 (cond ((sb-int:fixnump fd
)
567 (when (eql if-exists
:append
)
568 (sb-unix:unix-lseek fd
0 sb-unix
:l_xtnd
))
569 (return (values fd name original delete-original
)))
570 ((eql errno sb-unix
:enoent
)
571 (case if-does-not-exist
573 (cerror "Return NIL."
574 'sb-int
:simple-file-error
576 :format-control
"Error opening ~S, ~A."
579 (sb-int:strerror errno
))))
581 (cerror "Return NIL."
582 'sb-int
:simple-file-error
585 "Error creating ~S, path does not exist."
586 :format-arguments
(list pathname
))))
588 ((eql errno sb-unix
:eexist
)
589 (unless (eq nil if-exists
)
590 (cerror "Return NIL."
591 'sb-int
:simple-file-error
593 :format-control
"Error opening ~S, ~A."
596 (sb-int:strerror errno
))))
598 #+nil
; FIXME: reinstate this; error reporting is nice.
599 ((eql errno sb-unix
:eacces
)
601 'sb-int
:simple-file-error
603 :format-control
"Error opening ~S, ~A."
606 (sb-int:strerror errno
))))
608 (cerror "Return NIL."
609 'sb-int
:simple-file-error
611 :format-control
"Error opening ~S, ~A."
614 (sb-int:strerror errno
)))
617 (defun open-fd-stream (pathname &key
(direction :input
)
618 (element-type 'base-char
)
619 (if-exists nil if-exists-given
)
620 (if-does-not-exist nil if-does-not-exist-given
)
621 (external-format :default
))
622 (declare (type (or pathname string stream
) pathname
)
623 (type (member :input
:output
:io
:probe
) direction
)
624 (type (member :error
:new-version
:rename
:rename-and-delete
625 :overwrite
:append
:supersede nil
) if-exists
)
626 (type (member :error
:create nil
) if-does-not-exist
))
627 (let ((filespec (merge-pathnames pathname
)))
628 (multiple-value-bind (fd namestring original delete-original
)
629 (%fd-open filespec direction if-exists if-exists-given
630 if-does-not-exist if-does-not-exist-given
)
633 ((:input
:output
:io
)
634 (sb-sys:make-fd-stream fd
635 :input
(member direction
'(:input
:io
))
636 :output
(member direction
'(:output
:io
))
637 :element-type element-type
640 :delete-original delete-original
645 :external-format external-format
))
647 (let ((stream (sb-impl::%make-fd-stream
:name namestring
:fd fd
649 :element-type element-type
)))
654 ;; Experimental "filespec" stuff
656 ;; sat: Hooks to parse URIs etc apparently go here
658 (defstruct (filespec-parser
659 (:constructor make-filespec-parser
(name priority function
)))
664 (defvar *filespec-parsers
* ())
666 (defun add-filespec (name priority function
)
667 (let ((filespec (make-filespec-parser name priority function
)))
668 (setf *filespec-parsers
*
669 (stable-sort (cons filespec
(delete name
*filespec-parsers
*
670 :key
#'filespec-parser-name
))
672 :key
#'filespec-parser-priority
)))
675 (defmacro define-filespec
(name lambda-list
&body body
)
676 (let ((truename (if (consp name
) (first name
) name
))
677 (priority (if (consp name
) (second name
) 0)))
678 `(add-filespec ',truename
,priority
(lambda ,lambda-list
682 (defun parse-filespec (string &optional
(errorp t
))
683 (dolist (i *filespec-parsers
* (when errorp
684 (error "~S not recognised." string
)))
685 (let ((result (ignore-errors
686 (funcall (filespec-parser-function i
) string
))))
687 (when result
(return result
)))))
689 (define-filespec pathname
(string)