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:sap-ref-8
(sb-sys:vector-sap buffer
) index
)
32 (sb-sys:sap-ref-8 buffer index
)))
34 (defun (setf bref
) (octet buffer index
)
35 (declare (type (unsigned-byte 8) octet
)
36 (type simple-stream-buffer buffer
)
37 (type (integer 0 #.most-positive-fixnum
) index
))
39 (setf (sb-sys:sap-ref-8
(sb-sys:vector-sap buffer
) index
) octet
)
40 (setf (sb-sys:sap-ref-8 buffer index
) octet
)))
42 (defun buffer-copy (src soff dst doff length
)
43 (declare (type simple-stream-buffer src dst
)
44 (type fixnum soff doff length
))
45 (sb-sys:without-gcing
;; is this necessary??
46 (sb-kernel:system-area-ub8-copy
(buffer-sap src
) soff
50 (defun allocate-buffer (size)
51 (if (= size sb-impl
::bytes-per-buffer
)
52 (sb-impl::next-available-buffer
)
53 (make-array size
:element-type
'(unsigned-byte 8))))
55 (defun free-buffer (buffer)
56 (when (sb-sys:system-area-pointer-p buffer
)
57 (push buffer sb-impl
::*available-buffers
*))
61 (defun make-control-table (&rest inits
)
62 (let ((table (make-array 32 :initial-element nil
)))
63 (do* ((char (pop inits
) (pop inits
))
64 (func (pop inits
) (pop inits
)))
66 (when (< (char-code char
) 32)
67 (setf (aref table
(char-code char
)) func
)))
70 (defun std-newline-out-handler (stream character
)
71 (declare (ignore character
))
72 (with-stream-class (simple-stream stream
)
73 (setf (sm charpos stream
) -
1)
76 (defun std-tab-out-handler (stream character
)
77 (declare (ignore character
))
78 (with-stream-class (simple-stream stream
)
79 (let ((col (sm charpos stream
)))
81 (setf (sm charpos stream
) (1- (* 8 (1+ (floor col
8)))))))
84 (defun std-dc-newline-in-handler (stream character
)
85 (with-stream-class (dual-channel-simple-stream stream
)
86 ;; FIXME: Currently, -1 is wrong, since callers of CHARPOS expect
87 ;; a result in (or null (and fixnum unsigned-byte)), so they must
88 ;; never see this temporary value. Note that in
89 ;; STD-NEWLINE-OUT-HANDLER it is correct to use -1, since CHARPOS
90 ;; is incremented to zero before WRITE-CHAR returns. Perhaps the
91 ;; same should happen for input?
92 (setf (sm charpos stream
) 0) ; was -1
95 (defvar *std-control-out-table
*
96 (make-control-table #\Newline
#'std-newline-out-handler
97 #\Tab
#'std-tab-out-handler
))
99 (defvar *default-external-format
* :iso8859-1
)
101 (defvar *external-formats
* (make-hash-table))
102 (defvar *external-format-aliases
* (make-hash-table))
104 (defstruct (external-format
106 (:print-function %print-external-format
)
107 (:constructor make-external-format
(name octets-to-char
109 (name (sb-int:missing-arg
) :type keyword
:read-only t
)
110 (octets-to-char (sb-int:missing-arg
) :type function
:read-only t
)
111 (char-to-octets (sb-int:missing-arg
) :type function
:read-only t
))
113 (defun %print-external-format
(ef stream depth
)
114 (declare (ignore depth
))
115 (print-unreadable-object (ef stream
:type t
:identity t
)
116 (princ (ef-name ef
) stream
)))
118 (defmacro define-external-format
(name octets-to-char char-to-octets
)
119 `(macrolet ((octets-to-char ((state input unput
) &body body
)
120 `(lambda (,state
,input
,unput
)
121 (declare (type (function () (unsigned-byte 8)) ,input
)
122 (type (function (sb-int:index
) t
) ,unput
)
123 (ignorable ,state
,input
,unput
)
124 (values character sb-int
:index t
))
126 (char-to-octets ((char state output
) &body body
)
127 `(lambda (,char
,state
,output
)
128 (declare (type character
,char
)
129 (type (function ((unsigned-byte 8)) t
) ,output
)
130 (ignorable state
,output
)
133 (setf (gethash ,name
*external-formats
*)
134 (make-external-format ,name
,octets-to-char
,char-to-octets
))))
136 ;;; TODO: make this work
137 (defun load-external-format-aliases ()
138 (let ((*package
* (find-package "KEYWORD")))
139 (with-open-file (stm "ef:aliases" :if-does-not-exist nil
)
141 (do ((alias (read stm nil stm
) (read stm nil stm
))
142 (value (read stm nil stm
) (read stm nil stm
)))
143 ((or (eq alias stm
) (eq value stm
))
144 (unless (eq alias stm
)
145 (warn "External-format aliases file ends early.")))
146 (if (and (keywordp alias
) (keywordp value
))
147 (setf (gethash alias
*external-format-aliases
*) value
)
148 (warn "Bad entry in external-format aliases file: ~S => ~S."
151 (defun find-external-format (name &optional
(error-p t
))
152 (when (external-format-p name
)
153 (return-from find-external-format name
))
155 (when (eq name
:default
)
156 (setq name
*default-external-format
*))
158 ;; TODO: make this work
160 (unless (ext:search-list-defined-p
"ef:")
161 (setf (ext:search-list
"ef:") '("library:ef/")))
163 (when (zerop (hash-table-count *external-format-aliases
*))
164 (setf (gethash :latin1
*external-format-aliases
*) :iso8859-1
)
165 (setf (gethash :latin-1
*external-format-aliases
*) :iso8859-1
)
166 (setf (gethash :iso-8859-1
*external-format-aliases
*) :iso8859-1
)
167 (load-external-format-aliases))
169 (do ((tmp (gethash name
*external-format-aliases
*)
170 (gethash tmp
*external-format-aliases
*))
172 ((or (null tmp
) (= cnt
50))
174 (error "External-format aliasing depth exceeded.")))
177 (or (gethash name
*external-formats
*)
178 (and (let ((*package
* (find-package "SB-SIMPLE-STREAMS")))
179 (load (format nil
"ef:~(~A~)" name
) :if-does-not-exist nil
))
180 (gethash name
*external-formats
*))
181 (if error-p
(error "External format ~S not found." name
) nil
)))
183 (define-condition void-external-format
(error)
186 (lambda (condition stream
)
187 (declare (ignore condition
))
188 (format stream
"Attempting I/O through void external-format."))))
190 (define-external-format :void
191 (octets-to-char (state input unput
)
192 (declare (ignore state input unput
))
193 (error 'void-external-format
))
194 (char-to-octets (char state output
)
195 (declare (ignore char state output
))
196 (error 'void-external-format
)))
198 (define-external-format :iso8859-1
199 (octets-to-char (state input unput
)
200 (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
201 (values (code-char (funcall input
)) 1 state
))
202 (char-to-octets (char state output
)
203 (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
204 (let ((code (char-code char
)))
206 (funcall output code
)
209 (funcall output code
)
210 (funcall output
(char-code #\?))))
213 (defmacro octets-to-char
(external-format state count input unput
)
214 (let ((tmp1 (gensym)) (tmp2 (gensym)) (tmp3 (gensym)))
215 `(multiple-value-bind (,tmp1
,tmp2
,tmp3
)
216 (funcall (ef-octets-to-char ,external-format
) ,state
,input
,unput
)
217 (setf ,state
,tmp3
,count
,tmp2
)
220 (defmacro char-to-octets
(external-format char state output
)
222 (setf ,state
(funcall (ef-char-to-octets ,external-format
)
223 ,char
,state
,output
))
226 (defun string-to-octets (string &key
(start 0) end
(external-format :default
))
227 (declare (type string string
)
228 (type sb-int
:index start
)
229 (type (or null sb-int
:index
) end
))
230 (let ((ef (find-external-format external-format
))
231 (buffer (make-array (length string
) :element-type
'(unsigned-byte 8)))
235 (setf (aref buffer ptr
) b
)
236 (when (= (incf ptr
) (length buffer
))
237 (setq buffer
(adjust-array buffer
(* 2 ptr
))))))
238 (dotimes (i (- (or end
(length string
)) start
))
239 (declare (type sb-int
:index i
))
240 (char-to-octets ef
(char string
(+ start i
)) state
#'out
))
241 (sb-kernel:shrink-vector buffer ptr
))))
243 (defun octets-to-string (octets &key
(start 0) end
(external-format :default
))
244 (declare (type vector octets
)
245 (type sb-int
:index start
)
246 (type (or null sb-int
:index
) end
))
247 (let ((ef (find-external-format external-format
))
248 (end (1- (or end
(length octets
))))
249 (string (make-string (length octets
)))
255 (aref octets
(incf ptr
)))
258 (loop until
(>= ptr end
)
259 do
(setf (schar string
(incf pos
))
260 (octets-to-char ef state count
#'input
#'unput
))))
261 (sb-kernel:shrink-vector string
(1+ pos
))))
263 (defun vector-elt-width (vector)
264 ;; Return octet-width of vector elements
266 ;; (simple-array fixnum (*)) not supported
267 ;; (simple-array base-char (*)) treated specially; don't call this
268 ((simple-array bit
(*)) 1)
269 ((simple-array (unsigned-byte 2) (*)) 1)
270 ((simple-array (unsigned-byte 4) (*)) 1)
271 ((simple-array (signed-byte 8) (*)) 1)
272 ((simple-array (unsigned-byte 8) (*)) 1)
273 ((simple-array (signed-byte 16) (*)) 2)
274 ((simple-array (unsigned-byte 16) (*)) 2)
275 ((simple-array (signed-byte 32) (*)) 4)
276 ((simple-array (unsigned-byte 32) (*)) 4)
277 ((simple-array single-float
(*)) 4)
278 ((simple-array double-float
(*)) 8)
279 ((simple-array (complex single-float
) (*)) 8)
280 ((simple-array (complex double-float
) (*)) 16)))
282 #-
(or big-endian little-endian
)
283 (eval-when (:compile-toplevel
)
284 (push sb-c
::*backend-byte-order
* *features
*))
286 (defun endian-swap-value (vector endian-swap
)
287 #+big-endian
(declare (ignore vector
))
289 (:network-order
#+big-endian
0
290 #+little-endian
(1- (vector-elt-width vector
)))
296 (otherwise endian-swap
)))
299 (defun %read-vector
(vector stream start end endian-swap blocking
)
300 (declare (type (kernel:simple-unboxed-array
(*)) vector
)
301 (type stream stream
))
302 ;; move code from read-vector
306 (defun %write-vector
(... blocking
)
310 (defun read-octets (stream buffer start end blocking
)
311 (declare (type simple-stream stream
)
312 (type (or null simple-stream-buffer
) buffer
)
314 (type (or null fixnum
) end
)
315 (type blocking blocking
)
316 (optimize (speed 3) (space 2) (safety 0) (debug 0)))
317 (with-stream-class (simple-stream stream
)
318 (let ((fd (sm input-handle stream
))
319 (end (or end
(sm buf-len stream
)))
320 (buffer (or buffer
(sm buffer stream
))))
321 (declare (fixnum end
))
324 (let ((flag (sb-sys:wait-until-fd-usable fd
:input
325 (if blocking nil
0))))
327 ((and (not blocking
) (= start end
)) (if flag -
3 0))
328 ((and (not blocking
) (not flag
)) 0)
331 (declare (type fixnum count
))
334 ;; Avoid CMUCL gengc write barrier
335 (do ((i start
(+ i
(the fixnum
#.
(sb-posix:getpagesize
)))))
337 (declare (type fixnum i
))
338 (setf (bref buffer i
) 0))
339 (setf (bref buffer
(1- end
)) 0)
340 (multiple-value-bind (bytes errno
)
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-unix:unix-write fd
(buffer-sap buffer
) start
397 (format *debug-io
* "~&;; UNIX-WRITE: errno=~D~%" errno
)
398 (cond ((= errno sb-unix
:eintr
) (go again
))
399 ;; don't block for subsequent chars
400 (t (return (- -
10 errno
)))))
401 (t (return count
)))))))))))
402 (t (error "implement me"))))))
404 (defun do-some-output (stream)
405 ;; Do some pending output; return T if completed, NIL if more to do
406 (with-stream-class (simple-stream stream
)
407 (let ((fd (sm output-handle stream
)))
409 (let ((list (pop (sm pending stream
))))
411 (sb-sys:remove-fd-handler
(sm handler stream
))
412 (setf (sm handler stream
) nil
)
414 (let* ((buffer (first list
))
415 (start (second list
))
418 (declare (type simple-stream-buffer buffer
)
419 (type sb-int
:index start end len
))
421 (multiple-value-bind (bytes errno
)
422 (sb-unix:unix-write fd
(buffer-sap buffer
) start len
)
424 (if (= errno sb-unix
:eintr
)
426 (progn (push list
(sm pending stream
))
429 (setf (second list
) (+ start bytes
))
430 (push list
(sm pending stream
))
433 (free-buffer buffer
)))))))))))
435 (defun queue-write (stream buffer start end
)
436 ;; Queue a write; return T if buffer needs changing, NIL otherwise
437 (declare (type simple-stream stream
)
438 (type simple-stream-buffer buffer
)
439 (type sb-int
:index start end
))
440 (with-stream-class (simple-stream stream
)
441 (when (sm handler stream
)
442 (unless (do-some-output stream
)
443 (let ((last (last (sm pending stream
))))
444 (setf (cdr last
) (list (list buffer start end
)))
445 (return-from queue-write t
))))
446 (let ((bytes (write-octets stream buffer start end nil
)))
447 (unless (or (= bytes
(- end start
)) ; completed
448 (= bytes -
3)) ; empty buffer; shouldn't happen
449 (setf (sm pending stream
) (list (list buffer start end
)))
450 (setf (sm handler stream
)
451 (sb-sys:add-fd-handler
(sm output-handle stream
) :output
453 (declare (ignore fd
))
454 (do-some-output stream
))))
460 (defun %fd-open
(pathname direction if-exists if-exists-given
461 if-does-not-exist if-does-not-exist-given
)
462 (declare (type pathname pathname
)
463 (type (member :input
:output
:io
:probe
) direction
)
464 (type (member :error
:new-version
:rename
:rename-and-delete
465 :overwrite
:append
:supersede nil
) if-exists
)
466 (type (member :error
:create nil
) if-does-not-exist
))
467 (multiple-value-bind (input output mask
)
469 (:input
(values t nil sb-unix
:o_rdonly
))
470 (:output
(values nil t sb-unix
:o_wronly
))
471 (:io
(values t t sb-unix
:o_rdwr
))
472 (:probe
(values t nil sb-unix
:o_rdonly
)))
473 (declare (type sb-int
:index mask
))
474 (let ((name (cond ((sb-int:unix-namestring pathname input
))
475 ((and input
(eq if-does-not-exist
:create
))
476 (sb-int:unix-namestring pathname nil
))
477 ((and (eq direction
:io
) (not if-does-not-exist-given
))
478 (sb-int:unix-namestring pathname nil
)))))
479 ;; Process if-exists argument if we are doing any output.
481 (unless if-exists-given
483 (if (eq (pathname-version pathname
) :newest
)
487 ((:error nil
:new-version
)
488 (setf mask
(logior mask sb-unix
:o_excl
)))
489 ((:rename
:rename-and-delete
)
490 (setf mask
(logior mask sb-unix
:o_creat
)))
492 (setf mask
(logior mask sb-unix
:o_trunc
)))))
494 (setf if-exists nil
))) ; :ignore-this-arg
495 (unless if-does-not-exist-given
496 (setf if-does-not-exist
497 (cond ((eq direction
:input
) :error
)
499 (member if-exists
'(:overwrite
:append
)))
501 ((eq direction
:probe
)
505 (if (eq if-does-not-exist
:create
)
506 (setf mask
(logior mask sb-unix
:o_creat
)))
508 (let ((original (if (member if-exists
509 '(:rename
:rename-and-delete
))
510 (sb-impl::pick-backup-name name
)
512 (delete-original (eq if-exists
:rename-and-delete
))
515 ;; We are doing a :rename or :rename-and-delete.
516 ;; Determine if the file already exists, make sure the original
517 ;; file is not a directory and keep the mode
521 (okay err
/dev inode orig-mode
)
522 (sb-unix:unix-stat name
)
523 (declare (ignore inode
)
524 (type (or sb-int
:index null
) orig-mode
))
527 (when (and output
(= (logand orig-mode
#o170000
)
529 (error 'sb-int
:simple-file-error
532 "Cannot open ~S for output: Is a directory."
533 :format-arguments
(list name
)))
534 (setf mode
(logand orig-mode
#o777
))
536 ((eql err
/dev sb-unix
:enoent
)
539 (error 'sb-int
:simple-file-error
541 :format-control
"Cannot find ~S: ~A"
544 (sb-int:strerror err
/dev
)))))))))
546 (rename-file name original
))
548 (setf delete-original nil
)
549 ;; In order to use SUPERSEDE instead, we have
550 ;; to make sure unix:o_creat corresponds to
551 ;; if-does-not-exist. unix:o_creat was set
552 ;; before because of if-exists being :rename.
553 (unless (eq if-does-not-exist
:create
)
554 (setf mask
(logior (logandc2 mask sb-unix
:o_creat
)
556 (setf if-exists
:supersede
))))
558 ;; Okay, now we can try the actual open.
560 (multiple-value-bind (fd errno
)
562 (sb-unix:unix-open name mask mode
)
563 (values nil sb-unix
:enoent
))
564 (cond ((sb-int:fixnump fd
)
565 (when (eql if-exists
:append
)
566 (sb-unix:unix-lseek fd
0 sb-unix
:l_xtnd
))
567 (return (values fd name original delete-original
)))
568 ((eql errno sb-unix
:enoent
)
569 (case if-does-not-exist
571 (cerror "Return NIL."
572 'sb-int
:simple-file-error
574 :format-control
"Error opening ~S, ~A."
577 (sb-int:strerror errno
))))
579 (cerror "Return NIL."
580 'sb-int
:simple-file-error
583 "Error creating ~S, path does not exist."
584 :format-arguments
(list pathname
))))
586 ((eql errno sb-unix
:eexist
)
587 (unless (eq nil if-exists
)
588 (cerror "Return NIL."
589 'sb-int
:simple-file-error
591 :format-control
"Error opening ~S, ~A."
594 (sb-int:strerror errno
))))
596 #+nil
; FIXME: reinstate this; error reporting is nice.
597 ((eql errno sb-unix
:eacces
)
599 'sb-int
:simple-file-error
601 :format-control
"Error opening ~S, ~A."
604 (sb-int:strerror errno
))))
606 (cerror "Return NIL."
607 'sb-int
:simple-file-error
609 :format-control
"Error opening ~S, ~A."
612 (sb-int:strerror errno
)))
615 (defun open-fd-stream (pathname &key
(direction :input
)
616 (element-type 'base-char
)
617 (if-exists nil if-exists-given
)
618 (if-does-not-exist nil if-does-not-exist-given
)
619 (external-format :default
))
620 (declare (type (or pathname string stream
) pathname
)
621 (type (member :input
:output
:io
:probe
) direction
)
622 (type (member :error
:new-version
:rename
:rename-and-delete
623 :overwrite
:append
:supersede nil
) if-exists
)
624 (type (member :error
:create nil
) if-does-not-exist
)
625 (ignore external-format
))
626 (let ((filespec (merge-pathnames pathname
)))
627 (multiple-value-bind (fd namestring original delete-original
)
628 (%fd-open filespec direction if-exists if-exists-given
629 if-does-not-exist if-does-not-exist-given
)
632 ((:input
:output
:io
)
633 (sb-sys:make-fd-stream fd
634 :input
(member direction
'(:input
:io
))
635 :output
(member direction
'(:output
:io
))
636 :element-type element-type
639 :delete-original delete-original
645 (let ((stream (sb-impl::%make-fd-stream
:name namestring
:fd fd
647 :element-type element-type
)))
652 ;; Experimental "filespec" stuff
654 ;; sat: Hooks to parse URIs etc apparently go here
656 (defstruct (filespec-parser
657 (:constructor make-filespec-parser
(name priority function
)))
662 (defvar *filespec-parsers
* ())
664 (defun add-filespec (name priority function
)
665 (let ((filespec (make-filespec-parser name priority function
)))
666 (setf *filespec-parsers
*
667 (stable-sort (cons filespec
(delete name
*filespec-parsers
*
668 :key
#'filespec-parser-name
))
670 :key
#'filespec-parser-priority
)))
673 (defmacro define-filespec
(name lambda-list
&body body
)
674 (let ((truename (if (consp name
) (first name
) name
))
675 (priority (if (consp name
) (second name
) 0)))
676 `(add-filespec ',truename
,priority
(lambda ,lambda-list
680 (defun parse-filespec (string &optional
(errorp t
))
681 (dolist (i *filespec-parsers
* (when errorp
682 (error "~S not recognised." string
)))
683 (let ((result (ignore-errors
684 (funcall (filespec-parser-function i
) string
))))
685 (when result
(return result
)))))
687 (define-filespec pathname
(string)