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 (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-accessors ((ib input-buffer-of) (ob output-buffer-of)
  37                    (ef external-format-of)) 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   '(unsigned-byte 8))
  53
  54 ;; TODO: use the buffer pool
  55 (defmethod close :around ((stream active-socket) &key abort)
  56   (unless abort (finish-output stream))
  57   (with-accessors ((ib input-buffer-of)
  58                    (ob output-buffer-of)) stream
  59     (when ib (free-iobuf ib))
  60     (when ob (free-iobuf ob))
  61     (setf ib nil ob nil))
  62   (call-next-method)
  63   (values stream))
  64
  65 (defmethod close ((stream dual-channel-gray-stream) &key abort)
  66   (declare (ignore stream abort)))
  67 \f
  68 ;;;;;;;;;;;;;;;;;;;
  69 ;;               ;;
  70 ;; Input Methods ;;
  71 ;;               ;;
  72 ;;;;;;;;;;;;;;;;;;;
  73
  74 (defmethod stream-clear-input ((stream active-socket))
  75   (with-accessors ((ib input-buffer-of)) stream
  76     (iobuf-reset ib)
  77     nil))
  78
  79 (defun %fill-ibuf (buf fd &optional timeout)
  80   (when timeout
  81     (let ((status
  82            (iomux:wait-until-fd-ready fd :read timeout)))
  83       ;; FIXME signal something better
  84       (cond ((member :timeout status)
  85              (return-from %fill-ibuf :timeout))
  86             ((member :error status)
  87              (error "WAIT-UNTIL-FD-READY returned :ERROR on FD ~S" fd)))))
  88   (let ((num (et:repeat-upon-eintr
  89                (et:read fd (iobuf-end-pointer buf)
  90                         (iobuf-end-space-length buf)))))
  91     (if (zerop num)
  92         :eof
  93         (incf (iobuf-end buf) num))))
  94
  95 (defun %read-into-simple-array-ub8 (stream array start end)
  96   (declare (type dual-channel-gray-stream stream))
  97   (with-accessors ((ib input-buffer-of)
  98                    (fd socket-fd)) stream
  99     (let ((octets-needed (- end start)))
 100       (loop :with array-offset := start
 101             :for octets-in-buffer := (iobuf-length ib)
 102             :for nbytes := (min octets-needed octets-in-buffer)
 103          :when (plusp nbytes) :do
 104            (iobuf-copy-into-lisp-array ib (iobuf-start ib)
 105                                        array array-offset nbytes)
 106            (incf array-offset nbytes)
 107            (decf octets-needed nbytes)
 108            (incf (iobuf-start ib) nbytes)
 109          :if (zerop octets-needed) :do (loop-finish)
 110          :else :do (iobuf-reset ib)
 111          :when (eql :eof (%fill-ibuf ib fd)) :do (loop-finish)
 112          :finally (return array-offset)))))
 113
 114 (defun %read-into-string (stream string start end)
 115   (declare (type dual-channel-gray-stream stream))
 116   (loop :for offset :from start :below end
 117         :for char := (stream-read-char stream)
 118      :if (eql char :eof) :do (loop-finish)
 119      :else :do (setf (char string offset) char)
 120      :finally (return offset)))
 121
 122 (defun %read-into-vector (stream vector start end)
 123   (declare (type dual-channel-gray-stream stream))
 124   (loop :for offset :from start :below end
 125         :for octet := (stream-read-byte stream)
 126      :if (eql octet :eof) :do (loop-finish)
 127      :else :do (setf (aref vector offset) octet)
 128      :finally (return offset)))
 129
 130 #-clisp
 131 (defmethod stream-read-sequence ((stream active-socket) seq
 132                                  &optional (start 0) end)
 133   (setf (values start end) (%check-bounds seq start end))
 134   (when (< start end)
 135     (etypecase seq
 136       (ub8-sarray
 137        (%read-into-simple-array-ub8 stream seq start end))
 138       (string
 139        (%read-into-string stream seq start end))
 140       (vector
 141        (%read-into-vector stream seq start end)))))
 142
 143 #+clisp
 144 (defmethod stream-read-byte-sequence ((stream active-socket) seq
 145                                       &optional (start 0) end
 146                                       no-hang interactive)
 147   (declare (ignore no-hang interactive))
 148   (setf (values start end) (%check-bounds seq start end))
 149   (when (< start end)
 150     (etypecase seq
 151       (ub8-sarray
 152        (%read-into-simple-array-ub8 stream seq start end))
 153       (vector
 154        (%read-into-vector stream seq start end)))))
 155
 156 #+clisp
 157 (defmethod stream-read-char-sequence ((stream active-socket) seq
 158                                       &optional (start 0) end)
 159   (setf (values start end) (%check-bounds seq start end))
 160   (when (< start end)
 161     (etypecase seq
 162       (string
 163        (%read-into-string stream seq start end)))))
 164 \f
 165 ;;;;;;;;;;;;;;;;;;;;
 166 ;;                ;;
 167 ;; Output Methods ;;
 168 ;;                ;;
 169 ;;;;;;;;;;;;;;;;;;;;
 170
 171 (defun %write-n-bytes (buf fd nbytes &optional timeout)
 172   (let ((bytes-written 0))
 173     (flet ((write-once ()
 174              (let ((num (handler-case
 175                             (et:repeat-upon-eintr
 176                               (et:write fd (inc-pointer buf bytes-written)
 177                                         nbytes))
 178                           (et:unix-error-pipe (err) (declare (ignore err))
 179                             (return-from %write-n-bytes (values nil :eof))))))
 180                (unless (zerop num) (incf bytes-written num))))
 181            (buffer-emptyp () (zerop nbytes)))
 182       (let (num)
 183         (if (buffer-emptyp) (values t nil)
 184             (et:repeat-decreasing-timeout (timeout-var timeout)
 185               (unless (setf num (write-once))
 186                 (when (member :error (iomux:wait-until-fd-ready fd :write))
 187                   ;; FIXME signal something better -- maybe analyze the status
 188                   (return-from %write-n-bytes (values nil :fail))))
 189               (when (buffer-emptyp) (return-from %write-n-bytes (values t bytes-written)))
 190               (when (zerop timeout-var) (return-from %write-n-bytes (values nil :timeout)))))))))
 191
 192 (defun %flush-obuf (buf fd &optional timeout)
 193   (let ((bytes-written 0))
 194     (flet ((write-once ()
 195              (let ((num (handler-case
 196                             (et:repeat-upon-eintr
 197                               (et:write fd (iobuf-start-pointer buf)
 198                                         (iobuf-length buf)))
 199                           (et:unix-error-pipe (err) (declare (ignore err))
 200                             (return-from %flush-obuf (values nil :eof))))))
 201                (unless (zerop num)
 202                  (incf (iobuf-start buf) num)
 203                  (incf bytes-written num))))
 204            (buffer-emptyp ()
 205              (when (iobuf-empty-p buf)
 206                (iobuf-reset buf) t)))
 207       (let (num)
 208         (if (buffer-emptyp) (values t nil)
 209             (et:repeat-decreasing-timeout (timeout-var timeout)
 210               (unless (setf num (write-once))
 211                 (when (member :error (iomux:wait-until-fd-ready fd :write))
 212                   ;; FIXME signal something better -- maybe analyze the status
 213                   (return-from %flush-obuf (values nil :fail))))
 214               (when (buffer-emptyp) (return-from %flush-obuf (values t bytes-written)))
 215               (when (zerop timeout-var) (return-from %flush-obuf (values nil :timeout)))))))))
 216
 217 (defun %flush-obuf-if-needed (stream)
 218   (declare (type dual-channel-gray-stream stream))
 219   (with-accessors ((fd socket-fd) (ob output-buffer-of)
 220                    (must-flush-output-p must-flush-output-p)) stream
 221     (when (or must-flush-output-p (iobuf-full-p ob))
 222       (%flush-obuf ob fd)
 223       (setf must-flush-output-p nil))))
 224
 225 (defmethod stream-clear-output ((stream active-socket))
 226   (with-accessors ((ob output-buffer-of)
 227                    (must-flush-output-p must-flush-output-p)
 228                    (fd socket-fd)) stream
 229     (iobuf-reset ob)
 230     (setf must-flush-output-p nil)
 231     nil))
 232
 233 (defmethod stream-finish-output ((stream active-socket))
 234   (with-accessors ((ob output-buffer-of)
 235                    (must-flush-output-p must-flush-output-p)
 236                    (fd socket-fd)) stream
 237     (%flush-obuf ob fd)
 238     (setf must-flush-output-p nil)
 239     nil))
 240
 241 (defmethod stream-force-output ((stream active-socket))
 242   (setf (must-flush-output-p stream) t))
 243
 244 (defun %write-simple-array-ub8 (stream array start end)
 245   (declare (type dual-channel-gray-stream stream))
 246   (with-accessors ((ob output-buffer-of)
 247                    (fd socket-fd)) stream
 248     (let ((octets-needed (- end start)))
 249       (if (<= octets-needed (iobuf-end-space-length ob))
 250           (progn
 251             (iobuf-copy-from-lisp-array array start ob
 252                                         (iobuf-end ob) octets-needed)
 253             (incf (iobuf-end ob) octets-needed)
 254             (%flush-obuf-if-needed stream))
 255           (with-pointer-to-vector-data (ptr array)
 256             (%flush-obuf ob fd)
 257             (let ((ret (%write-n-bytes (inc-pointer ptr start)
 258                                        fd octets-needed)))
 259               (when (numberp ret)
 260                 (incf (iobuf-end ob) octets-needed)))))
 261       (values array))))
 262
 263 (defun %write-vector-ub8 (stream vector start end)
 264   (declare (type dual-channel-gray-stream stream))
 265   (%write-simple-array-ub8 stream (coerce vector 'ub8-sarray) start end))
 266
 267 (defun %write-vector (stream vector start end)
 268   (declare (type dual-channel-gray-stream stream))
 269   (loop :for offset :from start :below end
 270         :for octet := (aref vector offset)
 271      :do (stream-write-byte stream octet)
 272      :finally (return vector)))
 273
 274 #-clisp
 275 (defmethod stream-write-sequence ((stream active-socket) seq
 276                                   &optional (start 0) end)
 277   (setf (values start end) (%check-bounds seq start end))
 278   (when (< start end)
 279     (etypecase seq
 280       (ub8-sarray
 281        (%write-simple-array-ub8 stream seq start end))
 282       (string
 283        (stream-write-string stream seq start end))
 284       ((vector ub8)
 285        (%write-vector-ub8 stream seq start end))
 286       (vector
 287        (%write-vector stream seq start end)))))
 288
 289 #+clisp
 290 (defmethod stream-write-byte-sequence ((stream active-socket) seq
 291                                        &optional (start 0) end
 292                                        no-hang interactive)
 293   (declare (ignore no-hang interactive))
 294   (setf (values start end) (%check-bounds seq start end))
 295   (when (< start end)
 296     (etypecase seq
 297       (ub8-sarray
 298        (%write-simple-array-ub8 stream seq start end))
 299       ((vector ub8)
 300        (%write-vector-ub8 stream seq start end))
 301       (vector
 302        (%write-vector stream seq start end)))))
 303
 304 #+clisp
 305 (defmethod stream-write-char-sequence ((stream active-socket) seq
 306                                        &optional (start 0) end)
 307   (setf (values start end) (%check-bounds seq start end))
 308   (when (< start end)
 309     (etypecase seq
 310       (string
 311        (stream-write-string stream seq start end)))))
 312 \f
 313 ;;;;;;;;;;;;;;;;;;;;;
 314 ;;                 ;;
 315 ;; Character Input ;;
 316 ;;                 ;;
 317 ;;;;;;;;;;;;;;;;;;;;;
 318
 319 (defun maybe-find-line-ending (fd ib ef)
 320   (let* ((start-off (iobuf-start ib))
 321          (char-code (bref ib start-off)))
 322     (block nil
 323       (ecase (ioenc:ef-line-terminator ef)
 324         (:unix (when (= char-code (char-code #\Linefeed))
 325                  (incf (iobuf-start ib))
 326                  (return #\Newline)))
 327         (:mac (when (= char-code (char-code #\Return))
 328                 (incf (iobuf-start ib))
 329                 (return #\Newline)))
 330         (:dos (when (= char-code (char-code #\Return))
 331                 (when (and (= (iobuf-length ib) 1)
 332                            (eql (%fill-ibuf ib fd) :eof))
 333                   (incf (iobuf-start ib))
 334                   (return #\Return))
 335                 (when (= (bref ib (1+ start-off))
 336                          (char-code #\Linefeed))
 337                   (incf (iobuf-start ib) 2)
 338                   (return #\Newline))))))))
 339
 340 ;; FIXME: currently we return :EOF when read(2) returns 0
 341 ;;        we should distinguish hard end-of-files(EOF and buffer empty)
 342 ;;        from soft end-of-files(EOF and *some* bytes still in the buffer
 343 ;;        but not enough to make a full character)
 344 (defmethod stream-read-char ((stream active-socket))
 345   (with-accessors ((fd socket-fd) (ib input-buffer-of)
 346                    (unread-index ibuf-unread-index-of)
 347                    (ef external-format-of)) stream
 348     (setf unread-index (iobuf-start ib))
 349     (let ((str (make-string 1))
 350           (ret nil))
 351       (flet ((fill-buf-or-eof ()
 352                (setf ret (%fill-ibuf ib fd))
 353                (when (eql ret :eof)
 354                  (return-from stream-read-char :eof))))
 355         (cond ((zerop (iobuf-length ib))
 356                (iobuf-reset ib)
 357                (fill-buf-or-eof))
 358               ;; Some encodings such as CESU or Java's modified UTF-8 take
 359               ;; as much as 6 bytes per character. Make sure we have enough
 360               ;; space to collect read-ahead bytes if required.
 361               ((< 0 (iobuf-end-space-length ib) +max-octets-per-char+)
 362                (iobuf-copy-data-to-start ib)
 363                (setf unread-index 0)))
 364         ;; line-end handling
 365         (let ((line-end
 366                (maybe-find-line-ending fd ib ef)))
 367           (when line-end
 368             (return-from stream-read-char line-end)))
 369         (tagbody :start
 370            (handler-case
 371                (setf ret (nth-value 1 (ioenc::%octets-to-string
 372                                        (iobuf-data ib) str
 373                                        (iobuf-start ib)
 374                                        (iobuf-end ib) ef 1)))
 375              (end-of-input-in-character (err)
 376                (declare (ignore err))
 377                (fill-buf-or-eof)
 378                (go :start)))
 379            (incf (iobuf-start ib) ret))
 380         (char str 0)))))
 381
 382 (defun maybe-find-line-ending-no-hang (fd ib ef)
 383   (declare (ignore fd))
 384   (let* ((start-off (iobuf-start ib))
 385          (char-code (bref ib start-off)))
 386     (block nil
 387       (ecase (ioenc:ef-line-terminator ef)
 388         (:unix (when (= char-code (char-code #\Linefeed))
 389                  (incf (iobuf-start ib))
 390                  (return #\Newline)))
 391         (:mac (when (= char-code (char-code #\Return))
 392                 (incf (iobuf-start ib))
 393                 (return #\Newline)))
 394         (:dos (when (= char-code (char-code #\Return))
 395                 (when (= (iobuf-length ib) 1)
 396                   (incf (iobuf-start ib))
 397                   (return :starvation))
 398                 (when (= (bref ib (1+ start-off))
 399                          (char-code #\Linefeed))
 400                   (incf (iobuf-start ib) 2)
 401                   (return #\Newline))))))))
 402
 403 (defmethod stream-read-char-no-hang ((stream active-socket))
 404   (with-accessors ((fd socket-fd) (ib input-buffer-of)
 405                    (ef external-format-of)) stream
 406     (let ((str (make-string 1))
 407           (ret nil)
 408           (eof nil))
 409       (block nil
 410         (when (< 0 (iobuf-end-space-length ib) 4)
 411           (iobuf-copy-data-to-start ib))
 412         (when (and (iomux:fd-ready-p fd :read)
 413                    (eql :eof (%fill-ibuf ib fd)))
 414           (setf eof t))
 415         (when (zerop (iobuf-length ib))
 416           (return (if eof :eof nil)))
 417         ;; line-end handling
 418         (let ((line-end
 419                (maybe-find-line-ending-no-hang fd ib ef)))
 420           (cond ((eql line-end :starvation)
 421                  (return (if eof #\Return nil)))
 422                 ((characterp line-end)
 423                  (return line-end))))
 424         ;; octet decoding
 425         (handler-case
 426             (setf ret (nth-value 1 (ioenc::%octets-to-string
 427                                     (iobuf-data ib) str
 428                                     (iobuf-start ib)
 429                                     (iobuf-end ib) ef 1)))
 430           (end-of-input-in-character (err)
 431             (declare (ignore err))
 432             (return nil)))
 433         (incf (iobuf-start ib) ret)
 434         (char str 0)))))
 435
 436 (defun %stream-unread-char (stream)
 437   (declare (type active-socket stream))
 438   (with-accessors ((ib input-buffer-of)
 439                    (unread-index ibuf-unread-index-of)) stream
 440     (symbol-macrolet ((start (iobuf-start ib)))
 441       (cond
 442         ((> start unread-index)
 443          (setf start unread-index))
 444         (t
 445          (error "No uncommitted character to unread")))))
 446   nil)
 447
 448 (defmethod stream-unread-char ((stream active-socket) character)
 449   ;; unreading anything but the latest character is wrong,
 450   ;; but checking is not mandated by the standard
 451   #+iolib-debug
 452   (progn
 453     (%stream-unread-char stream)
 454     (unless (ignore-errors (eql (stream-read-char stream) character))
 455       (error "Trying to unread wrong character ~S" character)))
 456   #-iolib-debug
 457   (declare (ignore character))
 458   #-iolib-debug
 459   (%stream-unread-char stream))
 460
 461 (defmethod stream-peek-char ((stream active-socket))
 462   (let ((char (stream-read-char stream)))
 463     (cond ((eql char :eof) :eof)
 464           (t (%stream-unread-char stream)
 465              (values char)))))
 466
 467 ;; (defmethod stream-read-line ((stream active-socket))
 468 ;;   )
 469
 470 (defmethod stream-listen ((stream active-socket))
 471   (let ((char (stream-read-char-no-hang stream)))
 472     (cond ((characterp char)
 473            (stream-unread-char stream char)
 474            t)
 475           ((eql char :eof)
 476            nil)
 477           (t t))))
 478 \f
 479 ;;;;;;;;;;;;;;;;;;;;;;
 480 ;;                  ;;
 481 ;; Character Output ;;
 482 ;;                  ;;
 483 ;;;;;;;;;;;;;;;;;;;;;;
 484
 485 (defmethod stream-write-char ((stream active-socket)
 486                               (character character))
 487   (%flush-obuf-if-needed stream)
 488   (if (eql character #\Newline)
 489       (%write-line-terminator stream (ioenc:ef-line-terminator (external-format-of stream)))
 490       ;; FIXME: avoid consing a string here. At worst, declare it dynamic-extent
 491       (stream-write-string stream (make-string 1 :initial-element character))))
 492
 493 (defmethod stream-start-line-p ((stream active-socket))
 494   (values nil))
 495
 496 (defmethod stream-terpri ((stream active-socket))
 497   (write-char #\Newline stream) nil)
 498
 499 (defmethod stream-fresh-line ((stream active-socket))
 500   (write-char #\Newline stream) t)
 501
 502 (define-constant +unix-line-terminator+
 503     (make-array 1 :element-type 'ub8 :initial-contents '(10)))
 504 (define-constant +dos-line-terminator+
 505     (make-array 2 :element-type 'ub8 :initial-contents '(13 10)))
 506 (define-constant +mac-line-terminator+
 507     (make-array 1 :element-type 'ub8 :initial-contents '(13)))
 508
 509 (defun %write-line-terminator (stream line-terminator)
 510   (case line-terminator
 511     (:unix (%write-simple-array-ub8 stream +unix-line-terminator+ 0 1))
 512     (:dos  (%write-simple-array-ub8 stream +dos-line-terminator+  0 2))
 513     (:mac  (%write-simple-array-ub8 stream +mac-line-terminator+  0 1))))
 514
 515 (defmethod stream-write-string ((stream active-socket)
 516                                 (string string)
 517                                 &optional (start 0) end)
 518   (setf (values start end) (%check-bounds string start end))
 519   (when (< start end)
 520     (let* ((octets nil)
 521            (ef (external-format-of stream))
 522            (line-terminator (ioenc:ef-line-terminator ef)))
 523       (loop :for off1 := start :then (1+ off2)
 524             :for nl-off := (position #\Newline string :start off1)
 525             :for off2 := (or nl-off end)
 526          :when nl-off :do (%write-line-terminator stream line-terminator)
 527          :when (> off2 off1) :do
 528          (setf octets (ioenc:string-to-octets
 529                        string :start off1 :end off2
 530                        :external-format ef))
 531          (%write-simple-array-ub8 stream octets 0 (length octets))
 532          :while (< off2 end))))
 533   (values string))
 534 \f
 535 ;;;;;;;;;;;;;;;;;;
 536 ;;              ;;
 537 ;; Binary Input ;;
 538 ;;              ;;
 539 ;;;;;;;;;;;;;;;;;;
 540
 541 (defmethod stream-read-byte ((stream active-socket))
 542   (with-accessors ((fd socket-fd)
 543                    (ib input-buffer-of)) stream
 544     (flet ((fill-buf-or-eof ()
 545              (iobuf-reset ib)
 546              (when (eql :eof (%fill-ibuf ib fd))
 547                (return-from stream-read-byte :eof))))
 548       (when (zerop (iobuf-length ib))
 549         (fill-buf-or-eof))
 550       (iobuf-pop-octet ib))))
 551 \f
 552 ;;;;;;;;;;;;;;;;;;;
 553 ;;               ;;
 554 ;; Binary Output ;;
 555 ;;               ;;
 556 ;;;;;;;;;;;;;;;;;;;
 557
 558 (defmethod stream-write-byte ((stream active-socket) integer)
 559   (check-type integer ub8 "an unsigned 8-bit value")
 560   (with-accessors ((ob output-buffer-of)) stream
 561     (%flush-obuf-if-needed stream)
 562     (iobuf-push-octet ob integer)))