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-copy (buffer-sap src) (* soff 8)
47 (buffer-sap dst) (* doff 8)
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 (setf (sm charpos stream) -1) ;; set to 0 "if reading" ???
89 (defvar *std-control-out-table*
90 (make-control-table #\Newline #'std-newline-out-handler
91 #\Tab #'std-tab-out-handler))
93 (defvar *default-external-format* :iso8859-1)
95 (defvar *external-formats* (make-hash-table))
96 (defvar *external-format-aliases* (make-hash-table))
98 (defstruct (external-format
100 (:print-function %print-external-format)
101 (:constructor make-external-format (name octets-to-char
103 (name (sb-int:missing-arg) :type keyword :read-only t)
104 (octets-to-char (sb-int:missing-arg) :type function :read-only t)
105 (char-to-octets (sb-int:missing-arg) :type function :read-only t))
107 (defun %print-external-format (ef stream depth)
108 (declare (ignore depth))
109 (print-unreadable-object (ef stream :type t :identity t)
110 (princ (ef-name ef) stream)))
112 (defmacro define-external-format (name octets-to-char char-to-octets)
113 `(macrolet ((octets-to-char ((state input unput) &body body)
114 `(lambda (,state ,input ,unput)
115 (declare (type (function () (unsigned-byte 8)) ,input)
116 (type (function (sb-int:index) t) ,unput)
117 (ignorable ,state ,input ,unput)
118 (values character sb-int:index t))
120 (char-to-octets ((char state output) &body body)
121 `(lambda (,char ,state ,output)
122 (declare (type character ,char)
123 (type (function ((unsigned-byte 8)) t) ,output)
124 (ignorable state ,output)
127 (setf (gethash ,name *external-formats*)
128 (make-external-format ,name ,octets-to-char ,char-to-octets))))
130 ;;; TODO: make this work
131 (defun load-external-format-aliases ()
132 (let ((*package* (find-package "KEYWORD")))
133 (with-open-file (stm "ef:aliases" :if-does-not-exist nil)
135 (do ((alias (read stm nil stm) (read stm nil stm))
136 (value (read stm nil stm) (read stm nil stm)))
137 ((or (eq alias stm) (eq value stm))
138 (unless (eq alias stm)
139 (warn "External-format aliases file ends early.")))
140 (if (and (keywordp alias) (keywordp value))
141 (setf (gethash alias *external-format-aliases*) value)
142 (warn "Bad entry in external-format aliases file: ~S => ~S."
145 (defun find-external-format (name &optional (error-p t))
146 (when (external-format-p name)
147 (return-from find-external-format name))
149 (when (eq name :default)
150 (setq name *default-external-format*))
152 ;; TODO: make this work
154 (unless (ext:search-list-defined-p "ef:")
155 (setf (ext:search-list "ef:") '("library:ef/")))
157 (when (zerop (hash-table-count *external-format-aliases*))
158 (setf (gethash :latin1 *external-format-aliases*) :iso8859-1)
159 (setf (gethash :latin-1 *external-format-aliases*) :iso8859-1)
160 (setf (gethash :iso-8859-1 *external-format-aliases*) :iso8859-1)
161 (load-external-format-aliases))
163 (do ((tmp (gethash name *external-format-aliases*)
164 (gethash tmp *external-format-aliases*))
166 ((or (null tmp) (= cnt 50))
168 (error "External-format aliasing depth exceeded.")))
171 (or (gethash name *external-formats*)
172 (and (let ((*package* (find-package "SB-SIMPLE-STREAMS")))
173 (load (format nil "ef:~(~A~)" name) :if-does-not-exist nil))
174 (gethash name *external-formats*))
175 (if error-p (error "External format ~S not found." name) nil)))
177 (define-condition void-external-format (error)
180 (lambda (condition stream)
181 (declare (ignore condition))
182 (format stream "Attempting I/O through void external-format."))))
184 (define-external-format :void
185 (octets-to-char (state input unput)
186 (declare (ignore state input unput))
187 (error 'void-external-format))
188 (char-to-octets (char state output)
189 (declare (ignore char state output))
190 (error 'void-external-format)))
192 (define-external-format :iso8859-1
193 (octets-to-char (state input unput)
194 (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
195 (values (code-char (funcall input)) 1 state))
196 (char-to-octets (char state output)
197 (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
198 (let ((code (char-code char)))
200 (funcall output code)
203 (funcall output code)
204 (funcall output (char-code #\?))))
207 (defmacro octets-to-char (external-format state count input unput)
208 (let ((tmp1 (gensym)) (tmp2 (gensym)) (tmp3 (gensym)))
209 `(multiple-value-bind (,tmp1 ,tmp2 ,tmp3)
210 (funcall (ef-octets-to-char ,external-format) ,state ,input ,unput)
211 (setf ,state ,tmp3 ,count ,tmp2)
214 (defmacro char-to-octets (external-format char state output)
216 (setf ,state (funcall (ef-char-to-octets ,external-format)
217 ,char ,state ,output))
220 (defun string-to-octets (string &key (start 0) end (external-format :default))
221 (declare (type string string)
222 (type sb-int:index start)
223 (type (or null sb-int:index) end))
224 (let ((ef (find-external-format external-format))
225 (buffer (make-array (length string) :element-type '(unsigned-byte 8)))
229 (setf (aref buffer ptr) b)
230 (when (= (incf ptr) (length buffer))
231 (setq buffer (adjust-array buffer (* 2 ptr))))))
232 (dotimes (i (- (or end (length string)) start))
233 (declare (type sb-int:index i))
234 (char-to-octets ef (char string (+ start i)) state #'out))
235 (sb-kernel:shrink-vector buffer ptr))))
237 (defun octets-to-string (octets &key (start 0) end (external-format :default))
238 (declare (type vector octets)
239 (type sb-int:index start)
240 (type (or null sb-int:index) end))
241 (let ((ef (find-external-format external-format))
242 (end (1- (or end (length octets))))
243 (string (make-string (length octets)))
249 (aref octets (incf ptr)))
252 (loop until (>= ptr end)
253 do (setf (schar string (incf pos))
254 (octets-to-char ef state count #'input #'unput))))
255 (sb-kernel:shrink-vector string (1+ pos))))
257 (defun vector-elt-width (vector)
258 ;; Return octet-width of vector elements
260 ;; (simple-array fixnum (*)) not supported
261 ;; (simple-array base-char (*)) treated specially; don't call this
262 ((simple-array bit (*)) 1)
263 ((simple-array (unsigned-byte 2) (*)) 1)
264 ((simple-array (unsigned-byte 4) (*)) 1)
265 ((simple-array (signed-byte 8) (*)) 1)
266 ((simple-array (unsigned-byte 8) (*)) 1)
267 ((simple-array (signed-byte 16) (*)) 2)
268 ((simple-array (unsigned-byte 16) (*)) 2)
269 ((simple-array (signed-byte 32) (*)) 4)
270 ((simple-array (unsigned-byte 32) (*)) 4)
271 ((simple-array single-float (*)) 4)
272 ((simple-array double-float (*)) 8)
273 ((simple-array (complex single-float) (*)) 8)
274 ((simple-array (complex double-float) (*)) 16)))
276 #-(or big-endian little-endian)
277 (eval-when (:compile-toplevel)
278 (push sb-c::*backend-byte-order* *features*))
280 (defun endian-swap-value (vector endian-swap)
281 #+big-endian (declare (ignore vector))
283 (:network-order #+big-endian 0
284 #+little-endian (1- (vector-elt-width vector)))
290 (otherwise endian-swap)))
293 (defun %read-vector (vector stream start end endian-swap blocking)
294 (declare (type (kernel:simple-unboxed-array (*)) vector)
295 (type stream stream))
296 ;; move code from read-vector
300 (defun %write-vector (... blocking)
304 (defun read-octets (stream buffer start end blocking)
305 (declare (type simple-stream stream)
306 (type (or null simple-stream-buffer) buffer)
308 (type (or null fixnum) end)
309 (type blocking blocking)
310 (optimize (speed 3) (space 2) (safety 0) (debug 0)))
311 (with-stream-class (simple-stream stream)
312 (let ((fd (sm input-handle stream))
313 (end (or end (sm buf-len stream)))
314 (buffer (or buffer (sm buffer stream))))
315 (declare (fixnum end))
318 (let ((flag (sb-sys:wait-until-fd-usable fd :input
319 (if blocking nil 0))))
321 ((and (not blocking) (= start end)) (if flag -3 0))
322 ((and (not blocking) (not flag)) 0)
325 (declare (type fixnum count))
328 ;; Avoid CMUCL gengc write barrier
329 (do ((i start (+ i (the fixnum #.(sb-posix:getpagesize)))))
331 (declare (type fixnum i))
332 (setf (bref buffer i) 0))
333 (setf (bref buffer (1- end)) 0)
334 (multiple-value-bind (bytes errno)
335 (sb-unix:unix-read fd (buffer-sap buffer start)
336 (the fixnum (- end start)))
337 (declare (type (or null fixnum) bytes)
338 (type (integer 0 100) errno))
343 (format *debug-io* "~&;; UNIX-READ: errno=~D~%" errno)
344 (cond ((= errno sb-unix:eintr) (go again))
346 (or (= errno ;;sb-unix:eagain
351 (= errno sb-unix:ewouldblock)))
352 (sb-sys:wait-until-fd-usable fd :input nil)
354 (t (return (- -10 errno)))))
355 ((zerop count) (return -1))
356 (t (return count)))))))))))
357 (t (%read-vector buffer fd start end :byte-8
358 (if blocking :bnb nil)))))))
360 (defun write-octets (stream buffer start end blocking)
361 (declare (type simple-stream stream)
362 (type simple-stream-buffer buffer)
364 (type (or null fixnum) end))
365 (with-stream-class (simple-stream stream)
366 (when (sm handler stream)
368 ((null (sm pending stream)))
369 (sb-sys:serve-all-events)))
371 (let ((fd (sm output-handle stream))
372 (end (or end (length buffer))))
375 (let ((flag (sb-sys:wait-until-fd-usable fd :output
376 (if blocking nil 0))))
378 ((and (not blocking) (= start end)) (if flag -3 0))
379 ((and (not blocking) (not flag)) 0)
384 (multiple-value-bind (bytes errno)
385 (sb-unix:unix-write fd (buffer-sap buffer) start
391 (format *debug-io* "~&;; UNIX-WRITE: errno=~D~%" errno)
392 (cond ((= errno sb-unix:eintr) (go again))
393 ;; don't block for subsequent chars
394 (t (return (- -10 errno)))))
395 (t (return count)))))))))))
396 (t (error "implement me"))))))
398 (defun do-some-output (stream)
399 ;; Do some pending output; return T if completed, NIL if more to do
400 (with-stream-class (simple-stream stream)
401 (let ((fd (sm output-handle stream)))
403 (let ((list (pop (sm pending stream))))
405 (sb-sys:remove-fd-handler (sm handler stream))
406 (setf (sm handler stream) nil)
408 (let* ((buffer (first list))
409 (start (second list))
412 (declare (type simple-stream-buffer buffer)
413 (type sb-int:index start end len))
415 (multiple-value-bind (bytes errno)
416 (sb-unix:unix-write fd (buffer-sap buffer) start len)
418 (if (= errno sb-unix:eintr)
420 (progn (push list (sm pending stream))
423 (setf (second list) (+ start bytes))
424 (push list (sm pending stream))
427 (free-buffer buffer)))))))))))
429 (defun queue-write (stream buffer start end)
430 ;; Queue a write; return T if buffer needs changing, NIL otherwise
431 (declare (type simple-stream stream)
432 (type simple-stream-buffer buffer)
433 (type sb-int:index start end))
434 (with-stream-class (simple-stream stream)
435 (when (sm handler stream)
436 (unless (do-some-output stream)
437 (let ((last (last (sm pending stream))))
438 (setf (cdr last) (list (list buffer start end)))
439 (return-from queue-write t))))
440 (let ((bytes (write-octets stream buffer start end nil)))
441 (unless (or (= bytes (- end start)) ; completed
442 (= bytes -3)) ; empty buffer; shouldn't happen
443 (setf (sm pending stream) (list (list buffer start end)))
444 (setf (sm handler stream)
445 (sb-sys:add-fd-handler (sm output-handle stream) :output
447 (declare (ignore fd))
448 (do-some-output stream))))
454 (defun %fd-open (pathname direction if-exists if-exists-given
455 if-does-not-exist if-does-not-exist-given)
456 (declare (type pathname pathname)
457 (type (member :input :output :io :probe) direction)
458 (type (member :error :new-version :rename :rename-and-delete
459 :overwrite :append :supersede nil) if-exists)
460 (type (member :error :create nil) if-does-not-exist))
461 (multiple-value-bind (input output mask)
463 (:input (values t nil sb-unix:o_rdonly))
464 (:output (values nil t sb-unix:o_wronly))
465 (:io (values t t sb-unix:o_rdwr))
466 (:probe (values t nil sb-unix:o_rdonly)))
467 (declare (type sb-int:index mask))
468 (let ((name (cond ((sb-int:unix-namestring pathname input))
469 ((and input (eq if-does-not-exist :create))
470 (sb-int:unix-namestring pathname nil)))))
471 ;; Process if-exists argument if we are doing any output.
473 (unless if-exists-given
475 (if (eq (pathname-version pathname) :newest)
480 (setf mask (logior mask sb-unix:o_excl)))
481 ((:rename :rename-and-delete)
482 (setf mask (logior mask sb-unix:o_creat)))
483 ((:new-version :supersede)
484 (setf mask (logior mask sb-unix:o_trunc)))))
486 (setf if-exists nil))) ; :ignore-this-arg
487 (unless if-does-not-exist-given
488 (setf if-does-not-exist
489 (cond ((eq direction :input) :error)
491 (member if-exists '(:overwrite :append)))
493 ((eq direction :probe)
497 (if (eq if-does-not-exist :create)
498 (setf mask (logior mask sb-unix:o_creat)))
500 (let ((original (if (member if-exists
501 '(:rename :rename-and-delete))
502 (sb-impl::pick-backup-name name)
504 (delete-original (eq if-exists :rename-and-delete))
507 ;; We are doing a :rename or :rename-and-delete.
508 ;; Determine if the file already exists, make sure the original
509 ;; file is not a directory and keep the mode
513 (okay err/dev inode orig-mode)
514 (sb-unix:unix-stat name)
515 (declare (ignore inode)
516 (type (or sb-int:index null) orig-mode))
519 (when (and output (= (logand orig-mode #o170000)
521 (error 'sb-int:simple-file-error
524 "Cannot open ~S for output: Is a directory."
525 :format-arguments (list name)))
526 (setf mode (logand orig-mode #o777))
528 ((eql err/dev sb-unix:enoent)
531 (error 'sb-int:simple-file-error
533 :format-control "Cannot find ~S: ~A"
536 (sb-int:strerror err/dev)))))))))
538 (rename-file name original))
540 (setf delete-original nil)
541 ;; In order to use SUPERSEDE instead, we have
542 ;; to make sure unix:o_creat corresponds to
543 ;; if-does-not-exist. unix:o_creat was set
544 ;; before because of if-exists being :rename.
545 (unless (eq if-does-not-exist :create)
546 (setf mask (logior (logandc2 mask sb-unix:o_creat)
548 (setf if-exists :supersede))))
550 ;; Okay, now we can try the actual open.
552 (multiple-value-bind (fd errno)
554 (sb-unix:unix-open name mask mode)
555 (values nil sb-unix:enoent))
556 (cond ((sb-int:fixnump fd)
557 (when (eql if-exists :append)
558 (sb-unix:unix-lseek fd 0 sb-unix:l_xtnd))
559 (return (values fd name original delete-original)))
560 ((eql errno sb-unix:enoent)
561 (case if-does-not-exist
563 (cerror "Return NIL."
564 'sb-int:simple-file-error
566 :format-control "Error opening ~S, ~A."
569 (sb-int:strerror errno))))
571 (cerror "Return NIL."
572 'sb-int:simple-file-error
575 "Error creating ~S, path does not exist."
576 :format-arguments (list pathname))))
578 ((eql errno sb-unix:eexist)
579 (unless (eq nil if-exists)
580 (cerror "Return NIL."
581 'sb-int:simple-file-error
583 :format-control "Error opening ~S, ~A."
586 (sb-int:strerror errno))))
588 #+nil ; FIXME: reinstate this; error reporting is nice.
589 ((eql errno sb-unix:eacces)
591 'sb-int:simple-file-error
593 :format-control "Error opening ~S, ~A."
596 (sb-int:strerror errno))))
598 (cerror "Return NIL."
599 'sb-int:simple-file-error
601 :format-control "Error opening ~S, ~A."
604 (sb-int:strerror errno)))
607 (defun open-fd-stream (pathname &key (direction :input)
608 (element-type 'base-char)
609 (if-exists nil if-exists-given)
610 (if-does-not-exist nil if-does-not-exist-given)
611 (external-format :default))
612 (declare (type (or pathname string stream) pathname)
613 (type (member :input :output :io :probe) direction)
614 (type (member :error :new-version :rename :rename-and-delete
615 :overwrite :append :supersede nil) if-exists)
616 (type (member :error :create nil) if-does-not-exist)
617 (ignore external-format))
618 (let ((filespec (merge-pathnames pathname)))
619 (multiple-value-bind (fd namestring original delete-original)
620 (%fd-open filespec direction if-exists if-exists-given
621 if-does-not-exist if-does-not-exist-given)
624 ((:input :output :io)
625 (sb-sys:make-fd-stream fd
626 :input (member direction '(:input :io))
627 :output (member direction '(:output :io))
628 :element-type element-type
631 :delete-original delete-original
636 (let ((stream (sb-impl::%make-fd-stream :name namestring :fd fd
638 :element-type element-type)))
643 ;; Experimental "filespec" stuff
645 ;; sat: Hooks to parse URIs etc apparently go here
647 (defstruct (filespec-parser
648 (:constructor make-filespec-parser (name priority function)))
653 (defvar *filespec-parsers* ())
655 (defun add-filespec (name priority function)
656 (let ((filespec (make-filespec-parser name priority function)))
657 (setf *filespec-parsers*
658 (stable-sort (cons filespec (delete name *filespec-parsers*
659 :key #'filespec-parser-name))
661 :key #'filespec-parser-priority)))
664 (defmacro define-filespec (name lambda-list &body body)
665 (let ((truename (if (consp name) (first name) name))
666 (priority (if (consp name) (second name) 0)))
667 `(add-filespec ',truename ,priority (lambda ,lambda-list
671 (defun parse-filespec (string &optional (errorp t))
672 (dolist (i *filespec-parsers* (when errorp
673 (error "~S not recognised." string)))
674 (let ((result (ignore-errors
675 (funcall (filespec-parser-function i) string))))
676 (when result (return result)))))
678 (define-filespec pathname (string)