sockets/gray-stream-methods.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;   Copyright (C) 2007 Stelian Ionescu
   4 ;;
   5 ;;   This code is free software; you can redistribute it and/or
   6 ;;   modify it under the terms of the version 2.1 of
   7 ;;   the GNU Lesser General Public License as published by
   8 ;;   the Free Software Foundation, as clarified by the
   9 ;;   preamble found here:
  10 ;;       http://opensource.franz.com/preamble.html
  11 ;;
  12 ;;   This program is distributed in the hope that it will be useful,
  13 ;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;   GNU General Public License for more details.
  16 ;;
  17 ;;   You should have received a copy of the GNU Lesser General
  18 ;;   Public License along with this library; if not, write to the
  19 ;;   Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  20 ;;   Boston, MA 02110-1301, USA
  21
  22 (in-package :net.sockets)
  23
  24 (iolib-utils:define-constant +max-octets-per-char+ 6)
  25
  26 ;; TODO: use the buffer pool
  27 ;; TODO: handle instance reinitialization
  28 (defmethod shared-initialize :after ((s dual-channel-gray-stream) slot-names
  29                                      &key (input-buffer-size +bytes-per-iobuf+)
  30                                      (output-buffer-size +bytes-per-iobuf+)
  31                                      (external-format :default))
  32   (declare (ignore slot-names))
  33   (check-type input-buffer-size buffer-index)
  34   (check-type output-buffer-size buffer-index)
  35   (when (open-stream-p s) (close s))
  36   (with-slots ((ib input-buffer) (ob output-buffer)
  37                (ef external-format)) s
  38     (setf ib (allocate-iobuf input-buffer-size)
  39           ob (allocate-iobuf output-buffer-size))
  40     (setf ef (etypecase external-format
  41                (symbol (find-external-format external-format))
  42                ((and list (not null))
  43                 (apply #'make-external-format external-format))))))
  44 \f
  45 ;;;;;;;;;;;;;;;;;;;;
  46 ;;                ;;
  47 ;; Common Methods ;;
  48 ;;                ;;
  49 ;;;;;;;;;;;;;;;;;;;;
  50
  51 (defmethod stream-element-type ((stream active-socket))
  52   :default)
  53
  54 ;; TODO: use abort
  55 ;; TODO: use the buffer pool
  56 (defmethod close :around ((stream active-socket) &key abort)
  57   (declare (ignore abort))
  58   (with-slots ((ib input-buffer)
  59                (ob output-buffer)) stream
  60     (when ib (free-iobuf ib))
  61     (when ob (free-iobuf ob))
  62     (setf ib nil ob nil))
  63   (call-next-method)
  64   (values stream))
  65
  66 (defmethod close ((stream dual-channel-gray-stream) &key abort)
  67   (declare (ignore stream abort)))
  68 \f
  69 ;;;;;;;;;;;;;;;;;;;
  70 ;;               ;;
  71 ;; Input Methods ;;
  72 ;;               ;;
  73 ;;;;;;;;;;;;;;;;;;;
  74
  75 (defmethod stream-clear-input ((stream active-socket))
  76   (with-slots ((ib input-buffer)) stream
  77     (iobuf-reset ib)
  78     nil))
  79
  80 ;; (defmethod stream-read-sequence ((stream active-socket) seq
  81 ;;                                  &optional start end)
  82 ;;   )
  83 \f
  84 ;;;;;;;;;;;;;;;;;;;;
  85 ;;                ;;
  86 ;; Output Methods ;;
  87 ;;                ;;
  88 ;;;;;;;;;;;;;;;;;;;;
  89
  90 (defmethod stream-clear-output ((stream active-socket))
  91   (with-slots ((ob output-buffer)) stream
  92     (iobuf-reset ob)
  93     nil))
  94
  95 (defmethod stream-finish-output ((stream active-socket))
  96   (with-slots ((ob output-buffer) fd) stream
  97     (flush-obuf ob fd)
  98     nil))
  99
 100 (defmethod stream-force-output ((stream active-socket))
 101   ;; FIXME: add non-blocking version of this?
 102   ;; and/or re-write the flush code in a non-blocking variant,
 103   ;; and have the finish-output synchronize on the result.
 104   (stream-finish-output stream))
 105
 106 ;; (defmethod stream-read-sequence ((stream active-socket) seq
 107 ;;                                  &optional start end)
 108 ;;   )
 109 \f
 110 ;;;;;;;;;;;;;;;;;;;;;
 111 ;;                 ;;
 112 ;; Character Input ;;
 113 ;;                 ;;
 114 ;;;;;;;;;;;;;;;;;;;;;
 115
 116 (defun fill-ibuf (buf fd &optional timeout)
 117   (when timeout
 118     (let ((status
 119            (iomux:wait-until-fd-ready fd :read timeout)))
 120       (unless (member :read status)
 121         ;; FIXME signal something better
 122         (return-from fill-ibuf :timeout))))
 123   (let ((num (et:read fd (cffi:inc-pointer (iobuf-data buf)
 124                                            (iobuf-start buf))
 125                       (- (iobuf-size buf)
 126                          (iobuf-end buf)))))
 127     (if (zerop num)
 128         :eof
 129         (incf (iobuf-end buf) num))))
 130
 131 (defun maybe-find-line-ending (fd ib ef)
 132   (let* ((start-off (iobuf-start ib))
 133          (char-code (bref ib start-off)))
 134     (block nil
 135       (ecase (ioenc:ef-line-terminator ef)
 136         (:unix (when (= char-code (char-code #\Linefeed))
 137                  (incf (iobuf-start ib))
 138                  (return (values #\Newline 1))))
 139         (:mac (when (= char-code (char-code #\Return))
 140                 (incf (iobuf-start ib))
 141                 (return (values #\Newline 1))))
 142         (:dos (when (= char-code (char-code #\Return))
 143                 (when (and (= (iobuf-length ib) 1)
 144                            (eq (fill-ibuf ib fd) :eof))
 145                   (incf (iobuf-start ib))
 146                   (return (values #\Return 1)))
 147                 (when (= (bref ib (1+ start-off))
 148                          (char-code #\Linefeed))
 149                   (incf (iobuf-start ib) 2)
 150                   (return (values #\Newline 2)))))))))
 151
 152 (defmethod stream-read-char ((stream active-socket))
 153   (with-slots ((fd fd) (ib input-buffer)
 154                (unread-index ibuf-unread-index)
 155                (pos istream-pos)
 156                (ef external-format)) stream
 157     (setf unread-index (iobuf-start ib))
 158     (let ((str (make-string 1))
 159           (ret nil))
 160       (flet ((fill-buf-or-eof ()
 161                ;; FIXME - what if we can't refill, in the middle of a wide-char??
 162                (setf ret (fill-ibuf ib fd))
 163                (when (eq ret :eof)
 164                  (return-from stream-read-char :eof))))
 165         (cond ((zerop (iobuf-length ib))
 166                (iobuf-reset ib)
 167                (fill-buf-or-eof))
 168               ;; Some encodings such as CESU or Java's modified UTF-8 take
 169               ;; as much as 6 bytes per character. Make sure we have enough
 170               ;; space to collect read-ahead bytes if required.
 171               ((< 0 (iobuf-end-space-length ib) +max-octets-per-char+)
 172                (iobuf-copy-data-to-start ib)
 173                (setf unread-index 0)))
 174         ;; line-end handling
 175         (multiple-value-bind (line-end bytes-consumed)
 176             (maybe-find-line-ending fd ib ef)
 177           (when line-end
 178             (incf pos bytes-consumed)
 179             (return-from stream-read-char line-end)))
 180         (tagbody :start
 181            (handler-case
 182                (setf ret (nth-value 1 (ioenc::%octets-to-string
 183                                        (iobuf-data ib) str
 184                                        (iobuf-start ib)
 185                                        (iobuf-end ib) ef 1)))
 186              (end-of-input-in-character (err)
 187                (declare (ignore err))
 188                (fill-buf-or-eof)
 189                (go :start)))
 190            (incf pos ret)
 191            (incf (iobuf-start ib) ret))
 192         (char str 0)))))
 193
 194 (defun maybe-find-line-ending-no-hang (fd ib ef)
 195   (declare (ignore fd))
 196   (let* ((start-off (iobuf-start ib))
 197          (char-code (bref ib start-off)))
 198     (block nil
 199       (ecase (ioenc:ef-line-terminator ef)
 200         (:unix (when (= char-code (char-code #\Linefeed))
 201                  (incf (iobuf-start ib))
 202                  (return (values #\Newline 1))))
 203         (:mac (when (= char-code (char-code #\Return))
 204                 (incf (iobuf-start ib))
 205                 (return (values #\Newline 1))))
 206         (:dos (when (= char-code (char-code #\Return))
 207                 (when (= (iobuf-length ib) 1)
 208                   (incf (iobuf-start ib))
 209                   (return :starvation))
 210                 (when (= (bref ib (1+ start-off))
 211                          (char-code #\Linefeed))
 212                   (incf (iobuf-start ib) 2)
 213                   (return (values #\Newline 2)))))))))
 214
 215 (defmethod stream-read-char-no-hang ((stream active-socket))
 216   (with-slots ((fd fd) (ib input-buffer)
 217                (pos istream-pos)
 218                (ef external-format)) stream
 219     (let ((str (make-string 1))
 220           (ret nil)
 221           (eof nil))
 222       (block nil
 223         (when (< 0 (iobuf-end-space-length ib) 4)
 224           (iobuf-copy-data-to-start ib))
 225         (when (and (iomux:fd-ready-p fd :read)
 226                    (eql :eof (fill-ibuf ib fd)))
 227           (setf eof t))
 228         (when (zerop (iobuf-length ib))
 229           (return (if eof :eof nil)))
 230         ;; line-end handling
 231         (multiple-value-bind (line-end bytes-consumed)
 232             (maybe-find-line-ending-no-hang fd ib ef)
 233           (cond ((eql line-end :starvation)
 234                  (if eof
 235                      (progn
 236                        (incf pos)
 237                        (return #\Return))
 238                      (return nil)))
 239                 ((characterp line-end)
 240                  (incf pos bytes-consumed)
 241                  (return line-end))))
 242         ;; octet decoding
 243         (handler-case
 244             (setf ret (nth-value 1 (ioenc::%octets-to-string
 245                                     (iobuf-data ib) str
 246                                     (iobuf-start ib)
 247                                     (iobuf-end ib) ef 1)))
 248           (end-of-input-in-character (err)
 249             (declare (ignore err))
 250             (return nil)))
 251         (incf pos ret)
 252         (incf (iobuf-start ib) ret)
 253         (char str 0)))))
 254
 255 (defun %stream-unread-char (stream)
 256   ;; unreading anything but the latest character is wrong,
 257   ;; but checking is not mandated by the standard
 258   #+super-anal-checks
 259   (progn
 260     (%stream-unread-char stream)
 261     (unless (ignore-errors (eql (stream-read-char stream) character))
 262       (error "Trying to unread wrong character ~S" character)))
 263   (declare (type active-socket stream))
 264   (with-slots ((ib input-buffer) (unread-index ibuf-unread-index)) stream
 265     (symbol-macrolet ((start (iobuf-start ib)))
 266       (cond
 267         ((> start unread-index)
 268          (setf start unread-index))
 269         (t
 270          (error "No uncommitted character to unread")))))
 271   nil)
 272
 273 (defmethod stream-unread-char ((stream active-socket) character)
 274   (declare (ignore character))
 275   (%stream-unread-char stream))
 276
 277 (defmethod stream-peek-char ((stream active-socket))
 278   (let ((char (stream-read-char stream)))
 279     (cond ((eq char :eof) :eof)
 280           (t (%stream-unread-char stream)
 281              (values char)))))
 282
 283 ;; (defmethod stream-read-line ((stream active-socket))
 284 ;;   (with-slots ((fd fd) (ib input-buffer)
 285 ;;                (pos istream-pos)
 286 ;;                (ef external-format)) stream
 287 ;;     (let ((str (make-string 80)) (strsz 80) (strlen 0)
 288 ;;           (chars-out 0) (bytes-in 0)
 289 ;;           (ret nil))
 290 ;;       )))
 291
 292 (defmethod stream-listen ((stream active-socket))
 293   (characterp (stream-read-char-no-hang stream)))
 294 \f
 295 ;;;;;;;;;;;;;;;;;;;;;;
 296 ;;                  ;;
 297 ;; Character Output ;;
 298 ;;                  ;;
 299 ;;;;;;;;;;;;;;;;;;;;;;
 300
 301 (defun buffer-string-to-octets (string buffer start end ef fd &optional max-char-num)
 302   (declare (string string)
 303            (type iobuf buffer)
 304            (type buffer-index start)
 305            (type buffer-index end)
 306            (ignore fd)
 307            (optimize (speed 3) (space 0) (safety 0) (debug 0)))
 308   (unless max-char-num (setf max-char-num -1))
 309   (let ((ptr start) oldptr
 310         (pos -1) oldpos
 311         (char-count -1))
 312     (labels
 313         ((input ()
 314            (prog1 (char string ptr) (incf ptr)))
 315          (output (octet)
 316            (setf (bref buffer (incf pos)) octet))
 317          (error-fn (symbol)
 318            (restart-case
 319                (error symbol :string string
 320                       :start start :end end
 321                       :position oldptr
 322                       :external-format (ef-name ef))
 323              (use-value (s)
 324                :report "Supply a replacement character."
 325                :interactive ioenc::read-replacement-char
 326                s)
 327              (use-standard-unicode-replacement ()
 328                :report "Use standard UCS replacement character"
 329                (code-char ioenc::+replacement-char+))
 330              (stop-decoding ()
 331                :report "Stop decoding and return to last good offset."
 332                (setf pos oldpos)
 333                (exit))))
 334          (exit ()
 335            (return-from buffer-string-to-octets (1+ pos))))
 336       (loop :while (and (< ptr end)
 337                         (/= (incf char-count) max-char-num))
 338          :do (setf oldpos pos oldptr ptr)
 339          (ioenc::char-to-octets ef #'input #'output #'error-fn (- end ptr)))
 340       (exit))))
 341
 342 (defun flush-obuf (buf fd &optional timeout)
 343   ;; FIXME - ought to loop partial writes until actual timeout,
 344   ;; interleaving write
 345   ;; computing the initial deadline, and retrying until it's passed
 346   (flet ((write-once ()
 347            (let* ((num (et:write
 348                         fd
 349                         (cffi:inc-pointer (iobuf-data buf)
 350                                           (iobuf-start buf))
 351                         (iobuf-length buf))))
 352              (if (zerop num)
 353                  nil
 354                  (progn (incf (iobuf-start buf) num) t))))
 355          (emptyp ()
 356            (when (iobuf-empty-p buf)
 357              (iobuf-reset buf)
 358              t)))
 359     (if (emptyp)
 360         (values t nil)
 361         (if timeout
 362             (loop :with deadline := (+ (iomux::gettime) timeout)
 363                :for status := (iomux:wait-until-fd-ready fd :write timeout) :do
 364                (unless (member :write status)
 365                  ;; FIXME signal something better -- maybe analyze the status
 366                  (return (values nil :timeout)))
 367                (unless (write-once)
 368                  (return (values nil :fail)))
 369                (when (emptyp)
 370                  (return (values t nil)))
 371                (setf timeout (- deadline (iomux::gettime)))
 372                (unless (> timeout 0)
 373                  (return (values nil :timeout))))
 374             (loop :for status := (iomux:wait-until-fd-ready fd :write nil) :do
 375                (unless (member :write status)
 376                  ;; FIXME signal something better -- maybe analyze the status
 377                  (return (values nil :fail)))
 378                (unless (write-once)
 379                  (return (values nil :fail)))
 380                (when (emptyp)
 381                  (return (values t nil))))))))
 382
 383
 384 (defmethod %stream-write-octets ((stream active-socket) octets
 385                                  &optional start end)
 386   ;; FIXME: when calling write-sequence with a simple-array of octets
 387   ;; do required I/O directly, not through a buffer
 388   (check-type octets (simple-array ub8 (*)))
 389   (let ((max (length octets)))
 390     (if start
 391         (check-type start unsigned-byte)
 392         (setf start 0))
 393     (if end
 394         (progn
 395           (check-type end unsigned-byte)
 396           (assert (<= end max)))
 397         (setf end max)))
 398   (with-slots ((buf output-buffer) fd) stream
 399     (loop :while (< start end) :do
 400          (let ((len (min (- end start) (iobuf-end-space-length buf))))
 401            (setf *print-readably* nil)
 402            ;; FIXME: optimize this BLT
 403            (loop :for i :from start
 404               :for j :from (iobuf-end buf)
 405               :repeat len :do
 406               (setf (bref buf j) (aref octets i)))
 407            (incf (iobuf-end buf) len)
 408            (incf start len)
 409            (when (= (iobuf-end buf) (iobuf-size buf))
 410              (or (flush-obuf buf fd)
 411                  ;; FIXME: better error handling
 412                  (error "Failed to write octets")))))))
 413
 414 (defmethod stream-write-char ((stream active-socket) character)
 415   ;; FIXME: avoid consing a string here. At worst, declare it dynamic-extent
 416   (stream-write-string stream (make-string 1 :initial-element character)))
 417
 418 ;; (defmethod stream-advance-to-column ((stream active-socket)
 419 ;;                                      (column integer)))
 420
 421 ;; (defmethod stream-line-column ((stream active-socket)))
 422
 423 ;; (defmethod stream-line-length ((stream active-socket)))
 424
 425 (defmethod stream-start-line-p ((stream active-socket))
 426   nil)
 427
 428 ;; (defmethod stream-terpri ((stream active-socket)))
 429
 430 ;; (defmethod stream-fresh-line ((stream active-socket)))
 431
 432 (defmethod stream-write-string ((stream active-socket)
 433                                 (string string)
 434                                 &optional start end)
 435   ;; FIXME: have the ef do i/o directly into the existing buffer,
 436   ;; don't do double buffering of I/O
 437   (%stream-write-octets
 438    stream
 439    (ioenc:string-to-octets string :start start :end end
 440                            :external-format (slot-value stream 'external-format))))
 441
 442 ;; FIXME: isn't there a generic stream-write-sequence???
 443
 444 \f
 445 ;;;;;;;;;;;;;;;;;;
 446 ;;              ;;
 447 ;; Binary Input ;;
 448 ;;              ;;
 449 ;;;;;;;;;;;;;;;;;;
 450
 451 (defmethod stream-read-byte ((stream active-socket))
 452   (with-slots ((fd fd) (ib input-buffer)
 453                (pos istream-pos)) stream
 454     (flet ((fill-buf-or-eof ()
 455              (when (eq :eof (fill-ibuf ib fd))
 456                (return-from stream-read-byte :eof))))
 457       (when (zerop (iobuf-length ib))
 458         (iobuf-reset ib)
 459         (fill-buf-or-eof))
 460       (prog1 (bref ib (iobuf-start ib))
 461         (incf pos)
 462         (incf (iobuf-start ib))))))
 463 \f
 464 ;;;;;;;;;;;;;;;;;;;
 465 ;;               ;;
 466 ;; Binary Output ;;
 467 ;;               ;;
 468 ;;;;;;;;;;;;;;;;;;;
 469
 470 ;; (defmethod stream-write-byte ((stream active-socket) (integer integer))
 471 ;;   )