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
  49 ;;; Commented out in favor of standard class machinery that does not
  50 ;;; depend on implementation internals.
  51 #+nil
  52 (defmacro with-stream-class ((class-name &optional stream) &body body)
  53   (if stream
  54       (let ((stm (gensym "STREAM"))
  55             (slt (gensym "SV")))
  56         `(let* ((,stm ,stream)
  57                 (,slt (sb-pcl::std-instance-slots ,stm)))
  58            (declare (type ,class-name ,stm) (ignorable ,slt))
  59            (macrolet ((sm (slot-name stream)
  60                         (declare (ignore stream))
  61                         (let ((slot-access (gethash slot-name
  62                                                     *slot-access-functions*)))
  63                           (cond ((sb-int:fixnump (cdr slot-access))
  64                                  ;; Get value in nth slot
  65                                  `(the ,(car slot-access)
  66                                     (sb-pcl::clos-slots-ref ,',slt
  67                                                             ,(cdr slot-access))))
  68                                 (slot-access
  69                                  ;; Call memorized function
  70                                  `(the ,(car slot-access) (,(cdr slot-access)
  71                                                             ,',stm)))
  72                                 (t
  73                                  ;; Use slot-value
  74                                  `(slot-value ,',stm ',slot-name)))))
  75                       (add-stream-instance-flags (stream &rest flags)
  76                         (declare (ignore stream))
  77                         `(setf (sm %flags ,',stm) (logior (sm %flags ,',stm)
  78                                                           ,(%flags flags))))
  79                       (remove-stream-instance-flags (stream &rest flags)
  80                         (declare (ignore stream))
  81                         `(setf (sm %flags ,',stm) (logandc2 (sm %flags ,',stm)
  82                                                             ,(%flags flags))))
  83                       (any-stream-instance-flags (stream &rest flags)
  84                         (declare (ignore stream))
  85                         `(not (zerop (logand (sm %flags ,',stm)
  86                                              ,(%flags flags))))))
  87              ,@body)))
  88       `(macrolet ((sm (slot-name stream)
  89                     (let ((slot-access (gethash slot-name
  90                                                 *slot-access-functions*)))
  91                       (cond ((sb-int:fixnump (cdr slot-access))
  92                              `(the ,(car slot-access)
  93                                 (sb-pcl::clos-slots-ref
  94                                  (sb-pcl::std-instance-slots ,stream)
  95                                  ,(cdr slot-access))))
  96                             (slot-access
  97                              `(the ,(car slot-access) (,(cdr slot-access)
  98                                                         ,stream)))
  99                             (t `(slot-value ,stream ',slot-name))))))
 100          ,@body)))
 101
 102
 103 (defmacro with-stream-class ((class-name &optional stream) &body body)
 104   (if stream
 105     (let ((stm (gensym "STREAM"))
 106           (slt (gensym "SV")))
 107       `(let* ((,stm ,stream)
 108               (,slt (sb-kernel:%instance-ref ,stm 1)))
 109          (declare (type ,class-name ,stm)
 110                   (type simple-vector ,slt)
 111                   (ignorable ,slt))
 112          (macrolet ((sm (slot-name stream)
 113                       (declare (ignore stream))
 114                       #-count-sm
 115                       `(slot-value ,',stm ',slot-name)
 116                       #+count-sm
 117                       `(%sm ',slot-name ,',stm))
 118                     (add-stream-instance-flags (stream &rest flags)
 119                       (declare (ignore stream))
 120                       `(setf (sm %flags ,',stm) (logior (sm %flags ,',stm)
 121                                                         ,(%flags flags))))
 122                     (remove-stream-instance-flags (stream &rest flags)
 123                       (declare (ignore stream))
 124                       `(setf (sm %flags ,',stm) (logandc2 (sm %flags ,',stm)
 125                                                           ,(%flags flags))))
 126                     (any-stream-instance-flags (stream &rest flags)
 127                       (declare (ignore stream))
 128                       `(not (zerop (logand (sm %flags ,',stm)
 129                                            ,(%flags flags))))))
 130            ,@body)))
 131     `(macrolet ((sm (slot-name stream)
 132                   #-count-sm
 133                   `(slot-value ,stream ',slot-name)
 134                   #+count-sm
 135                   `(%sm ',slot-name ,stream)))
 136        ,@body)))
 137
 138 ;;; Commented out in favor of standard class machinery that does not
 139 ;;; depend on implementation internals.
 140 #+nil
 141 (defmacro sm (slot-name stream)
 142   (let ((slot-access (gethash slot-name *slot-access-functions*)))
 143     (warn "Using ~S macro outside ~S" 'sm 'with-stream-class)
 144     (cond ((sb-int:fixnump (cdr slot-access))
 145            `(the ,(car slot-access) (sb-pcl::clos-slots-ref
 146                                      (sb-pcl::std-instance-slots ,stream)
 147                                      ,(cdr slot-access))))
 148           (slot-access
 149            `(the ,(car slot-access) (,(cdr slot-access) ,stream)))
 150           (t `(slot-value ,stream ',slot-name)))))
 151
 152
 153 (defmacro sm (slot-name stream)
 154   "Access the named slot in Stream."
 155   (warn "Using ~S macro outside ~S." 'sm 'with-stream-class)
 156   `(slot-value ,stream ',slot-name))
 157
 158 (defmacro funcall-stm-handler (slot-name stream &rest args)
 159   (let ((s (gensym)))
 160     `(let ((,s ,stream))
 161        (funcall (sm ,slot-name ,s) ,s ,@args))))
 162
 163 (defmacro funcall-stm-handler-2 (slot-name arg1 stream &rest args)
 164   (let ((s (gensym)))
 165     `(let ((,s ,stream))
 166        (funcall (sm ,slot-name ,s) ,arg1 ,s ,@args))))
 167
 168 (defmacro add-stream-instance-flags (stream &rest flags)
 169   "Set the given flag bits in STREAM."
 170   (let ((s (gensym "STREAM")))
 171     `(let ((,s ,stream))
 172        (with-stream-class (simple-stream ,s)
 173          (setf (sm %flags ,s) (logior (sm %flags ,s) ,(%flags flags)))))))
 174
 175 (defmacro remove-stream-instance-flags (stream &rest flags)
 176   "Clear the given flag bits in STREAM."
 177   (let ((s (gensym "STREAM")))
 178     `(let ((,s ,stream))
 179        (with-stream-class (simple-stream ,s)
 180          (setf (sm %flags ,s) (logandc2 (sm %flags ,s) ,(%flags flags)))))))
 181
 182 (defmacro any-stream-instance-flags (stream &rest flags)
 183   "Determine whether any one of the FLAGS is set in STREAM."
 184   (let ((s (gensym "STREAM")))
 185     `(let ((,s ,stream))
 186        (with-stream-class (simple-stream ,s)
 187          (not (zerop (logand (sm %flags ,s) ,(%flags flags))))))))
 188
 189 (defmacro simple-stream-dispatch (stream single dual string)
 190   (let ((s (gensym "STREAM")))
 191     `(let ((,s ,stream))
 192        (with-stream-class (simple-stream ,s)
 193          (let ((%flags (sm %flags ,s)))
 194            (cond ((zerop (logand %flags ,(%flags '(:string :dual))))
 195                   ,single)
 196                  ((zerop (logand %flags ,(%flags '(:string))))
 197                   ,dual)
 198                  (t
 199                   ,string)))))))
 200
 201 (declaim (inline buffer-sap bref (setf bref) buffer-copy))
 202
 203 (defun buffer-sap (thing &optional offset)
 204   (declare (type simple-stream-buffer thing) (type (or fixnum null) offset)
 205            (optimize (speed 3) (space 2) (debug 0) (safety 0)
 206                      ;; Suppress the note about having to box up the return:
 207                      (sb-ext:inhibit-warnings 3)))
 208   (let ((sap (if (vectorp thing) (sb-sys:vector-sap thing) thing)))
 209     (if offset (sb-sys:sap+ sap offset) sap)))
 210
 211 (defun bref (buffer index)
 212   (declare (type simple-stream-buffer buffer)
 213            (type (integer 0 #.most-positive-fixnum) index))
 214   (sb-sys:sap-ref-8 (buffer-sap buffer) index))
 215
 216 (defun (setf bref) (octet buffer index)
 217   (declare (type (unsigned-byte 8) octet)
 218            (type simple-stream-buffer buffer)
 219            (type (integer 0 #.most-positive-fixnum) index))
 220   (setf (sb-sys:sap-ref-8 (buffer-sap buffer) index) octet))
 221
 222 (defun buffer-copy (src soff dst doff length)
 223   (declare (type simple-stream-buffer src dst)
 224            (type fixnum soff doff length))
 225   (sb-sys:without-gcing ;; is this necessary??
 226    (sb-kernel:system-area-copy (buffer-sap src) (* soff 8)
 227                                (buffer-sap dst) (* doff 8)
 228                                (* length 8))))
 229
 230 (defun allocate-buffer (size)
 231   (if (= size sb-impl::bytes-per-buffer)
 232       (sb-impl::next-available-buffer)
 233       (make-array size :element-type '(unsigned-byte 8))))
 234
 235 (defun free-buffer (buffer)
 236   (when (sb-sys:system-area-pointer-p buffer)
 237     (push buffer sb-impl::*available-buffers*))
 238   t)
 239
 240 (defun %fd-open (pathname direction if-exists if-exists-given
 241                           if-does-not-exist if-does-not-exist-given)
 242   (declare (type pathname pathname)
 243            (type (member :input :output :io :probe) direction)
 244            (type (member :error :new-version :rename :rename-and-delete
 245                          :overwrite :append :supersede nil) if-exists)
 246            (type (member :error :create nil) if-does-not-exist))
 247   (multiple-value-bind (input output mask)
 248       (ecase direction
 249         (:input (values t nil sb-unix:o_rdonly))
 250         (:output (values nil t sb-unix:o_wronly))
 251         (:io (values t t sb-unix:o_rdwr))
 252         (:probe (values t nil sb-unix:o_rdonly)))
 253     (declare (type sb-int:index mask))
 254     (let ((name (cond ((sb-int:unix-namestring pathname input))
 255                       ((and input (eq if-does-not-exist :create))
 256                        (sb-int:unix-namestring pathname nil)))))
 257       ;; Process if-exists argument if we are doing any output.
 258       (cond (output
 259              (unless if-exists-given
 260                (setf if-exists
 261                      (if (eq (pathname-version pathname) :newest)
 262                          :new-version
 263                          :error)))
 264              (case if-exists
 265                ((:error nil)
 266                 (setf mask (logior mask sb-unix:o_excl)))
 267                ((:rename :rename-and-delete)
 268                 (setf mask (logior mask sb-unix:o_creat)))
 269                ((:new-version :supersede)
 270                 (setf mask (logior mask sb-unix:o_trunc)))))
 271             (t
 272              (setf if-exists nil)))     ; :ignore-this-arg
 273       (unless if-does-not-exist-given
 274         (setf if-does-not-exist
 275               (cond ((eq direction :input) :error)
 276                     ((and output
 277                           (member if-exists '(:overwrite :append)))
 278                      :error)
 279                     ((eq direction :probe)
 280                      nil)
 281                     (t
 282                      :create))))
 283       (if (eq if-does-not-exist :create)
 284           (setf mask (logior mask sb-unix:o_creat)))
 285
 286       (let ((original (if (member if-exists
 287                                   '(:rename :rename-and-delete))
 288                           (sb-impl::pick-backup-name name)
 289                           nil))
 290             (delete-original (eq if-exists :rename-and-delete))
 291             (mode #o666))
 292         (when original
 293           ;; We are doing a :rename or :rename-and-delete.
 294           ;; Determine if the file already exists, make sure the original
 295           ;; file is not a directory and keep the mode
 296           (let ((exists
 297                  (and name
 298                       (multiple-value-bind
 299                             (okay err/dev inode orig-mode)
 300                           (sb-unix:unix-stat name)
 301                         (declare (ignore inode)
 302                                  (type (or sb-int:index null) orig-mode))
 303                         (cond
 304                           (okay
 305                            (when (and output (= (logand orig-mode #o170000)
 306                                                 #o40000))
 307                              (error 'sb-int:simple-file-error
 308                                  :pathname pathname
 309                                  :format-control
 310                                  "Cannot open ~S for output: Is a directory."
 311                                  :format-arguments (list name)))
 312                            (setf mode (logand orig-mode #o777))
 313                            t)
 314                           ((eql err/dev sb-unix:enoent)
 315                            nil)
 316                           (t
 317                            (error 'sb-int:simple-file-error
 318                                   :pathname pathname
 319                                   :format-control "Cannot find ~S: ~A"
 320                                   :format-arguments
 321                                     (list name
 322                                       (sb-int:strerror err/dev)))))))))
 323             (unless (and exists
 324                          (rename-file name original))
 325               (setf original nil)
 326               (setf delete-original nil)
 327               ;; In order to use SUPERSEDE instead, we have
 328               ;; to make sure unix:o_creat corresponds to
 329               ;; if-does-not-exist.  unix:o_creat was set
 330               ;; before because of if-exists being :rename.
 331               (unless (eq if-does-not-exist :create)
 332                 (setf mask (logior (logandc2 mask sb-unix:o_creat)
 333                                    sb-unix:o_trunc)))
 334               (setf if-exists :supersede))))
 335
 336         ;; Okay, now we can try the actual open.
 337         (loop
 338           (multiple-value-bind (fd errno)
 339               (if name
 340                   (sb-unix:unix-open name mask mode)
 341                   (values nil sb-unix:enoent))
 342             (cond ((sb-int:fixnump fd)
 343                    (when (eql if-exists :append)
 344                      (sb-unix:unix-lseek fd 0 sb-unix:l_xtnd))
 345                    (return (values fd name original delete-original)))
 346                   ((eql errno sb-unix:enoent)
 347                    (case if-does-not-exist
 348                      (:error
 349                        (cerror "Return NIL."
 350                                'sb-int:simple-file-error
 351                                :pathname pathname
 352                                :format-control "Error opening ~S, ~A."
 353                                :format-arguments
 354                                    (list pathname
 355                                          (sb-int:strerror errno))))
 356                      (:create
 357                       (cerror "Return NIL."
 358                                'sb-int:simple-file-error
 359                                :pathname pathname
 360                                :format-control
 361                                    "Error creating ~S, path does not exist."
 362                                :format-arguments (list pathname))))
 363                    (return nil))
 364                   ((eql errno sb-unix:eexist)
 365                    (unless (eq nil if-exists)
 366                      (cerror "Return NIL."
 367                              'sb-int:simple-file-error
 368                              :pathname pathname
 369                              :format-control "Error opening ~S, ~A."
 370                              :format-arguments
 371                                  (list pathname
 372                                        (sb-int:strerror errno))))
 373                    (return nil))
 374                   #+nil ; FIXME: reinstate this; error reporting is nice.
 375                   ((eql errno sb-unix:eacces)
 376                    (cerror "Try again."
 377                            'sb-int:simple-file-error
 378                            :pathname pathname
 379                            :format-control "Error opening ~S, ~A."
 380                            :format-arguments
 381                                (list pathname
 382                                      (sb-int:strerror errno))))
 383                   (t
 384                    (cerror "Return NIL."
 385                            'sb-int:simple-file-error
 386                            :pathname pathname
 387                            :format-control "Error opening ~S, ~A."
 388                            :format-arguments
 389                                (list pathname
 390                                      (sb-int:strerror errno)))
 391                    (return nil)))))))))
 392
 393 (defun open-fd-stream (pathname &key (direction :input)
 394                                 (element-type 'base-char)
 395                                 (if-exists nil if-exists-given)
 396                                 (if-does-not-exist nil if-does-not-exist-given)
 397                                 (external-format :default))
 398   (declare (type (or pathname string stream) pathname)
 399            (type (member :input :output :io :probe) direction)
 400            (type (member :error :new-version :rename :rename-and-delete
 401                          :overwrite :append :supersede nil) if-exists)
 402            (type (member :error :create nil) if-does-not-exist)
 403            (ignore external-format))
 404   (let ((filespec (merge-pathnames pathname)))
 405     (multiple-value-bind (fd namestring original delete-original)
 406         (%fd-open filespec direction if-exists if-exists-given
 407                   if-does-not-exist if-does-not-exist-given)
 408       (when fd
 409         (case direction
 410           ((:input :output :io)
 411            (sb-sys:make-fd-stream fd
 412                                   :input (member direction '(:input :io))
 413                                   :output (member direction '(:output :io))
 414                                   :element-type element-type
 415                                   :file namestring
 416                                   :original original
 417                                   :delete-original delete-original
 418                                   :pathname pathname
 419                                   :input-buffer-p t
 420                                   :auto-close t))
 421           (:probe
 422            (let ((stream (sb-impl::%make-fd-stream :name namestring :fd fd
 423                                                    :pathname pathname
 424                                                    :element-type element-type)))
 425              (close stream)
 426              stream)))))))
 427
 428
 429 ;; Experimental "filespec" stuff
 430
 431 ;; sat: Hooks to parse URIs etc apparently go here
 432
 433 (defstruct (filespec-parser
 434              (:constructor make-filespec-parser (name priority function)))
 435   name
 436   priority
 437   function)
 438
 439 (defvar *filespec-parsers* ())
 440
 441 (defun add-filespec (name priority function)
 442   (let ((filespec (make-filespec-parser name priority function)))
 443     (setf *filespec-parsers*
 444           (stable-sort (cons filespec (delete name *filespec-parsers*
 445                                               :key #'filespec-parser-name))
 446                        #'>
 447                        :key #'filespec-parser-priority)))
 448   t)
 449
 450 (defmacro define-filespec (name lambda-list &body body)
 451   (let ((truename (if (consp name) (first name) name))
 452         (priority (if (consp name) (second name) 0)))
 453     `(add-filespec ',truename ,priority (lambda ,lambda-list
 454                                           (block ,truename
 455                                             ,@body)))))
 456
 457 (defun parse-filespec (string &optional (errorp t))
 458   (dolist (i *filespec-parsers* (when errorp
 459                                   (error "~S not recognised." string)))
 460     (let ((result (ignore-errors
 461                     (funcall (filespec-parser-function i) string))))
 462       (when result (return result)))))
 463
 464 (define-filespec pathname (string)
 465   (pathname string))