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
  17 (declaim (inline buffer-sap bref (setf bref) buffer-copy
  18                  allocate-buffer free-buffer))
  19
  20 (defun buffer-sap (thing &optional offset)
  21   (declare (type simple-stream-buffer thing) (type (or fixnum null) offset)
  22            (optimize (speed 3) (space 2) (debug 0) (safety 0)
  23                      ;; Suppress the note about having to box up the return:
  24                      (sb-ext:inhibit-warnings 3)))
  25   (let ((sap (if (vectorp thing) (sb-sys:vector-sap thing) thing)))
  26     (if offset (sb-sys:sap+ sap offset) sap)))
  27
  28 (defun bref (buffer index)
  29   (declare (type simple-stream-buffer buffer)
  30            (type (integer 0 #.most-positive-fixnum) index))
  31   (sb-sys:sap-ref-8 (buffer-sap buffer) index))
  32
  33 (defun (setf bref) (octet buffer index)
  34   (declare (type (unsigned-byte 8) octet)
  35            (type simple-stream-buffer buffer)
  36            (type (integer 0 #.most-positive-fixnum) index))
  37   (setf (sb-sys:sap-ref-8 (buffer-sap buffer) index) octet))
  38
  39 (defun buffer-copy (src soff dst doff length)
  40   (declare (type simple-stream-buffer src dst)
  41            (type fixnum soff doff length))
  42   (sb-sys:without-gcing ;; is this necessary??
  43    (sb-kernel:system-area-copy (buffer-sap src) (* soff 8)
  44                                (buffer-sap dst) (* doff 8)
  45                                (* length 8))))
  46
  47 (defun allocate-buffer (size)
  48   (if (= size sb-impl::bytes-per-buffer)
  49       (sb-impl::next-available-buffer)
  50       (make-array size :element-type '(unsigned-byte 8))))
  51
  52 (defun free-buffer (buffer)
  53   (when (sb-sys:system-area-pointer-p buffer)
  54     (push buffer sb-impl::*available-buffers*))
  55   t)
  56
  57
  58 (defun make-control-table (&rest inits)
  59   (let ((table (make-array 32 :initial-element nil)))
  60     (do* ((char (pop inits) (pop inits))
  61           (func (pop inits) (pop inits)))
  62          ((null char))
  63       (when (< (char-code char) 32)
  64         (setf (aref table (char-code char)) func)))
  65     table))
  66
  67 (defun std-newline-out-handler (stream character)
  68   (declare (ignore character))
  69   (with-stream-class (simple-stream stream)
  70     (setf (sm charpos stream) -1)
  71     nil))
  72
  73 (defun std-tab-out-handler (stream character)
  74   (declare (ignore character))
  75   (with-stream-class (simple-stream stream)
  76     (let ((col (sm charpos stream)))
  77       (when col
  78         (setf (sm charpos stream) (1- (* 8 (1+ (floor col 8)))))))
  79     nil))
  80
  81 (defun std-dc-newline-in-handler (stream character)
  82   (with-stream-class (dual-channel-simple-stream stream)
  83     (setf (sm charpos stream) -1) ;; set to 0 "if reading" ???
  84     character))
  85
  86 (defvar *std-control-out-table*
  87   (make-control-table #\Newline #'std-newline-out-handler
  88                       #\Tab     #'std-tab-out-handler))
  89
  90 (defvar *default-external-format* :iso8859-1)
  91
  92 (defvar *external-formats* (make-hash-table))
  93 (defvar *external-format-aliases* (make-hash-table))
  94
  95 (defstruct (external-format
  96              (:conc-name ef-)
  97              (:print-function %print-external-format)
  98              (:constructor make-external-format (name octets-to-char
  99                                                       char-to-octets)))
 100   (name (sb-int:missing-arg) :type keyword :read-only t)
 101   (octets-to-char (sb-int:missing-arg) :type function :read-only t)
 102   (char-to-octets (sb-int:missing-arg) :type function :read-only t))
 103
 104 (defun %print-external-format (ef stream depth)
 105   (declare (ignore depth))
 106   (print-unreadable-object (ef stream :type t :identity t)
 107     (princ (ef-name ef) stream)))
 108
 109 (defmacro define-external-format (name octets-to-char char-to-octets)
 110   `(macrolet ((octets-to-char ((state input unput) &body body)
 111                 `(lambda (,state ,input ,unput)
 112                    (declare (type (function () (unsigned-byte 8)) ,input)
 113                             (type (function (sb-int:index) t) ,unput)
 114                             (ignorable ,state ,input ,unput)
 115                             (values character sb-int:index t))
 116                    ,@body))
 117               (char-to-octets ((char state output) &body body)
 118                 `(lambda (,char ,state ,output)
 119                    (declare (type character ,char)
 120                             (type (function ((unsigned-byte 8)) t) ,output)
 121                             (ignorable state ,output)
 122                             (values t))
 123                    ,@body)))
 124      (setf (gethash ,name *external-formats*)
 125            (make-external-format ,name ,octets-to-char ,char-to-octets))))
 126
 127 ;;; TODO: make this work
 128 (defun load-external-format-aliases ()
 129   (let ((*package* (find-package "KEYWORD")))
 130     (with-open-file (stm "ef:aliases" :if-does-not-exist nil)
 131       (when stm
 132         (do ((alias (read stm nil stm) (read stm nil stm))
 133              (value (read stm nil stm) (read stm nil stm)))
 134             ((or (eq alias stm) (eq value stm))
 135              (unless (eq alias stm)
 136                (warn "External-format aliases file ends early.")))
 137           (if (and (keywordp alias) (keywordp value))
 138               (setf (gethash alias *external-format-aliases*) value)
 139               (warn "Bad entry in external-format aliases file: ~S => ~S."
 140                     alias value)))))))
 141
 142 (defun find-external-format (name &optional (error-p t))
 143   (when (external-format-p name)
 144     (return-from find-external-format name))
 145
 146   (when (eq name :default)
 147     (setq name *default-external-format*))
 148
 149   ;; TODO: make this work
 150   #+nil
 151   (unless (ext:search-list-defined-p "ef:")
 152     (setf (ext:search-list "ef:") '("library:ef/")))
 153
 154   (when (zerop (hash-table-count *external-format-aliases*))
 155     (setf (gethash :latin1 *external-format-aliases*) :iso8859-1)
 156     (setf (gethash :latin-1 *external-format-aliases*) :iso8859-1)
 157     (setf (gethash :iso-8859-1 *external-format-aliases*) :iso8859-1)
 158     (load-external-format-aliases))
 159
 160   (do ((tmp (gethash name *external-format-aliases*)
 161             (gethash tmp *external-format-aliases*))
 162        (cnt 0 (1+ cnt)))
 163       ((or (null tmp) (= cnt 50))
 164        (unless (null tmp)
 165          (error "External-format aliasing depth exceeded.")))
 166     (setq name tmp))
 167
 168   (or (gethash name *external-formats*)
 169       (and (let ((*package* (find-package "SB-SIMPLE-STREAMS")))
 170              (load (format nil "ef:~(~A~)" name) :if-does-not-exist nil))
 171            (gethash name *external-formats*))
 172       (if error-p (error "External format ~S not found." name) nil)))
 173
 174 (define-condition void-external-format (error)
 175   ()
 176   (:report
 177     (lambda (condition stream)
 178       (declare (ignore condition))
 179       (format stream "Attempting I/O through void external-format."))))
 180
 181 (define-external-format :void
 182     (octets-to-char (state input unput)
 183       (declare (ignore state input unput))
 184       (error 'void-external-format))
 185   (char-to-octets (char state output)
 186     (declare (ignore char state output))
 187     (error 'void-external-format)))
 188
 189 (define-external-format :iso8859-1
 190     (octets-to-char (state input unput)
 191       (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
 192       (values (code-char (funcall input)) 1 state))
 193   (char-to-octets (char state output)
 194     (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
 195     (let ((code (char-code char)))
 196       #-(or)
 197       (funcall output code)
 198       #+(or)
 199       (if (< code 256)
 200           (funcall output code)
 201           (funcall output (char-code #\?))))
 202     state))
 203
 204 (defmacro octets-to-char (external-format state count input unput)
 205   (let ((tmp1 (gensym)) (tmp2 (gensym)) (tmp3 (gensym)))
 206     `(multiple-value-bind (,tmp1 ,tmp2 ,tmp3)
 207          (funcall (ef-octets-to-char ,external-format) ,state ,input ,unput)
 208        (setf ,state ,tmp3 ,count ,tmp2)
 209        ,tmp1)))
 210
 211 (defmacro char-to-octets (external-format char state output)
 212   `(progn
 213      (setf ,state (funcall (ef-char-to-octets ,external-format)
 214                            ,char ,state ,output))
 215      nil))
 216
 217 (defun string-to-octets (string &key (start 0) end (external-format :default))
 218   (declare (type string string)
 219            (type sb-int:index start)
 220            (type (or null sb-int:index) end))
 221   (let ((ef (find-external-format external-format))
 222         (buffer (make-array (length string) :element-type '(unsigned-byte 8)))
 223         (ptr 0)
 224         (state nil))
 225     (flet ((out (b)
 226              (setf (aref buffer ptr) b)
 227              (when (= (incf ptr) (length buffer))
 228                (setq buffer (adjust-array buffer (* 2 ptr))))))
 229       (dotimes (i (- (or end (length string)) start))
 230         (declare (type sb-int:index i))
 231         (char-to-octets ef (char string (+ start i)) state #'out))
 232       (sb-kernel:shrink-vector buffer ptr))))
 233
 234 (defun octets-to-string (octets &key (start 0) end (external-format :default))
 235   (declare (type vector octets)
 236            (type sb-int:index start)
 237            (type (or null sb-int:index) end))
 238   (let ((ef (find-external-format external-format))
 239         (end (1- (or end (length octets))))
 240         (string (make-string (length octets)))
 241         (ptr (1- start))
 242         (pos -1)
 243         (count 0)
 244         (state nil))
 245     (flet ((input ()
 246              (aref octets (incf ptr)))
 247            (unput (n)
 248              (decf ptr n)))
 249       (loop until (>= ptr end)
 250             do (setf (schar string (incf pos))
 251                  (octets-to-char ef state count #'input #'unput))))
 252     (sb-kernel:shrink-vector string (1+ pos))))
 253
 254 (defun vector-elt-width (vector)
 255   ;; Return octet-width of vector elements
 256   (etypecase vector
 257     ;; (simple-array fixnum (*)) not supported
 258     ;; (simple-array base-char (*)) treated specially; don't call this
 259     ((simple-array bit (*)) 1)
 260     ((simple-array (unsigned-byte 2) (*)) 1)
 261     ((simple-array (unsigned-byte 4) (*)) 1)
 262     ((simple-array (signed-byte 8) (*)) 1)
 263     ((simple-array (unsigned-byte 8) (*)) 1)
 264     ((simple-array (signed-byte 16) (*)) 2)
 265     ((simple-array (unsigned-byte 16) (*)) 2)
 266     ((simple-array (signed-byte 32) (*)) 4)
 267     ((simple-array (unsigned-byte 32) (*)) 4)
 268     ((simple-array single-float (*)) 4)
 269     ((simple-array double-float (*)) 8)
 270     ((simple-array (complex single-float) (*)) 8)
 271     ((simple-array (complex double-float) (*)) 16)))
 272
 273 #-(or big-endian little-endian)
 274 (eval-when (:compile-toplevel)
 275   (push sb-c::*backend-byte-order* *features*))
 276
 277 (defun endian-swap-value (vector endian-swap)
 278   #+big-endian (declare (ignore vector))
 279   (case endian-swap
 280     (:network-order #+big-endian 0
 281                     #+little-endian (1- (vector-elt-width vector)))
 282     (:byte-8 0)
 283     (:byte-16 1)
 284     (:byte-32 3)
 285     (:byte-64 7)
 286     (:byte-128 15)
 287     (otherwise endian-swap)))
 288
 289 #+(or)
 290 (defun %read-vector (vector stream start end endian-swap blocking)
 291   (declare (type (kernel:simple-unboxed-array (*)) vector)
 292            (type stream stream))
 293   ;; move code from read-vector
 294   )
 295
 296 #+(or)
 297 (defun %write-vector (... blocking)
 298   ;; implement me
 299   )
 300
 301 (defun read-octets (stream buffer start end blocking)
 302   (declare (type simple-stream stream)
 303            (type (or null simple-stream-buffer) buffer)
 304            (type fixnum start)
 305            (type (or null fixnum) end)
 306            (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 307   (with-stream-class (simple-stream stream)
 308     (let ((fd (sm input-handle stream))
 309           (end (or end (sm buf-len stream)))
 310           (buffer (or buffer (sm buffer stream))))
 311       (declare (fixnum end))
 312       (typecase fd
 313         (fixnum
 314          (let ((flag (sb-sys:wait-until-fd-usable fd :input
 315                                                   (if blocking nil 0))))
 316            (cond
 317              ((and (not blocking) (= start end)) (if flag -3 0))
 318              ((and (not blocking) (not flag)) 0)
 319              (t (block nil
 320                   (let ((count 0))
 321                     (declare (type fixnum count))
 322                     (tagbody
 323                      again
 324                        ;; Avoid CMUCL gengc write barrier
 325                        (do ((i start (+ i (the fixnum #.(sb-posix:getpagesize)))))
 326                            ((>= i end))
 327                          (declare (type fixnum i))
 328                          (setf (bref buffer i) 0))
 329                        (setf (bref buffer (1- end)) 0)
 330                        (multiple-value-bind (bytes errno)
 331                            (sb-unix:unix-read fd (buffer-sap buffer start)
 332                                               (the fixnum (- end start)))
 333                          (declare (type (or null fixnum) bytes)
 334                                   (type (integer 0 100) errno))
 335                          (when bytes
 336                            (incf count bytes)
 337                            (incf start bytes))
 338                          (cond ((null bytes)
 339                                 (format *debug-io* "~&;; UNIX-READ: errno=~D~%" errno)
 340                                 (cond ((= errno sb-unix:eintr) (go again))
 341                                       ((and blocking
 342                                             (or (= errno ;;sb-unix:eagain
 343                                                    ;; TODO: move
 344                                                    ;; eagain into
 345                                                    ;; sb-unix
 346                                                    11)
 347                                                 (= errno sb-unix:ewouldblock)))
 348                                        (sb-sys:wait-until-fd-usable fd :input nil)
 349                                        (go again))
 350                                       (t (return (- -10 errno)))))
 351                                ((zerop count) (return -1))
 352                                (t (return count)))))))))))
 353         (t (%read-vector buffer fd start end :byte-8
 354                          (if blocking :bnb nil)))))))
 355
 356 (defun write-octets (stream buffer start end blocking)
 357   (declare (type simple-stream stream)
 358            (type simple-stream-buffer buffer)
 359            (type fixnum start)
 360            (type (or null fixnum) end))
 361   (with-stream-class (simple-stream stream)
 362     (when (sm handler stream)
 363       (do ()
 364           ((null (sm pending stream)))
 365         (sb-sys:serve-all-events)))
 366
 367     (let ((fd (sm output-handle stream))
 368           (end (or end (length buffer))))
 369       (typecase fd
 370         (fixnum
 371          (let ((flag (sb-sys:wait-until-fd-usable fd :output
 372                                                   (if blocking nil 0))))
 373            (cond
 374              ((and (not blocking) (= start end)) (if flag -3 0))
 375              ((and (not blocking) (not flag)) 0)
 376              (t
 377               (block nil
 378                 (let ((count 0))
 379                   (tagbody again
 380                      (multiple-value-bind (bytes errno)
 381                          (sb-unix:unix-write fd (buffer-sap buffer) start
 382                                           (- end start))
 383                        (when bytes
 384                          (incf count bytes)
 385                          (incf start bytes))
 386                        (cond ((null bytes)
 387                               (format *debug-io* "~&;; UNIX-WRITE: errno=~D~%" errno)
 388                               (cond ((= errno sb-unix:eintr) (go again))
 389                                     ;; don't block for subsequent chars
 390                                     (t (return (- -10 errno)))))
 391                              (t (return count)))))))))))
 392         (t (error "implement me"))))))
 393
 394 (defun do-some-output (stream)
 395   ;; Do some pending output; return T if completed, NIL if more to do
 396   (with-stream-class (simple-stream stream)
 397     (let ((fd (sm output-handle stream)))
 398       (loop
 399         (let ((list (pop (sm pending stream))))
 400           (unless list
 401             (sb-sys:remove-fd-handler (sm handler stream))
 402             (setf (sm handler stream) nil)
 403             (return t))
 404           (let* ((buffer (first list))
 405                  (start (second list))
 406                  (end (third list))
 407                  (len (- end start)))
 408             (declare (type simple-stream-buffer buffer)
 409                      (type sb-int:index start end len))
 410             (tagbody again
 411                (multiple-value-bind (bytes errno)
 412                    (sb-unix:unix-write fd (buffer-sap buffer) start len)
 413                  (cond ((null bytes)
 414                         (if (= errno sb-unix:eintr)
 415                             (go again)
 416                             (progn (push list (sm pending stream))
 417                                    (return nil))))
 418                        ((< bytes len)
 419                         (setf (second list) (+ start bytes))
 420                         (push list (sm pending stream))
 421                         (return nil))
 422                        ((= bytes len)
 423                         (free-buffer buffer)))))))))))
 424
 425 (defun queue-write (stream buffer start end)
 426   ;; Queue a write; return T if buffer needs changing, NIL otherwise
 427   (declare (type simple-stream stream)
 428            (type simple-stream-buffer buffer)
 429            (type sb-int:index start end))
 430   (with-stream-class (simple-stream stream)
 431     (when (sm handler stream)
 432       (unless (do-some-output stream)
 433         (let ((last (last (sm pending stream))))
 434           (setf (cdr last) (list (list buffer start end)))
 435           (return-from queue-write t))))
 436     (let ((bytes (write-octets stream buffer start end nil)))
 437       (unless (or (= bytes (- end start)) ; completed
 438                   (= bytes -3)) ; empty buffer; shouldn't happen
 439         (setf (sm pending stream) (list (list buffer start end)))
 440         (setf (sm handler stream)
 441               (sb-sys:add-fd-handler (sm output-handle stream) :output
 442                                      (lambda (fd)
 443                                        (declare (ignore fd))
 444                                        (do-some-output stream))))
 445         t))))
 446
 447
 448
 449
 450 (defun %fd-open (pathname direction if-exists if-exists-given
 451                           if-does-not-exist if-does-not-exist-given)
 452   (declare (type pathname pathname)
 453            (type (member :input :output :io :probe) direction)
 454            (type (member :error :new-version :rename :rename-and-delete
 455                          :overwrite :append :supersede nil) if-exists)
 456            (type (member :error :create nil) if-does-not-exist))
 457   (multiple-value-bind (input output mask)
 458       (ecase direction
 459         (:input (values t nil sb-unix:o_rdonly))
 460         (:output (values nil t sb-unix:o_wronly))
 461         (:io (values t t sb-unix:o_rdwr))
 462         (:probe (values t nil sb-unix:o_rdonly)))
 463     (declare (type sb-int:index mask))
 464     (let ((name (cond ((sb-int:unix-namestring pathname input))
 465                       ((and input (eq if-does-not-exist :create))
 466                        (sb-int:unix-namestring pathname nil)))))
 467       ;; Process if-exists argument if we are doing any output.
 468       (cond (output
 469              (unless if-exists-given
 470                (setf if-exists
 471                      (if (eq (pathname-version pathname) :newest)
 472                          :new-version
 473                          :error)))
 474              (case if-exists
 475                ((:error nil)
 476                 (setf mask (logior mask sb-unix:o_excl)))
 477                ((:rename :rename-and-delete)
 478                 (setf mask (logior mask sb-unix:o_creat)))
 479                ((:new-version :supersede)
 480                 (setf mask (logior mask sb-unix:o_trunc)))))
 481             (t
 482              (setf if-exists nil)))     ; :ignore-this-arg
 483       (unless if-does-not-exist-given
 484         (setf if-does-not-exist
 485               (cond ((eq direction :input) :error)
 486                     ((and output
 487                           (member if-exists '(:overwrite :append)))
 488                      :error)
 489                     ((eq direction :probe)
 490                      nil)
 491                     (t
 492                      :create))))
 493       (if (eq if-does-not-exist :create)
 494           (setf mask (logior mask sb-unix:o_creat)))
 495
 496       (let ((original (if (member if-exists
 497                                   '(:rename :rename-and-delete))
 498                           (sb-impl::pick-backup-name name)
 499                           nil))
 500             (delete-original (eq if-exists :rename-and-delete))
 501             (mode #o666))
 502         (when original
 503           ;; We are doing a :rename or :rename-and-delete.
 504           ;; Determine if the file already exists, make sure the original
 505           ;; file is not a directory and keep the mode
 506           (let ((exists
 507                  (and name
 508                       (multiple-value-bind
 509                             (okay err/dev inode orig-mode)
 510                           (sb-unix:unix-stat name)
 511                         (declare (ignore inode)
 512                                  (type (or sb-int:index null) orig-mode))
 513                         (cond
 514                           (okay
 515                            (when (and output (= (logand orig-mode #o170000)
 516                                                 #o40000))
 517                              (error 'sb-int:simple-file-error
 518                                  :pathname pathname
 519                                  :format-control
 520                                  "Cannot open ~S for output: Is a directory."
 521                                  :format-arguments (list name)))
 522                            (setf mode (logand orig-mode #o777))
 523                            t)
 524                           ((eql err/dev sb-unix:enoent)
 525                            nil)
 526                           (t
 527                            (error 'sb-int:simple-file-error
 528                                   :pathname pathname
 529                                   :format-control "Cannot find ~S: ~A"
 530                                   :format-arguments
 531                                     (list name
 532                                       (sb-int:strerror err/dev)))))))))
 533             (unless (and exists
 534                          (rename-file name original))
 535               (setf original nil)
 536               (setf delete-original nil)
 537               ;; In order to use SUPERSEDE instead, we have
 538               ;; to make sure unix:o_creat corresponds to
 539               ;; if-does-not-exist.  unix:o_creat was set
 540               ;; before because of if-exists being :rename.
 541               (unless (eq if-does-not-exist :create)
 542                 (setf mask (logior (logandc2 mask sb-unix:o_creat)
 543                                    sb-unix:o_trunc)))
 544               (setf if-exists :supersede))))
 545
 546         ;; Okay, now we can try the actual open.
 547         (loop
 548           (multiple-value-bind (fd errno)
 549               (if name
 550                   (sb-unix:unix-open name mask mode)
 551                   (values nil sb-unix:enoent))
 552             (cond ((sb-int:fixnump fd)
 553                    (when (eql if-exists :append)
 554                      (sb-unix:unix-lseek fd 0 sb-unix:l_xtnd))
 555                    (return (values fd name original delete-original)))
 556                   ((eql errno sb-unix:enoent)
 557                    (case if-does-not-exist
 558                      (:error
 559                        (cerror "Return NIL."
 560                                'sb-int:simple-file-error
 561                                :pathname pathname
 562                                :format-control "Error opening ~S, ~A."
 563                                :format-arguments
 564                                    (list pathname
 565                                          (sb-int:strerror errno))))
 566                      (:create
 567                       (cerror "Return NIL."
 568                                'sb-int:simple-file-error
 569                                :pathname pathname
 570                                :format-control
 571                                    "Error creating ~S, path does not exist."
 572                                :format-arguments (list pathname))))
 573                    (return nil))
 574                   ((eql errno sb-unix:eexist)
 575                    (unless (eq nil if-exists)
 576                      (cerror "Return NIL."
 577                              'sb-int:simple-file-error
 578                              :pathname pathname
 579                              :format-control "Error opening ~S, ~A."
 580                              :format-arguments
 581                                  (list pathname
 582                                        (sb-int:strerror errno))))
 583                    (return nil))
 584                   #+nil ; FIXME: reinstate this; error reporting is nice.
 585                   ((eql errno sb-unix:eacces)
 586                    (cerror "Try again."
 587                            'sb-int:simple-file-error
 588                            :pathname pathname
 589                            :format-control "Error opening ~S, ~A."
 590                            :format-arguments
 591                                (list pathname
 592                                      (sb-int:strerror errno))))
 593                   (t
 594                    (cerror "Return NIL."
 595                            'sb-int:simple-file-error
 596                            :pathname pathname
 597                            :format-control "Error opening ~S, ~A."
 598                            :format-arguments
 599                                (list pathname
 600                                      (sb-int:strerror errno)))
 601                    (return nil)))))))))
 602
 603 (defun open-fd-stream (pathname &key (direction :input)
 604                                 (element-type 'base-char)
 605                                 (if-exists nil if-exists-given)
 606                                 (if-does-not-exist nil if-does-not-exist-given)
 607                                 (external-format :default))
 608   (declare (type (or pathname string stream) pathname)
 609            (type (member :input :output :io :probe) direction)
 610            (type (member :error :new-version :rename :rename-and-delete
 611                          :overwrite :append :supersede nil) if-exists)
 612            (type (member :error :create nil) if-does-not-exist)
 613            (ignore external-format))
 614   (let ((filespec (merge-pathnames pathname)))
 615     (multiple-value-bind (fd namestring original delete-original)
 616         (%fd-open filespec direction if-exists if-exists-given
 617                   if-does-not-exist if-does-not-exist-given)
 618       (when fd
 619         (case direction
 620           ((:input :output :io)
 621            (sb-sys:make-fd-stream fd
 622                                   :input (member direction '(:input :io))
 623                                   :output (member direction '(:output :io))
 624                                   :element-type element-type
 625                                   :file namestring
 626                                   :original original
 627                                   :delete-original delete-original
 628                                   :pathname pathname
 629                                   :input-buffer-p t
 630                                   :auto-close t))
 631           (:probe
 632            (let ((stream (sb-impl::%make-fd-stream :name namestring :fd fd
 633                                                    :pathname pathname
 634                                                    :element-type element-type)))
 635              (close stream)
 636              stream)))))))
 637
 638
 639 ;; Experimental "filespec" stuff
 640
 641 ;; sat: Hooks to parse URIs etc apparently go here
 642
 643 (defstruct (filespec-parser
 644              (:constructor make-filespec-parser (name priority function)))
 645   name
 646   priority
 647   function)
 648
 649 (defvar *filespec-parsers* ())
 650
 651 (defun add-filespec (name priority function)
 652   (let ((filespec (make-filespec-parser name priority function)))
 653     (setf *filespec-parsers*
 654           (stable-sort (cons filespec (delete name *filespec-parsers*
 655                                               :key #'filespec-parser-name))
 656                        #'>
 657                        :key #'filespec-parser-priority)))
 658   t)
 659
 660 (defmacro define-filespec (name lambda-list &body body)
 661   (let ((truename (if (consp name) (first name) name))
 662         (priority (if (consp name) (second name) 0)))
 663     `(add-filespec ',truename ,priority (lambda ,lambda-list
 664                                           (block ,truename
 665                                             ,@body)))))
 666
 667 (defun parse-filespec (string &optional (errorp t))
 668   (dolist (i *filespec-parsers* (when errorp
 669                                   (error "~S not recognised." string)))
 670     (let ((result (ignore-errors
 671                     (funcall (filespec-parser-function i) string))))
 672       (when result (return result)))))
 673
 674 (define-filespec pathname (string)
 675   (pathname string))