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