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