contrib/sb-simple-streams/internal.lisp

   1 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*-
   2
   3 ;;; **********************************************************************
   4 ;;; This code was written by Paul Foley and has been placed in the public
   5 ;;; domain.
   6 ;;;
   7
   8 ;;; Sbcl port by Rudi Schlatte.
   9
  10 (in-package "SB-SIMPLE-STREAMS")
  11
  12 ;;;
  13 ;;; **********************************************************************
  14 ;;;
  15 ;;; Various functions needed by simple-streams
  16 (declaim (inline buffer-sap bref (setf bref) buffer-copy
  17                  allocate-buffer free-buffer))
  18
  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)))
  26
  27 (defun bref (buffer index)
  28   (declare (type simple-stream-buffer buffer)
  29            (type (integer 0 #.most-positive-fixnum) index))
  30   (if (vectorp buffer)
  31       (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index))
  32       (sb-sys:sap-ref-8 buffer index))
  33
  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))
  38   (if (vectorp buffer)
  39       (setf (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index) octet)
  40       (setf (sb-sys:sap-ref-8 buffer index) octet)))
  41
  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)
  48                                (* length 8))))
  49
  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))))
  54
  55 (defun free-buffer (buffer)
  56   (when (sb-sys:system-area-pointer-p buffer)
  57     (push buffer sb-impl::*available-buffers*))
  58   t)
  59
  60
  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)))
  65          ((null char))
  66       (when (< (char-code char) 32)
  67         (setf (aref table (char-code char)) func)))
  68     table))
  69
  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)
  74     nil))
  75
  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)))
  80       (when col
  81         (setf (sm charpos stream) (1- (* 8 (1+ (floor col 8)))))))
  82     nil))
  83
  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" ???
  87     character))
  88
  89 (defvar *std-control-out-table*
  90   (make-control-table #\Newline #'std-newline-out-handler
  91                       #\Tab     #'std-tab-out-handler))
  92
  93 (defvar *default-external-format* :iso8859-1)
  94
  95 (defvar *external-formats* (make-hash-table))
  96 (defvar *external-format-aliases* (make-hash-table))
  97
  98 (defstruct (external-format
  99              (:conc-name ef-)
 100              (:print-function %print-external-format)
 101              (:constructor make-external-format (name octets-to-char
 102                                                       char-to-octets)))
 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))
 106
 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)))
 111
 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))
 119                    ,@body))
 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)
 125                             (values t))
 126                    ,@body)))
 127      (setf (gethash ,name *external-formats*)
 128            (make-external-format ,name ,octets-to-char ,char-to-octets))))
 129
 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)
 134       (when stm
 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."
 143                     alias value)))))))
 144
 145 (defun find-external-format (name &optional (error-p t))
 146   (when (external-format-p name)
 147     (return-from find-external-format name))
 148
 149   (when (eq name :default)
 150     (setq name *default-external-format*))
 151
 152   ;; TODO: make this work
 153   #+nil
 154   (unless (ext:search-list-defined-p "ef:")
 155     (setf (ext:search-list "ef:") '("library:ef/")))
 156
 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))
 162
 163   (do ((tmp (gethash name *external-format-aliases*)
 164             (gethash tmp *external-format-aliases*))
 165        (cnt 0 (1+ cnt)))
 166       ((or (null tmp) (= cnt 50))
 167        (unless (null tmp)
 168          (error "External-format aliasing depth exceeded.")))
 169     (setq name tmp))
 170
 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)))
 176
 177 (define-condition void-external-format (error)
 178   ()
 179   (:report
 180     (lambda (condition stream)
 181       (declare (ignore condition))
 182       (format stream "Attempting I/O through void external-format."))))
 183
 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)))
 191
 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)))
 199       #-(or)
 200       (funcall output code)
 201       #+(or)
 202       (if (< code 256)
 203           (funcall output code)
 204           (funcall output (char-code #\?))))
 205     state))
 206
 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)
 212        ,tmp1)))
 213
 214 (defmacro char-to-octets (external-format char state output)
 215   `(progn
 216      (setf ,state (funcall (ef-char-to-octets ,external-format)
 217                            ,char ,state ,output))
 218      nil))
 219
 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)))
 226         (ptr 0)
 227         (state nil))
 228     (flet ((out (b)
 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))))
 236
 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)))
 244         (ptr (1- start))
 245         (pos -1)
 246         (count 0)
 247         (state nil))
 248     (flet ((input ()
 249              (aref octets (incf ptr)))
 250            (unput (n)
 251              (decf ptr n)))
 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))))
 256
 257 (defun vector-elt-width (vector)
 258   ;; Return octet-width of vector elements
 259   (etypecase vector
 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)))
 275
 276 #-(or big-endian little-endian)
 277 (eval-when (:compile-toplevel)
 278   (push sb-c::*backend-byte-order* *features*))
 279
 280 (defun endian-swap-value (vector endian-swap)
 281   #+big-endian (declare (ignore vector))
 282   (case endian-swap
 283     (:network-order #+big-endian 0
 284                     #+little-endian (1- (vector-elt-width vector)))
 285     (:byte-8 0)
 286     (:byte-16 1)
 287     (:byte-32 3)
 288     (:byte-64 7)
 289     (:byte-128 15)
 290     (otherwise endian-swap)))
 291
 292 #+(or)
 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
 297   )
 298
 299 #+(or)
 300 (defun %write-vector (... blocking)
 301   ;; implement me
 302   )
 303
 304 (defun read-octets (stream buffer start end blocking)
 305   (declare (type simple-stream stream)
 306            (type (or null simple-stream-buffer) buffer)
 307            (type fixnum start)
 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))
 316       (typecase fd
 317         (fixnum
 318          (let ((flag (sb-sys:wait-until-fd-usable fd :input
 319                                                   (if blocking nil 0))))
 320            (cond
 321              ((and (not blocking) (= start end)) (if flag -3 0))
 322              ((and (not blocking) (not flag)) 0)
 323              (t (block nil
 324                   (let ((count 0))
 325                     (declare (type fixnum count))
 326                     (tagbody
 327                      again
 328                        ;; Avoid CMUCL gengc write barrier
 329                        (do ((i start (+ i (the fixnum #.(sb-posix:getpagesize)))))
 330                            ((>= i end))
 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))
 339                          (when bytes
 340                            (incf count bytes)
 341                            (incf start bytes))
 342                          (cond ((null bytes)
 343                                 (format *debug-io* "~&;; UNIX-READ: errno=~D~%" errno)
 344                                 (cond ((= errno sb-unix:eintr) (go again))
 345                                       ((and blocking
 346                                             (or (= errno ;;sb-unix:eagain
 347                                                    ;; TODO: move
 348                                                    ;; eagain into
 349                                                    ;; sb-unix
 350                                                    11)
 351                                                 (= errno sb-unix:ewouldblock)))
 352                                        (sb-sys:wait-until-fd-usable fd :input nil)
 353                                        (go again))
 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)))))))
 359
 360 (defun write-octets (stream buffer start end blocking)
 361   (declare (type simple-stream stream)
 362            (type simple-stream-buffer buffer)
 363            (type fixnum start)
 364            (type (or null fixnum) end))
 365   (with-stream-class (simple-stream stream)
 366     (when (sm handler stream)
 367       (do ()
 368           ((null (sm pending stream)))
 369         (sb-sys:serve-all-events)))
 370
 371     (let ((fd (sm output-handle stream))
 372           (end (or end (length buffer))))
 373       (typecase fd
 374         (fixnum
 375          (let ((flag (sb-sys:wait-until-fd-usable fd :output
 376                                                   (if blocking nil 0))))
 377            (cond
 378              ((and (not blocking) (= start end)) (if flag -3 0))
 379              ((and (not blocking) (not flag)) 0)
 380              (t
 381               (block nil
 382                 (let ((count 0))
 383                   (tagbody again
 384                      (multiple-value-bind (bytes errno)
 385                          (sb-unix:unix-write fd (buffer-sap buffer) start
 386                                           (- end start))
 387                        (when bytes
 388                          (incf count bytes)
 389                          (incf start bytes))
 390                        (cond ((null bytes)
 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"))))))
 397
 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)))
 402       (loop
 403         (let ((list (pop (sm pending stream))))
 404           (unless list
 405             (sb-sys:remove-fd-handler (sm handler stream))
 406             (setf (sm handler stream) nil)
 407             (return t))
 408           (let* ((buffer (first list))
 409                  (start (second list))
 410                  (end (third list))
 411                  (len (- end start)))
 412             (declare (type simple-stream-buffer buffer)
 413                      (type sb-int:index start end len))
 414             (tagbody again
 415                (multiple-value-bind (bytes errno)
 416                    (sb-unix:unix-write fd (buffer-sap buffer) start len)
 417                  (cond ((null bytes)
 418                         (if (= errno sb-unix:eintr)
 419                             (go again)
 420                             (progn (push list (sm pending stream))
 421                                    (return nil))))
 422                        ((< bytes len)
 423                         (setf (second list) (+ start bytes))
 424                         (push list (sm pending stream))
 425                         (return nil))
 426                        ((= bytes len)
 427                         (free-buffer buffer)))))))))))
 428
 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
 446                                      (lambda (fd)
 447                                        (declare (ignore fd))
 448                                        (do-some-output stream))))
 449         t))))
 450
 451
 452
 453
 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)
 462       (ecase direction
 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.
 472       (cond (output
 473              (unless if-exists-given
 474                (setf if-exists
 475                      (if (eq (pathname-version pathname) :newest)
 476                          :new-version
 477                          :error)))
 478              (case if-exists
 479                ((:error nil)
 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)))))
 485             (t
 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)
 490                     ((and output
 491                           (member if-exists '(:overwrite :append)))
 492                      :error)
 493                     ((eq direction :probe)
 494                      nil)
 495                     (t
 496                      :create))))
 497       (if (eq if-does-not-exist :create)
 498           (setf mask (logior mask sb-unix:o_creat)))
 499
 500       (let ((original (if (member if-exists
 501                                   '(:rename :rename-and-delete))
 502                           (sb-impl::pick-backup-name name)
 503                           nil))
 504             (delete-original (eq if-exists :rename-and-delete))
 505             (mode #o666))
 506         (when original
 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
 510           (let ((exists
 511                  (and name
 512                       (multiple-value-bind
 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))
 517                         (cond
 518                           (okay
 519                            (when (and output (= (logand orig-mode #o170000)
 520                                                 #o40000))
 521                              (error 'sb-int:simple-file-error
 522                                  :pathname pathname
 523                                  :format-control
 524                                  "Cannot open ~S for output: Is a directory."
 525                                  :format-arguments (list name)))
 526                            (setf mode (logand orig-mode #o777))
 527                            t)
 528                           ((eql err/dev sb-unix:enoent)
 529                            nil)
 530                           (t
 531                            (error 'sb-int:simple-file-error
 532                                   :pathname pathname
 533                                   :format-control "Cannot find ~S: ~A"
 534                                   :format-arguments
 535                                     (list name
 536                                       (sb-int:strerror err/dev)))))))))
 537             (unless (and exists
 538                          (rename-file name original))
 539               (setf original nil)
 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)
 547                                    sb-unix:o_trunc)))
 548               (setf if-exists :supersede))))
 549
 550         ;; Okay, now we can try the actual open.
 551         (loop
 552           (multiple-value-bind (fd errno)
 553               (if name
 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
 562                      (:error
 563                        (cerror "Return NIL."
 564                                'sb-int:simple-file-error
 565                                :pathname pathname
 566                                :format-control "Error opening ~S, ~A."
 567                                :format-arguments
 568                                    (list pathname
 569                                          (sb-int:strerror errno))))
 570                      (:create
 571                       (cerror "Return NIL."
 572                                'sb-int:simple-file-error
 573                                :pathname pathname
 574                                :format-control
 575                                    "Error creating ~S, path does not exist."
 576                                :format-arguments (list pathname))))
 577                    (return nil))
 578                   ((eql errno sb-unix:eexist)
 579                    (unless (eq nil if-exists)
 580                      (cerror "Return NIL."
 581                              'sb-int:simple-file-error
 582                              :pathname pathname
 583                              :format-control "Error opening ~S, ~A."
 584                              :format-arguments
 585                                  (list pathname
 586                                        (sb-int:strerror errno))))
 587                    (return nil))
 588                   #+nil ; FIXME: reinstate this; error reporting is nice.
 589                   ((eql errno sb-unix:eacces)
 590                    (cerror "Try again."
 591                            'sb-int:simple-file-error
 592                            :pathname pathname
 593                            :format-control "Error opening ~S, ~A."
 594                            :format-arguments
 595                                (list pathname
 596                                      (sb-int:strerror errno))))
 597                   (t
 598                    (cerror "Return NIL."
 599                            'sb-int:simple-file-error
 600                            :pathname pathname
 601                            :format-control "Error opening ~S, ~A."
 602                            :format-arguments
 603                                (list pathname
 604                                      (sb-int:strerror errno)))
 605                    (return nil)))))))))
 606
 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)
 622       (when fd
 623         (case direction
 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
 629                                   :file namestring
 630                                   :original original
 631                                   :delete-original delete-original
 632                                   :pathname pathname
 633                                   :input-buffer-p t
 634                                   :auto-close t))
 635           (:probe
 636            (let ((stream (sb-impl::%make-fd-stream :name namestring :fd fd
 637                                                    :pathname pathname
 638                                                    :element-type element-type)))
 639              (close stream)
 640              stream)))))))
 641
 642
 643 ;; Experimental "filespec" stuff
 644
 645 ;; sat: Hooks to parse URIs etc apparently go here
 646
 647 (defstruct (filespec-parser
 648              (:constructor make-filespec-parser (name priority function)))
 649   name
 650   priority
 651   function)
 652
 653 (defvar *filespec-parsers* ())
 654
 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))
 660                        #'>
 661                        :key #'filespec-parser-priority)))
 662   t)
 663
 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
 668                                           (block ,truename
 669                                             ,@body)))))
 670
 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)))))
 677
 678 (define-filespec pathname (string)
 679   (pathname string))