contrib/sb-simple-streams/internal.lisp

   1 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*-
   2
   3 ;;; This code is in the public domain.
   4
   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
   7 ;;; Schlatte.
   8
   9 (in-package "SB-SIMPLE-STREAMS")
  10
  11 ;;;
  12 ;;; HELPER FUNCTIONS
  13 ;;;
  14
  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
  21                           :eof          ; latched EOF
  22                           :dirty        ; output buffer needs write
  23                           :interactive) ; interactive stream
  24                         #'equal)
  25
  26 (eval-when (:compile-toplevel :load-toplevel :execute)
  27   (defun %flags (flags)
  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.")
  32         if pos
  33           sum (ash 1 pos) into bits
  34         else
  35           collect flag into unused
  36       finally (when unused
  37                 (warn "Invalid stream instance flag~P: ~{~S~^, ~}"
  38                       (length unused) unused))
  39               (return bits))))
  40
  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
  47 ;;; be accessed.
  48 (defmacro with-stream-class ((class-name &optional stream) &body body)
  49   (if stream
  50       (let ((stm (gensym "STREAM"))
  51             (slt (gensym)))
  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
  63                                                             ,(cdr slot-access))))
  64                                 (slot-access
  65                                  ;; Call memorized function
  66                                  `(the ,(car slot-access) (,(cdr slot-access)
  67                                                             ,',stm)))
  68                                 (t
  69                                  ;; Use slot-value
  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)
  74                                                           ,(%flags flags))))
  75                       (remove-stream-instance-flags (stream &rest flags)
  76                         (declare (ignore stream))
  77                         `(setf (sm %flags ,',stm) (logandc2 (sm %flags ,',stm)
  78                                                             ,(%flags flags))))
  79                       (any-stream-instance-flags (stream &rest flags)
  80                         (declare (ignore stream))
  81                         `(not (zerop (logand (sm %flags ,',stm)
  82                                              ,(%flags flags))))))
  83              ,@body)))
  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)
  91                                  ,(cdr slot-access))))
  92                             (slot-access
  93                              `(the ,(car slot-access) (,(cdr slot-access)
  94                                                         ,stream)))
  95                             (t `(slot-value ,stream ',slot-name))))))
  96          ,@body)))
  97
  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))))
 105           (slot-access
 106            `(the ,(car slot-access) (,(cdr slot-access) ,stream)))
 107           (t `(slot-value ,stream ',slot-name)))))
 108
 109 (defmacro funcall-stm-handler (slot-name stream &rest args)
 110   (let ((s (gensym)))
 111     `(let ((,s ,stream))
 112        (funcall (sm ,slot-name ,s) ,s ,@args))))
 113
 114 (defmacro funcall-stm-handler-2 (slot-name arg1 stream &rest args)
 115   (let ((s (gensym)))
 116     `(let ((,s ,stream))
 117        (funcall (sm ,slot-name ,s) ,arg1 ,s ,@args))))
 118
 119 (defmacro add-stream-instance-flags (stream &rest flags)
 120   "Set the given flag bits in STREAM."
 121   (let ((s (gensym "STREAM")))
 122     `(let ((,s ,stream))
 123        (with-stream-class (simple-stream ,s)
 124          (setf (sm %flags ,s) (logior (sm %flags ,s) ,(%flags flags)))))))
 125
 126 (defmacro remove-stream-instance-flags (stream &rest flags)
 127   "Clear the given flag bits in STREAM."
 128   (let ((s (gensym "STREAM")))
 129     `(let ((,s ,stream))
 130        (with-stream-class (simple-stream ,s)
 131          (setf (sm %flags ,s) (logandc2 (sm %flags ,s) ,(%flags flags)))))))
 132
 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")))
 136     `(let ((,s ,stream))
 137        (with-stream-class (simple-stream ,s)
 138          (not (zerop (logand (sm %flags ,s) ,(%flags flags))))))))
 139
 140
 141 (declaim (inline buffer-sap bref (setf bref) buffer-copy))
 142
 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)))
 150
 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))
 155
 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))
 161
 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)
 168                                (* length 8))))
 169
 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))))
 174
 175 (defun free-buffer (buffer)
 176   (when (not (vectorp buffer))
 177     (push buffer sb-impl::*available-buffers*))
 178   t)
 179
 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)
 188       (ecase direction
 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.
 198       (cond (output
 199              (unless if-exists-given
 200                (setf if-exists
 201                      (if (eq (pathname-version pathname) :newest)
 202                          :new-version
 203                          :error)))
 204              (case if-exists
 205                ((:error nil)
 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)))
 211                (:append
 212                 (setf mask (logior mask sb-unix:o_append)))))
 213             (t
 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)
 218                     ((and output
 219                           (member if-exists '(:overwrite :append)))
 220                      :error)
 221                     ((eq direction :probe)
 222                      nil)
 223                     (t
 224                      :create))))
 225       (if (eq if-does-not-exist :create)
 226           (setf mask (logior mask sb-unix:o_creat)))
 227
 228       (let ((original (if (member if-exists
 229                                   '(:rename :rename-and-delete))
 230                           (sb-impl::pick-backup-name name)
 231                           nil))
 232             (delete-original (eq if-exists :rename-and-delete))
 233             (mode #o666))
 234         (when original
 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
 238           (let ((exists
 239                  (and name
 240                       (multiple-value-bind
 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))
 245                         (cond
 246                           (okay
 247                            (when (and output (= (logand orig-mode #o170000)
 248                                                 #o40000))
 249                              (error 'sb-int:simple-file-error
 250                                  :pathname pathname
 251                                  :format-control
 252                                  "Cannot open ~S for output: Is a directory."
 253                                  :format-arguments (list name)))
 254                            (setf mode (logand orig-mode #o777))
 255                            t)
 256                           ((eql err/dev sb-unix:enoent)
 257                            nil)
 258                           (t
 259                            (error 'sb-int:simple-file-error
 260                                   :pathname pathname
 261                                   :format-control "Cannot find ~S: ~A"
 262                                   :format-arguments
 263                                     (list name
 264                                       (sb-int:strerror err/dev)))))))))
 265             (unless (and exists
 266                          (rename-file name original))
 267               (setf original nil)
 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)
 275                                    sb-unix:o_trunc)))
 276               (setf if-exists :supersede))))
 277
 278         ;; Okay, now we can try the actual open.
 279         (loop
 280           (multiple-value-bind (fd errno)
 281               (if name
 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
 288                      (:error
 289                        (cerror "Return NIL."
 290                                'sb-int:simple-file-error
 291                                :pathname pathname
 292                                :format-control "Error opening ~S, ~A."
 293                                :format-arguments
 294                                    (list pathname
 295                                          (sb-int:strerror errno))))
 296                      (:create
 297                       (cerror "Return NIL."
 298                                'sb-int:simple-file-error
 299                                :pathname pathname
 300                                :format-control
 301                                    "Error creating ~S, path does not exist."
 302                                :format-arguments (list pathname))))
 303                    (return nil))
 304                   ((eql errno sb-unix:eexist)
 305                    (unless (eq nil if-exists)
 306                      (cerror "Return NIL."
 307                              'sb-int:simple-file-error
 308                              :pathname pathname
 309                              :format-control "Error opening ~S, ~A."
 310                              :format-arguments
 311                                  (list pathname
 312                                        (sb-int:strerror errno))))
 313                    (return nil))
 314                   #+nil ; FIXME: reinstate this; error reporting is nice.
 315                   ((eql errno sb-unix:eacces)
 316                    (cerror "Try again."
 317                            'sb-int:simple-file-error
 318                            :pathname pathname
 319                            :format-control "Error opening ~S, ~A."
 320                            :format-arguments
 321                                (list pathname
 322                                      (sb-int:strerror errno))))
 323                   (t
 324                    (cerror "Return NIL."
 325                            'sb-int:simple-file-error
 326                            :pathname pathname
 327                            :format-control "Error opening ~S, ~A."
 328                            :format-arguments
 329                                (list pathname
 330                                      (sb-int:strerror errno)))
 331                    (return nil)))))))))
 332
 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)
 348     (when fd
 349       (case direction
 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
 355                                 :file namestring
 356                                 :original original
 357                                 :delete-original delete-original
 358                                 :pathname pathname
 359                                 :input-buffer-p t
 360                                 :auto-close t))
 361         (:probe
 362          (let ((stream (sb-impl::%make-fd-stream :name namestring :fd fd
 363                                                  :pathname pathname
 364                                                  :element-type element-type)))
 365            (close stream)
 366            stream))))))
 367
 368
 369 ;; Make PATHNAME and NAMESTRING work
 370 (defun cl::file-name (stream &optional new-name)
 371   (typecase stream
 372     (file-simple-stream
 373      (with-stream-class (file-simple-stream stream)
 374        (cond (new-name
 375               (setf (sm pathname stream) new-name)
 376               (setf (sm filename stream) (sb-int:unix-namestring new-name nil))
 377               t)
 378              (t
 379               (sm pathname stream)))))
 380     (sb-sys::file-stream
 381      (cond (new-name
 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))
 385             t)
 386            (t
 387             (sb-impl::fd-stream-pathname stream))))))
 388
 389 ;; Experimental "filespec" stuff
 390
 391 ;; sat: Hooks to parse URIs etc apparently go here
 392
 393 (defstruct (filespec-parser
 394              (:constructor make-filespec-parser (name priority function)))
 395   name
 396   priority
 397   function)
 398
 399 (defvar *filespec-parsers* ())
 400
 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))
 406                        #'>
 407                        :key #'filespec-parser-priority)))
 408   t)
 409
 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
 414                                           (block ,truename
 415                                             ,@body)))))
 416
 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)))))
 423
 424 (define-filespec pathname (string)
 425   (pathname string))