1 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*-
3 ;;; This code is in the public domain.
5 ;;; The cmucl implementation of simple-streams was done by Paul Foley,
6 ;;; who placed the code in the public domain. Sbcl port by Rudi
9 (in-package "SB-SIMPLE-STREAMS")
15 ;; All known stream flags. Note that the position in the constant
16 ;; list is significant (cf. %flags below).
17 (sb-int:defconstant-eqx +flag-bits+
18 '(:simple ; instance is valid
19 :input :output ; direction
20 :dual :string ; type of stream
22 :dirty ; output buffer needs write
23 :interactive) ; interactive stream
26 (eval-when (:compile-toplevel :load-toplevel :execute)
28 (loop for flag in flags
29 as pos = (position flag +flag-bits+)
30 when (eq flag :gray) do
31 (error "Gray streams not supported.")
33 sum (ash 1 pos) into bits
35 collect flag into unused
37 (warn "Invalid stream instance flag~P: ~{~S~^, ~}"
38 (length unused) unused))
41 ;;; Setup an environment where sm, funcall-stm-handler and
42 ;;; funcall-stm-handler-2 are valid and efficient for a stream of type
43 ;;; class-name or for the stream argument (in which case the
44 ;;; class-name argument is ignored). In nested with-stream-class
45 ;;; forms, the inner with-stream-class form must specify a stream
46 ;;; argument if the outer one specifies one, or the wrong object will
48 (defmacro with-stream-class ((class-name &optional stream) &body body)
50 (let ((stm (gensym "STREAM"))
52 `(let* ((,stm ,stream)
53 (,slt (sb-pcl::std-instance-slots ,stm)))
54 (declare (type ,class-name ,stm) (ignorable ,slt))
55 (macrolet ((sm (slot-name stream)
56 (declare (ignore stream))
57 (let ((slot-access (gethash slot-name
58 *slot-access-functions*)))
59 (cond ((sb-int:fixnump (cdr slot-access))
60 ;; Get value in nth slot
61 `(the ,(car slot-access)
62 (sb-pcl::clos-slots-ref ,',slt
65 ;; Call memorized function
66 `(the ,(car slot-access) (,(cdr slot-access)
70 `(slot-value ,',stm ',slot-name)))))
71 (add-stream-instance-flags (stream &rest flags)
72 (declare (ignore stream))
73 `(setf (sm %flags ,',stm) (logior (sm %flags ,',stm)
75 (remove-stream-instance-flags (stream &rest flags)
76 (declare (ignore stream))
77 `(setf (sm %flags ,',stm) (logandc2 (sm %flags ,',stm)
79 (any-stream-instance-flags (stream &rest flags)
80 (declare (ignore stream))
81 `(not (zerop (logand (sm %flags ,',stm)
84 `(macrolet ((sm (slot-name stream)
85 (let ((slot-access (gethash slot-name
86 *slot-access-functions*)))
87 (cond ((sb-int:fixnump (cdr slot-access))
88 `(the ,(car slot-access)
89 (sb-pcl::clos-slots-ref
90 (sb-pcl::std-instance-slots ,stream)
93 `(the ,(car slot-access) (,(cdr slot-access)
95 (t `(slot-value ,stream ',slot-name))))))
98 (defmacro sm (slot-name stream)
99 (let ((slot-access (gethash slot-name *slot-access-functions*)))
100 (warn "Using ~S macro outside ~S" 'sm 'with-stream-class)
101 (cond ((sb-int:fixnump (cdr slot-access))
102 `(the ,(car slot-access) (sb-pcl::clos-slots-ref
103 (sb-pcl::std-instance-slots ,stream)
104 ,(cdr slot-access))))
106 `(the ,(car slot-access) (,(cdr slot-access) ,stream)))
107 (t `(slot-value ,stream ',slot-name)))))
109 (defmacro funcall-stm-handler (slot-name stream &rest args)
112 (funcall (sm ,slot-name ,s) ,s ,@args))))
114 (defmacro funcall-stm-handler-2 (slot-name arg1 stream &rest args)
117 (funcall (sm ,slot-name ,s) ,arg1 ,s ,@args))))
119 (defmacro add-stream-instance-flags (stream &rest flags)
120 "Set the given flag bits in STREAM."
121 (let ((s (gensym "STREAM")))
123 (with-stream-class (simple-stream ,s)
124 (setf (sm %flags ,s) (logior (sm %flags ,s) ,(%flags flags)))))))
126 (defmacro remove-stream-instance-flags (stream &rest flags)
127 "Clear the given flag bits in STREAM."
128 (let ((s (gensym "STREAM")))
130 (with-stream-class (simple-stream ,s)
131 (setf (sm %flags ,s) (logandc2 (sm %flags ,s) ,(%flags flags)))))))
133 (defmacro any-stream-instance-flags (stream &rest flags)
134 "Determine whether any one of the FLAGS is set in STREAM."
135 (let ((s (gensym "STREAM")))
137 (with-stream-class (simple-stream ,s)
138 (not (zerop (logand (sm %flags ,s) ,(%flags flags))))))))
141 (declaim (inline buffer-sap bref (setf bref) buffer-copy))
143 (defun buffer-sap (thing &optional offset)
144 (declare (type simple-stream-buffer thing) (type (or fixnum null) offset)
145 (optimize (speed 3) (space 2) (debug 0) (safety 0)
146 ;; Suppress the note about having to box up the return:
147 (sb-ext:inhibit-warnings 3)))
148 (let ((sap (if (vectorp thing) (sb-sys:vector-sap thing) thing)))
149 (if offset (sb-sys:sap+ sap offset) sap)))
151 (defun bref (buffer index)
152 (declare (type simple-stream-buffer buffer)
153 (type (integer 0 #.most-positive-fixnum) index))
154 (sb-sys:sap-ref-8 (buffer-sap buffer) index))
156 (defun (setf bref) (octet buffer index)
157 (declare (type (unsigned-byte 8) octet)
158 (type simple-stream-buffer buffer)
159 (type (integer 0 #.most-positive-fixnum) index))
160 (setf (sb-sys:sap-ref-8 (buffer-sap buffer) index) octet))
162 (defun buffer-copy (src soff dst doff length)
163 (declare (type simple-stream-buffer src dst)
164 (type fixnum soff doff length))
165 (sb-sys:without-gcing ;; is this necessary??
166 (sb-kernel:system-area-copy (buffer-sap src) (* soff 8)
167 (buffer-sap dst) (* doff 8)
170 (defun allocate-buffer (size)
171 (if (= size sb-impl::bytes-per-buffer)
172 (sb-impl::next-available-buffer)
173 (make-array size :element-type '(unsigned-byte 8))))
175 (defun free-buffer (buffer)
176 (when (not (vectorp buffer))
177 (push buffer sb-impl::*available-buffers*))
180 (defun %fd-open (pathname direction if-exists if-exists-given
181 if-does-not-exist if-does-not-exist-given)
182 (declare (type pathname pathname)
183 (type (member :input :output :io :probe) direction)
184 (type (member :error :new-version :rename :rename-and-delete
185 :overwrite :append :supersede nil) if-exists)
186 (type (member :error :create nil) if-does-not-exist))
187 (multiple-value-bind (input output mask)
189 (:input (values t nil sb-unix:o_rdonly))
190 (:output (values nil t sb-unix:o_wronly))
191 (:io (values t t sb-unix:o_rdwr))
192 (:probe (values t nil sb-unix:o_rdonly)))
193 (declare (type sb-int:index mask))
194 (let ((name (cond ((sb-int:unix-namestring pathname input))
195 ((and input (eq if-does-not-exist :create))
196 (sb-int:unix-namestring pathname nil)))))
197 ;; Process if-exists argument if we are doing any output.
199 (unless if-exists-given
201 (if (eq (pathname-version pathname) :newest)
206 (setf mask (logior mask sb-unix:o_excl)))
207 ((:rename :rename-and-delete)
208 (setf mask (logior mask sb-unix:o_creat)))
209 ((:new-version :supersede)
210 (setf mask (logior mask sb-unix:o_trunc)))
212 (setf mask (logior mask sb-unix:o_append)))))
214 (setf if-exists nil))) ; :ignore-this-arg
215 (unless if-does-not-exist-given
216 (setf if-does-not-exist
217 (cond ((eq direction :input) :error)
219 (member if-exists '(:overwrite :append)))
221 ((eq direction :probe)
225 (if (eq if-does-not-exist :create)
226 (setf mask (logior mask sb-unix:o_creat)))
228 (let ((original (if (member if-exists
229 '(:rename :rename-and-delete))
230 (sb-impl::pick-backup-name name)
232 (delete-original (eq if-exists :rename-and-delete))
235 ;; We are doing a :rename or :rename-and-delete.
236 ;; Determine if the file already exists, make sure the original
237 ;; file is not a directory and keep the mode
241 (okay err/dev inode orig-mode)
242 (sb-unix:unix-stat name)
243 (declare (ignore inode)
244 (type (or sb-int:index null) orig-mode))
247 (when (and output (= (logand orig-mode #o170000)
249 (error 'sb-int:simple-file-error
252 "Cannot open ~S for output: Is a directory."
253 :format-arguments (list name)))
254 (setf mode (logand orig-mode #o777))
256 ((eql err/dev sb-unix:enoent)
259 (error 'sb-int:simple-file-error
261 :format-control "Cannot find ~S: ~A"
264 (sb-int:strerror err/dev)))))))))
266 (rename-file name original))
268 (setf delete-original nil)
269 ;; In order to use SUPERSEDE instead, we have
270 ;; to make sure unix:o_creat corresponds to
271 ;; if-does-not-exist. unix:o_creat was set
272 ;; before because of if-exists being :rename.
273 (unless (eq if-does-not-exist :create)
274 (setf mask (logior (logandc2 mask sb-unix:o_creat)
276 (setf if-exists :supersede))))
278 ;; Okay, now we can try the actual open.
280 (multiple-value-bind (fd errno)
282 (sb-unix:unix-open name mask mode)
283 (values nil sb-unix:enoent))
284 (cond ((sb-int:fixnump fd)
285 (return (values fd name original delete-original)))
286 ((eql errno sb-unix:enoent)
287 (case if-does-not-exist
289 (cerror "Return NIL."
290 'sb-int:simple-file-error
292 :format-control "Error opening ~S, ~A."
295 (sb-int:strerror errno))))
297 (cerror "Return NIL."
298 'sb-int:simple-file-error
301 "Error creating ~S, path does not exist."
302 :format-arguments (list pathname))))
304 ((eql errno sb-unix:eexist)
305 (unless (eq nil if-exists)
306 (cerror "Return NIL."
307 'sb-int:simple-file-error
309 :format-control "Error opening ~S, ~A."
312 (sb-int:strerror errno))))
314 #+nil ; FIXME: reinstate this; error reporting is nice.
315 ((eql errno sb-unix:eacces)
317 'sb-int:simple-file-error
319 :format-control "Error opening ~S, ~A."
322 (sb-int:strerror errno))))
324 (cerror "Return NIL."
325 'sb-int:simple-file-error
327 :format-control "Error opening ~S, ~A."
330 (sb-int:strerror errno)))
333 (defun open-fd-stream (pathname &key (direction :input)
334 (element-type 'base-char)
335 (if-exists nil if-exists-given)
336 (if-does-not-exist nil if-does-not-exist-given)
337 (external-format :default))
338 (declare (type (or pathname string stream) pathname)
339 (type (member :input :output :io :probe) direction)
340 (type (member :error :new-version :rename :rename-and-delete
341 :overwrite :append :supersede nil) if-exists)
342 (type (member :error :create nil) if-does-not-exist)
343 (ignore external-format))
344 (setq pathname (pathname pathname))
345 (multiple-value-bind (fd namestring original delete-original)
346 (%fd-open pathname direction if-exists if-exists-given
347 if-does-not-exist if-does-not-exist-given)
350 ((:input :output :io)
351 (sb-sys:make-fd-stream fd
352 :input (member direction '(:input :io))
353 :output (member direction '(:output :io))
354 :element-type element-type
357 :delete-original delete-original
362 (let ((stream (sb-impl::%make-fd-stream :name namestring :fd fd
364 :element-type element-type)))
369 ;; Make PATHNAME and NAMESTRING work
370 (defun cl::file-name (stream &optional new-name)
373 (with-stream-class (file-simple-stream stream)
375 (setf (sm pathname stream) new-name)
376 (setf (sm filename stream) (sb-int:unix-namestring new-name nil))
379 (sm pathname stream)))))
382 (setf (sb-impl::fd-stream-pathname stream) new-name)
383 (setf (sb-impl::fd-stream-file stream)
384 (sb-int:unix-namestring new-name nil))
387 (sb-impl::fd-stream-pathname stream))))))
389 ;; Experimental "filespec" stuff
391 ;; sat: Hooks to parse URIs etc apparently go here
393 (defstruct (filespec-parser
394 (:constructor make-filespec-parser (name priority function)))
399 (defvar *filespec-parsers* ())
401 (defun add-filespec (name priority function)
402 (let ((filespec (make-filespec-parser name priority function)))
403 (setf *filespec-parsers*
404 (stable-sort (cons filespec (delete name *filespec-parsers*
405 :key #'filespec-parser-name))
407 :key #'filespec-parser-priority)))
410 (defmacro define-filespec (name lambda-list &body body)
411 (let ((truename (if (consp name) (first name) name))
412 (priority (if (consp name) (second name) 0)))
413 `(add-filespec ',truename ,priority (lambda ,lambda-list
417 (defun parse-filespec (string &optional (errorp t))
418 (dolist (i *filespec-parsers* (when errorp
419 (error "~S not recognised." string)))
420 (let ((result (ignore-errors
421 (funcall (filespec-parser-function i) string))))
422 (when result (return result)))))
424 (define-filespec pathname (string)