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