contrib/sb-simple-streams/simple-streams.lisp

   1 ;;; -*- lisp -*-
   2
   3 ;;; This code is in the public domain.
   4
   5 ;;; The cmucl implementation of simple-streams was done by Paul Foley,
   6 ;;; who placed the code in the public domain.  Sbcl port by Rudi
   7 ;;; Schlatte.
   8
   9 (in-package "SB-SIMPLE-STREAMS")
  10
  11 ;;;
  12 ;;; SETUP
  13 ;;;
  14
  15 (defmethod shared-initialize :after ((instance simple-stream) slot-names
  16                                      &rest initargs &key &allow-other-keys)
  17   (declare (ignore slot-names))
  18   (unless (slot-boundp instance 'melded-stream)
  19     (setf (slot-value instance 'melded-stream) instance)
  20     (setf (slot-value instance 'melding-base) instance))
  21   (unless (device-open instance initargs)
  22     (device-close instance t)))
  23
  24 ;;; From the simple-streams documentation: "A generic function implies
  25 ;;; a specialization capability that does not exist for
  26 ;;; simple-streams; simple-stream specializations should be on
  27 ;;; device-close."  So don't do it.
  28 (defmethod close ((stream simple-stream) &key abort)
  29   (device-close stream abort))
  30
  31
  32 ;;; This takes care of the things all device-close methods have to do,
  33 ;;; regardless of the type of simple-stream
  34 (defmethod device-close :around ((stream simple-stream) abort)
  35   (with-stream-class (simple-stream stream)
  36     (when (any-stream-instance-flags stream :input :output)
  37       (when (any-stream-instance-flags stream :output)
  38         (if abort
  39             (clear-output stream)
  40             (force-output stream)))
  41       (call-next-method)
  42       (setf (sm input-handle stream) nil
  43             (sm output-handle stream) nil
  44             (sm j-listen stream) #'sb-kernel::closed-flame
  45             (sm j-read-char stream) #'sb-kernel::closed-flame
  46             (sm j-read-chars stream) #'sb-kernel::closed-flame
  47             (sm j-unread-char stream) #'sb-kernel::closed-flame
  48             (sm j-write-char stream) #'sb-kernel::closed-flame  ;@@
  49             (sm j-write-chars stream) #'sb-kernel::closed-flame) ;@@
  50       (remove-stream-instance-flags stream :input :output)
  51       (sb-ext:cancel-finalization stream))))
  52
  53 ;;;
  54 ;;; Stream printing
  55 ;;;
  56
  57 (defmethod print-object ((object simple-stream) stream)
  58   (print-unreadable-object (object stream :type nil :identity nil)
  59     (cond ((not (any-stream-instance-flags object :simple))
  60            (princ "Invalid " stream))
  61           ((not (any-stream-instance-flags object :input :output))
  62            (princ "Closed " stream)))
  63     (format stream "~:(~A~)" (type-of object))))
  64
  65 (defmethod print-object ((object file-simple-stream) stream)
  66   (print-unreadable-object (object stream :type nil :identity nil)
  67     (with-stream-class (file-simple-stream object)
  68       (cond ((not (any-stream-instance-flags object :simple))
  69              (princ "Invalid " stream))
  70             ((not (any-stream-instance-flags object :input :output))
  71              (princ "Closed " stream)))
  72       (format stream "~:(~A~) for ~S"
  73               (type-of object) (sm filename object)))))
  74
  75 (defun make-control-table (&rest inits)
  76   (let ((table (make-array 32 :initial-element nil)))
  77     (do* ((char (pop inits) (pop inits))
  78           (func (pop inits) (pop inits)))
  79          ((null char))
  80       (when (< (char-code char) 32)
  81         (setf (aref table (char-code char)) func)))
  82     table))
  83
  84 (defun std-newline-out-handler (stream character)
  85   (declare (ignore character))
  86   (with-stream-class (simple-stream stream)
  87     (setf (sm charpos stream) -1)
  88     nil))
  89
  90 (defun std-tab-out-handler (stream character)
  91   (declare (ignore character))
  92   (with-stream-class (simple-stream stream)
  93     (let ((col (sm charpos stream)))
  94       (when col
  95         (setf (sm charpos stream) (1- (* 8 (1+ (floor col 8)))))))
  96     nil))
  97
  98 (defun std-dc-newline-in-handler (stream character)
  99   (with-stream-class (dual-channel-simple-stream stream)
 100     (setf (sm charpos stream) -1) ;; set to 0 "if reading" ???
 101     character))
 102
 103 (defvar *std-control-out-table*
 104   (make-control-table #\Newline #'std-newline-out-handler
 105                       #\Tab     #'std-tab-out-handler))
 106
 107 (defvar *terminal-control-in-table*
 108   (make-control-table #\Newline #'std-dc-newline-in-handler))
 109
 110 (defun find-external-format (name)
 111   nil)
 112
 113 ;;;
 114 ;;; LOW LEVEL STUFF
 115 ;;;
 116
 117 (defun vector-elt-width (vector)
 118   ;; Return octet-width of vector elements
 119   (etypecase vector
 120     ;; (simple-array fixnum (*)) not supported
 121     ;; (simple-array base-char (*)) treated specially; don't call this
 122     ((simple-array bit (*)) 1)
 123     ((simple-array (unsigned-byte 2) (*)) 1)
 124     ((simple-array (unsigned-byte 4) (*)) 1)
 125     ((simple-array (signed-byte 8) (*)) 1)
 126     ((simple-array (unsigned-byte 8) (*)) 1)
 127     ((simple-array (signed-byte 16) (*)) 2)
 128     ((simple-array (unsigned-byte 16) (*)) 2)
 129     ((simple-array (signed-byte 32) (*)) 4)
 130     ((simple-array (unsigned-byte 32) (*)) 4)
 131     ((simple-array single-float (*)) 4)
 132     ((simple-array double-float (*)) 8)
 133     ((simple-array (complex single-float) (*)) 8)
 134     ((simple-array (complex double-float) (*)) 16)))
 135
 136 (defun endian-swap-value (vector endian-swap)
 137   (case endian-swap
 138     (:network-order (1- (vector-elt-width vector)))
 139     (:byte-8 0)
 140     (:byte-16 1)
 141     (:byte-32 3)
 142     (:byte-64 7)
 143     (:byte-128 15)
 144     (otherwise endian-swap)))
 145
 146
 147 (defun read-vector (vector stream &key (start 0) end (endian-swap :byte-8))
 148   (declare (type (sb-kernel:simple-unboxed-array (*)) vector)
 149            (type stream stream))
 150   ;; START and END are octet offsets, not vector indices!  [Except for strings]
 151   ;; Return value is index of next octet to be read into (i.e., start+count)
 152   (etypecase stream
 153     (simple-stream
 154      (with-stream-class (simple-stream stream)
 155        (if (stringp vector)
 156            (let* ((start (or start 0))
 157                   (end (or end (length vector)))
 158                   (char (funcall-stm-handler j-read-char stream nil nil t)))
 159              (when char
 160                (setf (schar vector start) char)
 161                (incf start)
 162                (+ start (funcall-stm-handler j-read-chars stream vector nil
 163                                              start end nil))))
 164            (do* ((j-read-byte
 165                   (cond ((any-stream-instance-flags stream :string)
 166                          (error "Can't READ-BYTE on string streams."))
 167                         ((any-stream-instance-flags stream :dual)
 168                          #'dc-read-byte)
 169                         (t
 170                          #'sc-read-byte)))
 171                  (index (or start 0) (1+ index))
 172                  (end (or end (* (length vector) (vector-elt-width vector))))
 173                  (endian-swap (endian-swap-value vector endian-swap))
 174                  (byte (funcall j-read-byte stream nil nil t)
 175                        (funcall j-read-byte stream nil nil nil)))
 176                 ((or (null byte) (>= index end)) index)
 177              (setf (bref vector (logxor index endian-swap)) byte)))))
 178     ((or ansi-stream fundamental-stream)
 179      (unless (typep vector '(or string
 180                              (simple-array (signed-byte 8) (*))
 181                              (simple-array (unsigned-byte 8) (*))))
 182        (error "Wrong vector type for read-vector on stream not of type simple-stream."))
 183      ;; FIXME: implement blocking/non-blocking semantics here as well
 184      (read-sequence vector stream :start (or start 0) :end end))))
 185
 186 #|(defun write-vector ...)|#
 187
 188 (defun read-octets (stream buffer start end blocking)
 189   (declare (type simple-stream stream)
 190            (type (or null simple-stream-buffer) buffer)
 191            (type fixnum start)
 192            (type (or null fixnum) end)
 193            (optimize (speed 3) (space 2) (safety 0) (debug 0)))
 194   (with-stream-class (simple-stream stream)
 195     (let ((fd (sm input-handle stream))
 196           (end (or end (sm buf-len stream)))
 197           (buffer (or buffer (sm buffer stream))))
 198       (declare (fixnum end))
 199       (typecase fd
 200         (fixnum
 201          (let ((flag (sb-sys:wait-until-fd-usable fd :input
 202                                                   (if blocking nil 0))))
 203            (cond
 204              ((and (not blocking) (= start end)) (if flag -3 0))
 205              ((and (not blocking) (not flag)) 0)
 206              (t (block nil
 207                   (let ((count 0))
 208                     (declare (type fixnum count))
 209                     (tagbody
 210                      again
 211                        ;; Avoid CMUCL gengc write barrier
 212                        (do ((i start (+ i (the fixnum (sb-posix:getpagesize)))))
 213                            ((>= i end))
 214                          (declare (type fixnum i))
 215                          (setf (bref buffer i) 0))
 216                        (setf (bref buffer (1- end)) 0)
 217                        (multiple-value-bind (bytes errno)
 218                            (sb-unix:unix-read fd (buffer-sap buffer start)
 219                                               (the fixnum (- end start)))
 220                          (declare (type (or null fixnum) bytes)
 221                                   (type (integer 0 100) errno))
 222                          (when bytes
 223                            (incf count bytes)
 224                            (incf start bytes))
 225                          (cond ((null bytes)
 226                                 (format *debug-io* "~&;; UNIX-READ: errno=~D~%" errno)
 227                                 (cond ((= errno sb-unix:eintr) (go again))
 228                                       ((and blocking
 229                                             (or (= errno ;;sb-unix:eagain
 230                                                    ;; FIXME: move
 231                                                    ;; eagain into
 232                                                    ;; sb-unix
 233                                                    11)
 234                                                 (= errno sb-unix:ewouldblock)))
 235                                        (sb-sys:wait-until-fd-usable fd :input nil)
 236                                        (go again))
 237                                       (t (return (- -10 errno)))))
 238                                ((zerop count) (return -1))
 239                                (t (return count)))))))))))
 240         ;; Handle encapsulated stream.  FIXME: perhaps handle
 241         ;; sbcl-vintage ansi-stream type in read-octets too?
 242         (stream (read-octets fd buffer start end blocking))
 243         (t (error "Don't know how to handle input handle &S" fd))))))
 244
 245 (defun write-octets (stream buffer start end blocking)
 246   (declare (type simple-stream stream)
 247            (type (or null simple-stream-buffer) buffer)
 248            (type fixnum start)
 249            (type (or null fixnum) end))
 250   (with-stream-class (simple-stream stream)
 251     (let ((fd (sm output-handle stream))
 252           (end (or end (error "WRITE-OCTETS: end=NIL")))
 253           (buffer (or buffer (error "WRITE-OCTETS: buffer=NIL"))))
 254       (typecase fd
 255         (fixnum
 256          (let ((flag (sb-sys:wait-until-fd-usable fd :output
 257                                                   (if blocking nil 0))))
 258            (cond
 259              ((and (not blocking) (= start end)) (if flag -3 0))
 260              ((and (not blocking) (not flag)) 0)
 261              (t
 262               (block nil
 263                 (let ((count 0))
 264                   (tagbody again
 265                      (multiple-value-bind (bytes errno)
 266                          (sb-unix:unix-write fd (buffer-sap buffer) start
 267                                              (- end start))
 268                        (when bytes
 269                          (incf count bytes)
 270                          (incf start bytes))
 271                        (cond ((null bytes)
 272                               (format *debug-io* "~&;; UNIX-WRITE: errno=~D~%"
 273                                       errno)
 274                               (cond ((= errno sb-unix:eintr) (go again))
 275                                     ;; don't block for subsequent chars
 276                                     (t (return (- -10 errno)))))
 277                              (t (return count)))))))))))
 278         ;; Handle encapsulated stream.  FIXME: perhaps handle
 279         ;; sbcl-vintage ansi-stream type in write-octets too?
 280         (stream (write-octets fd buffer start end blocking))
 281         (t (error "Don't know how to handle output handle &A" fd))))))
 282
 283
 284 ;;;
 285 ;;; IMPLEMENTATIONS
 286 ;;;
 287
 288
 289 ;;; simple-stream, dual-channel-simple-stream,
 290 ;;; single-channel-simple-stream
 291
 292 (defmethod device-buffer-length ((stream simple-stream))
 293   4096)
 294
 295 (defmethod device-file-position ((stream simple-stream))
 296   (with-stream-class (simple-stream stream)
 297     (cond ((any-stream-instance-flags stream :dual)
 298            (with-stream-class (dual-channel-simple-stream stream)
 299              (sm buffpos stream)))
 300           ((any-stream-instance-flags stream :string)
 301            (with-stream-class (string-simple-stream stream)
 302              (sm buffpos stream)))
 303           (t
 304            (with-stream-class (single-channel-simple-stream stream)
 305              (sm buffpos stream))))))
 306
 307
 308 (defmethod (setf device-file-position) (value (stream simple-stream))
 309   (with-stream-class (simple-stream stream)
 310     (cond ((any-stream-instance-flags stream :dual)
 311            (with-stream-class (dual-channel-simple-stream stream)
 312              (setf (sm buffpos stream) value)))
 313           ((any-stream-instance-flags stream :string)
 314            (with-stream-class (string-simple-stream stream)
 315              (setf (sm buffpos stream) value)))
 316           (t
 317            (with-stream-class (single-channel-simple-stream stream)
 318              (setf (sm buffpos stream) value))))))
 319
 320 (defmethod device-file-length ((stream simple-stream))
 321   nil)
 322
 323 (defmethod device-read ((stream single-channel-simple-stream) buffer
 324                         start end blocking)
 325   ;; rudi (2003-06-07): this block commented out in Paul Foley's code
 326 ;;   (when (and (null buffer) (not (eql start end)))
 327 ;;     (with-stream-class (single-channel-simple-stream stream)
 328 ;;       (setq buffer (sm buffer stream))
 329 ;;       (setq end (sm buf-len stream))))
 330   (read-octets stream buffer start end blocking))
 331
 332 (defmethod device-read ((stream dual-channel-simple-stream) buffer
 333                         start end blocking)
 334   (when (null buffer)
 335     (with-stream-class (dual-channel-simple-stream stream)
 336       (setq buffer (sm buffer stream))
 337       (setq end (- (sm buf-len stream) start))))
 338   (read-octets stream buffer start end blocking))
 339
 340 (defmethod device-clear-input ((stream simple-stream) buffer-only)
 341   (declare (ignore buffer-only))
 342   nil)
 343
 344 (defmethod device-write ((stream single-channel-simple-stream) buffer
 345                          start end blocking)
 346   (when (and (null buffer) (not (eql start end)))
 347     (with-stream-class (single-channel-simple-stream stream)
 348       (setf buffer (sm buffer stream))
 349       (setf end (sm buffpos stream))))
 350   (write-octets stream buffer start end blocking))
 351
 352 (defmethod device-write ((stream dual-channel-simple-stream) buffer
 353                          start end blocking)
 354   (when (and (null buffer) (not (eql start end)))
 355     (with-stream-class (dual-channel-simple-stream stream)
 356       (setf buffer (sm out-buffer stream))
 357       (setf end (sm outpos stream))))
 358   (write-octets stream buffer start end blocking))
 359
 360 (defmethod device-clear-output ((stream simple-stream))
 361   nil)
 362
 363
 364 ;;; Direct-Simple-Stream and Buffer-(Input|Output)-Simple-Stream
 365
 366 (defmethod device-file-length ((stream direct-simple-stream))
 367   ;; return buffer length
 368   )
 369
 370 (defmethod device-open ((stream buffer-input-simple-stream) options)
 371   #| do something |#
 372   stream)
 373
 374 (defmethod device-open ((stream buffer-output-simple-stream) options)
 375   #| do something |#
 376   stream)
 377
 378
 379 ;;; Definition of File-Simple-Stream and relations
 380
 381 (defun open-file-stream (stream options)
 382   (let ((filename (pathname (getf options :filename)))
 383         (direction (getf options :direction :input))
 384         (if-exists (getf options :if-exists))
 385         (if-exists-given (not (eql (getf options :if-exists t) t)))
 386         (if-does-not-exist (getf options :if-does-not-exist))
 387         (if-does-not-exist-given (not (eql (getf options :if-does-not-exist t) t))))
 388     (with-stream-class (file-simple-stream stream)
 389       (ecase direction
 390         (:input (add-stream-instance-flags stream :input))
 391         (:output (add-stream-instance-flags stream :output))
 392         (:io (add-stream-instance-flags stream :input :output)))
 393       (cond ((and (sm input-handle stream) (sm output-handle stream)
 394                   (not (eql (sm input-handle stream)
 395                             (sm output-handle stream))))
 396              (error "Input-Handle and Output-Handle can't be different."))
 397             ((or (sm input-handle stream) (sm output-handle stream))
 398              (add-stream-instance-flags stream :simple)
 399              ;; get namestring, etc. from handle, if possible (it's a stream)
 400              ;; set up buffers
 401              stream)
 402             (t
 403              (multiple-value-bind (fd namestring original delete-original)
 404                  (%fd-open filename direction if-exists if-exists-given
 405                            if-does-not-exist if-does-not-exist-given)
 406                (when fd
 407                  (add-stream-instance-flags stream :simple)
 408                  (setf (sm pathname stream) filename
 409                        (sm filename stream) namestring
 410                        (sm original stream) original
 411                        (sm delete-original stream) delete-original)
 412                  (when (any-stream-instance-flags stream :input)
 413                    (setf (sm input-handle stream) fd))
 414                  (when (any-stream-instance-flags stream :output)
 415                    (setf (sm output-handle stream) fd))
 416                  (sb-ext:finalize stream
 417                    (lambda ()
 418                      (sb-unix:unix-close fd)
 419                      (format *terminal-io* "~&;;; ** closed ~S (fd ~D)~%"
 420                              namestring fd)))
 421                  stream)))))))
 422
 423 (defmethod device-open ((stream file-simple-stream) options)
 424   (with-stream-class (file-simple-stream stream)
 425     (when (open-file-stream stream options)
 426       ;; Franz says:
 427       ;;  "The device-open method must be prepared to recognize resource
 428       ;;   and change-class situations. If no filename is specified in
 429       ;;   the options list, and if no input-handle or output-handle is
 430       ;;   given, then the input-handle and output-handle slots should
 431       ;;   be examined; if non-nil, that means the stream is still open,
 432       ;;   and thus the operation being requested of device-open is a
 433       ;;   change-class. Also, a device-open method need not allocate a
 434       ;;   buffer every time it is called, but may instead reuse a
 435       ;;   buffer it finds in a stream, if it does not become a security
 436       ;;   issue."
 437       (unless (sm buffer stream)
 438         (let ((length (device-buffer-length stream)))
 439           ;; Buffer should be array of (unsigned-byte 8), in general
 440           ;; use strings for now so it's easy to read the content...
 441           (setf (sm buffer stream) (make-string length)
 442                 (sm buffpos stream) 0
 443                 (sm buffer-ptr stream) 0
 444                 (sm buf-len stream) length)))
 445       (when (any-stream-instance-flags stream :output)
 446         (setf (sm control-out stream) *std-control-out-table*))
 447       (let ((efmt (getf options :external-format :default)))
 448         (compose-encapsulating-streams stream efmt)
 449         (install-single-channel-character-strategy stream efmt nil)))))
 450
 451 (defmethod device-close ((stream file-simple-stream) abort)
 452   (with-stream-class (file-simple-stream stream)
 453     (cond (abort
 454            ;; TODO:
 455            ;; Remove any fd-handler
 456            ;; If it's an output stream and has an original name,
 457            ;; revert the file
 458            )
 459           (t
 460            ;; TODO:
 461            ;; If there's an original name and delete-original is set
 462            ;; kill the original
 463            ))
 464     (if (sm input-handle stream)
 465         (sb-unix:unix-close (sm input-handle stream))
 466         (sb-unix:unix-close (sm output-handle stream)))
 467     (setf (sm buffer stream) nil))
 468   t)
 469
 470 (defmethod device-file-position ((stream file-simple-stream))
 471   (with-stream-class (file-simple-stream stream)
 472     (values (sb-unix:unix-lseek (or (sm input-handle stream)
 473                                     (sm output-handle stream))
 474                                 0
 475                                 sb-unix:l_incr))))
 476
 477 (defmethod (setf device-file-position) (value (stream file-simple-stream))
 478   (declare (type fixnum value))
 479   (with-stream-class (file-simple-stream stream)
 480     (values (sb-unix:unix-lseek (or (sm input-handle stream)
 481                                     (sm output-handle stream))
 482                                 value
 483                                 (if (minusp value)
 484                                     sb-unix:l_xtnd
 485                                     sb-unix:l_set)))))
 486
 487 (defmethod device-file-length ((stream file-simple-stream))
 488   (with-stream-class (file-simple-stream stream)
 489     (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
 490         (sb-unix:unix-fstat (sm input-handle stream))
 491       (declare (ignore dev ino mode nlink uid gid rdev))
 492       (if okay size nil))))
 493
 494 (defmethod device-open ((stream mapped-file-simple-stream) options)
 495   (with-stream-class (mapped-file-simple-stream stream)
 496     (when (open-file-stream stream options)
 497       (let* ((input (any-stream-instance-flags stream :input))
 498              (output (any-stream-instance-flags stream :output))
 499              (prot (logior (if input sb-posix::PROT-READ 0)
 500                            (if output sb-posix::PROT-WRITE 0)))
 501              (fd (or (sm input-handle stream) (sm output-handle stream))))
 502         (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
 503             (sb-unix:unix-fstat fd)
 504           (declare (ignore ino mode nlink uid gid rdev))
 505           (unless okay
 506             (sb-unix:unix-close fd)
 507             (sb-ext:cancel-finalization stream)
 508             (error "Error fstating ~S: ~A" stream
 509                    (sb-int:strerror dev)))
 510           (when (> size most-positive-fixnum)
 511             ;; Or else BUF-LEN has to be a general integer, or
 512             ;; maybe (unsigned-byte 32).  In any case, this means
 513             ;; BUF-MAX and BUF-PTR have to be the same, which means
 514             ;; number-consing every time BUF-PTR moves...
 515             ;; Probably don't have the address space available to map
 516             ;; bigger files, anyway.
 517             (warn "Unable to memory-map entire file.")
 518             (setf size most-positive-fixnum))
 519           (let ((buffer
 520                  (handler-case
 521                   (sb-posix:mmap nil size prot sb-posix::MAP-SHARED fd 0)
 522                   (sb-posix:syscall-error nil))))
 523             (when (null buffer)
 524               (sb-unix:unix-close fd)
 525               (sb-ext:cancel-finalization stream)
 526               (error "Unable to map file."))
 527             (setf (sm buffer stream) buffer
 528                   (sm buffpos stream) 0
 529                   (sm buffer-ptr stream) size
 530                   (sm buf-len stream) size)
 531             (install-single-channel-character-strategy
 532              stream (getf options :external-format :default) 'mapped)
 533             (sb-ext:finalize stream
 534               (lambda ()
 535                 (sb-posix:munmap buffer size)
 536                 (format *terminal-io* "~&;;; ** unmapped ~S" buffer)))))))
 537     stream))
 538
 539 (defmethod device-close ((stream mapped-file-simple-stream) abort)
 540   (with-stream-class (mapped-file-simple-stream stream)
 541     (when (sm buffer stream)
 542       (sb-posix:munmap (sm buffer stream) (sm buf-len stream))
 543       (setf (sm buffer stream) nil))
 544     (cond (abort
 545            ;; remove any FD handler
 546            ;; if it has an original name (is this possible for mapped files?)
 547            ;;   revert the file
 548            )
 549           (t
 550            ;; if there's an original name and delete-original is set (again,
 551            ;;   is this even possible?), kill the original
 552            ))
 553     (sb-unix:unix-close (sm input-handle stream)))
 554   t)
 555
 556
 557 ;;; Definition of Null-Simple-Stream
 558
 559
 560 (defmethod device-open ((stream null-simple-stream) options)
 561   (with-stream-class (null-simple-stream stream)
 562     (add-stream-instance-flags stream :simple :input :output)
 563     ;;(install-single-channel-character-strategy
 564     ;; stream (getf options :external-format :default) nil)
 565     (setf (sm j-read-char stream) #'null-read-char
 566           (sm j-read-chars stream) #'null-read-chars
 567           (sm j-unread-char stream) #'null-unread-char
 568           (sm j-write-char stream) #'null-write-char
 569           (sm j-write-chars stream) #'null-write-chars
 570           (sm j-listen stream) #'null-listen))
 571   stream)
 572
 573
 574 (defmethod device-buffer-length ((stream null-simple-stream))
 575   256)
 576
 577 (defmethod device-read ((stream null-simple-stream) buffer
 578                         start end blocking)
 579   (declare (ignore buffer start end blocking))
 580   -1)
 581
 582 (defmethod device-write ((stream null-simple-stream) buffer
 583                          start end blocking)
 584   (declare (ignore buffer blocking))
 585   (- end start))
 586
 587
 588 ;;; Socket-Simple-Stream and relatives
 589
 590
 591 (defmethod device-open ((stream socket-base-simple-stream) options)
 592   #| do something |#
 593   stream)
 594
 595 (defmethod device-open ((stream socket-simple-stream) options)
 596   (with-stream-class (socket-simple-stream stream)
 597      (let* ((remote-host (getf options :remote-host))
 598             (remote-port (getf options :remote-port))
 599             (socket (make-instance 'sb-bsd-sockets:inet-socket
 600                                    :type :stream :protocol :tcp)))
 601        (setf (sm socket stream) socket)
 602        (sb-bsd-sockets:socket-connect socket remote-host remote-port)
 603        (let ((fd (sb-bsd-sockets:socket-file-descriptor socket)))
 604          ;; Connect stream to socket, ...
 605          (setf (sm input-handle stream) fd)
 606          (setf (sm output-handle stream) fd)
 607          ;; ... and socket to stream.
 608          (setf (slot-value socket 'stream) stream)
 609          (sb-ext:cancel-finalization socket)
 610          (sb-ext:finalize stream
 611                           (lambda ()
 612                             (sb-unix:unix-close fd)
 613                             (format *terminal-io*
 614                                     "~&;;; ** closed socket (fd ~D)~%" fd))))
 615        ;; Now frob the stream slots.  FIXME: should we handle a
 616        ;; :direction arg from output, defaulting to :input only?
 617        (add-stream-instance-flags stream :simple :input :output :dual)
 618        (unless (sm buffer stream)
 619          (let ((length (device-buffer-length stream)))
 620            ;; Buffer should be array of (unsigned-byte 8), in general
 621            ;; use strings for now so it's easy to read the content...
 622            (setf (sm buffer stream) (make-string length)
 623                  (sm buffpos stream) 0
 624                  (sm buffer-ptr stream) 0
 625                  (sm buf-len stream) length)))
 626        (unless (sm out-buffer stream)
 627         (let ((length (device-buffer-length stream)))
 628           (setf (sm out-buffer stream) (make-string length)
 629                 (sm max-out-pos stream) length)))
 630        (setf (sm control-in stream) *terminal-control-in-table*)
 631        (setf (sm control-out stream) *std-control-out-table*)
 632        (install-dual-channel-character-strategy
 633         stream (getf options :external-format :default)))
 634      stream))
 635
 636 (defmethod device-close ((stream socket-simple-stream) abort)
 637   ;; Abort argument is handled by :around method on base class
 638   (declare (ignore abort))
 639   (with-stream-class (socket-simple-stream stream)
 640     (sb-unix:unix-close (sm input-handle stream))
 641     (setf (sm buffer stream) nil)
 642     (setf (sm out-buffer stream) nil))
 643   (sb-ext:cancel-finalization stream)
 644   t)
 645
 646
 647 ;;; String-Simple-Stream and relatives
 648
 649
 650 (defmethod device-file-position ((stream string-simple-stream))
 651   ;; get string length (of input or output buffer?)
 652   )
 653
 654 (defmethod (setf device-file-position) (value (stream string-simple-stream))
 655   ;; set string length (of input or output buffer?)
 656   )
 657
 658 (defmethod device-file-length ((stream string-simple-stream))
 659   ;; return string length
 660   )
 661
 662 (defmethod device-open :before ((stream string-input-simple-stream) options)
 663   (with-stream-class (string-input-simple-stream stream)
 664     (let ((string (getf options :string)))
 665       (when (and string (null (sm buffer stream)))
 666         (let ((start (getf options :start))
 667               (end (or (getf options :end) (length string))))
 668           (setf (sm buffer stream) string
 669                 (sm buffpos stream) start
 670                 (sm buffer-ptr stream) end))))
 671     (install-string-input-character-strategy stream)
 672     (add-stream-instance-flags stream :string :input :simple)))
 673
 674 (defmethod device-open :before ((stream string-output-simple-stream) options)
 675   (with-stream-class (string-output-simple-stream stream)
 676     (unless (sm out-buffer stream)
 677       (let ((string (getf options :string)))
 678         (if string
 679             (setf (sm out-buffer stream) string
 680                   (sm max-out-pos stream) (length string))
 681             (let ((buflen (max (device-buffer-length stream) 16)))
 682               (setf (sm out-buffer stream) (make-string buflen)
 683                     (sm max-out-pos stream) buflen)))))
 684     (unless (sm control-out stream)
 685       (setf (sm control-out stream) *std-control-out-table*))
 686     (install-string-output-character-strategy stream)
 687     (add-stream-instance-flags stream :string :output :simple)))
 688
 689
 690 (defmethod device-open ((stream string-input-simple-stream) options)
 691   #| do something |#
 692   stream)
 693
 694
 695 (defmethod device-open ((stream string-output-simple-stream) options)
 696   #| do something |#
 697   stream)
 698
 699
 700 (defmethod device-open ((stream xp-simple-stream) options)
 701   #| do something |#
 702   stream)
 703
 704 (defmethod device-open ((stream fill-pointer-output-simple-stream) options)
 705   #| do something |#
 706   stream)
 707
 708 (defmethod device-file-position ((stream fill-pointer-output-simple-stream))
 709   ;; get fill pointer (of input or output buffer?)
 710   )
 711
 712 (defmethod (setf device-file-position)
 713     (value (stream fill-pointer-output-simple-stream))
 714   ;; set fill pointer (of input or output buffer?)
 715   )
 716
 717
 718 ;;; Terminal-Simple-Stream
 719
 720 (defmethod device-open ((stream terminal-simple-stream) options)
 721   (with-stream-class (terminal-simple-stream stream)
 722     (when (getf options :input-handle)
 723       (setf (sm input-handle stream) (getf options :input-handle))
 724       (add-stream-instance-flags stream :simple :interactive :dual :input)
 725       (unless (sm buffer stream)
 726         (let ((length (device-buffer-length stream)))
 727           (setf (sm buffer stream) (make-string length)
 728                 (sm buf-len stream) length)))
 729       (setf (sm control-in stream) *terminal-control-in-table*))
 730     (when (getf options :output-handle)
 731       (setf (sm output-handle stream) (getf options :output-handle))
 732       (add-stream-instance-flags stream :simple :interactive :dual :output)
 733       (unless (sm out-buffer stream)
 734         (let ((length (device-buffer-length stream)))
 735           (setf (sm out-buffer stream) (make-string length)
 736                 (sm max-out-pos stream) length)))
 737       (setf (sm control-out stream) *std-control-out-table*))
 738     (install-dual-channel-character-strategy
 739      stream (getf options :external-format :default)))
 740   ;; TODO (rudi 2003-06-08): when neither input-handle nor
 741   ;; output-handle are given, close the stream again.
 742   #| do something |#
 743   stream)
 744
 745 (defmethod device-read ((stream terminal-simple-stream) buffer
 746                         start end blocking)
 747   (let ((result (call-next-method)))
 748     (if (= result -1) -2 result)))
 749
 750 (defmethod device-clear-input ((stream terminal-simple-stream) buffer-only)
 751   )
 752
 753 (defmethod device-close ((stream simple-stream) abort)
 754   (declare (ignore abort))
 755   t)
 756
 757
 758
 759
 760
 761
 762
 763
 764
 765
 766
 767 (defmethod device-read ((stream terminal-simple-stream) buffer
 768                         start end blocking)
 769   (let ((result (call-next-method)))
 770     (if (= result -1) -2 result)))
 771
 772
 773
 774 (defmethod device-clear-input ((stream terminal-simple-stream) buffer-only)
 775   )
 776
 777
 778
 779 (defmethod device-write ((stream socket-base-simple-stream) buffer
 780                          start end blocking)
 781   ;; @@2
 782   (call-next-method))
 783
 784
 785
 786
 787
 788
 789
 790
 791 ;; device-finish-record apparently has no methods defined
 792
 793
 794 ;;;
 795 ;;; IMPLEMENTATIONS FOR FOREIGN STREAMS
 796 ;;; (SYS:LISP-STREAM AND EXT:FUNDAMENTAL-STREAM)
 797 ;;;
 798
 799
 800 ;;;
 801 ;;; CREATION OF STANDARD STREAMS
 802 ;;;
 803