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 ;; TODO: use the buffer pool
  25 ;; TODO: handle instance reinitialization
  26 (defmethod shared-initialize :after ((s dual-channel-gray-stream) slot-names
  27                                      &key (input-buffer-size +bytes-per-iobuf+)
  28                                      (output-buffer-size +bytes-per-iobuf+)
  29                                      (external-format :default))
  30   (declare (ignore slot-names))
  31   (check-type input-buffer-size buffer-index)
  32   (check-type output-buffer-size buffer-index)
  33   (when (open-stream-p s) (close s))
  34   (with-slots ((ib input-buffer) (ob output-buffer)
  35                (ef external-format)) s
  36     (setf ib (allocate-iobuf input-buffer-size)
  37           ob (allocate-iobuf output-buffer-size))
  38     (setf ef (etypecase external-format
  39                (symbol (find-external-format external-format))
  40                ((and list (not null))
  41                 (apply #'make-external-format external-format))))))
  42 \f
  43 ;;;;;;;;;;;;;;;;;;;;
  44 ;;                ;;
  45 ;; Common Methods ;;
  46 ;;                ;;
  47 ;;;;;;;;;;;;;;;;;;;;
  48
  49 (defmethod stream-element-type ((stream active-socket))
  50   :default)
  51
  52 ;; TODO: use abort
  53 ;; TODO: use the buffer pool
  54 (defmethod close :around ((stream active-socket) &key abort)
  55   (declare (ignore abort))
  56   (with-slots ((ib input-buffer)
  57                (ob output-buffer)) stream
  58     (when ib (free-iobuf ib))
  59     (when ob (free-iobuf ob))
  60     (setf ib nil ob nil))
  61   (call-next-method)
  62   (values stream))
  63
  64 (defmethod close ((stream dual-channel-gray-stream) &key abort)
  65   (declare (ignore stream abort)))
  66 \f
  67 ;;;;;;;;;;;;;;;;;;;
  68 ;;               ;;
  69 ;; Input Methods ;;
  70 ;;               ;;
  71 ;;;;;;;;;;;;;;;;;;;
  72
  73 (defmethod stream-clear-input ((stream active-socket))
  74   (with-slots ((ib input-buffer)) stream
  75     (iobuf-reset ib)
  76     nil))
  77
  78 ;; (defmethod stream-read-sequence ((stream active-socket) seq
  79 ;;                                  &optional start end)
  80 ;;   )
  81 \f
  82 ;;;;;;;;;;;;;;;;;;;;
  83 ;;                ;;
  84 ;; Output Methods ;;
  85 ;;                ;;
  86 ;;;;;;;;;;;;;;;;;;;;
  87
  88 (defmethod stream-clear-output ((stream active-socket))
  89   (with-slots ((ob output-buffer)) stream
  90     (iobuf-reset ob)
  91     nil))
  92
  93 ;; (defmethod stream-finish-output ((stream active-socket))
  94 ;;   (with-slots ((ob output-buffer)) stream
  95 ;;     nil))
  96
  97 ;; (defmethod stream-force-output ((stream active-socket))
  98 ;;   (with-slots ((ob output-buffer)) stream
  99 ;;     nil))
 100
 101 ;; (defmethod stream-read-sequence ((stream active-socket) seq
 102 ;;                                  &optional start end)
 103 ;;   )
 104 \f
 105 ;;;;;;;;;;;;;;;;;;;;;
 106 ;;                 ;;
 107 ;; Character Input ;;
 108 ;;                 ;;
 109 ;;;;;;;;;;;;;;;;;;;;;
 110
 111 (defun fill-iobuf (buf fd &optional timeout)
 112   (iomux:wait-until-fd-ready fd :read timeout)
 113   (let ((num (et:read fd (cffi:inc-pointer (iobuf-data buf)
 114                                            (iobuf-start buf))
 115                       (- (iobuf-size buf)
 116                          (iobuf-end buf)))))
 117     (if (zerop num)
 118         :eof
 119         (incf (iobuf-end buf) num))))
 120
 121 (defun maybe-find-line-ending (fd ib ef)
 122   (let* ((start-off (iobuf-start ib))
 123          (char-code (bref ib start-off)))
 124     (block nil
 125       (ecase (ioenc:ef-line-terminator ef)
 126         (:unix (when (= char-code (char-code #\Linefeed))
 127                  (incf (iobuf-start ib))
 128                  (return (values #\Newline 1))))
 129         (:mac (when (= char-code (char-code #\Return))
 130                 (incf (iobuf-start ib))
 131                 (return (values #\Newline 1))))
 132         (:dos (when (= char-code (char-code #\Return))
 133                 (when (and (= (iobuf-length ib) 1)
 134                            (eq (fill-iobuf ib fd) :eof))
 135                   (incf (iobuf-start ib))
 136                   (return (values #\Return 1)))
 137                 (when (= (bref ib (1+ start-off))
 138                          (char-code #\Linefeed))
 139                   (incf (iobuf-start ib) 2)
 140                   (return (values #\Newline 2)))))))))
 141
 142 (defmethod stream-read-char ((stream active-socket))
 143   (with-slots ((fd fd) (ib input-buffer)
 144                (pos istream-pos)
 145                (ef external-format)) stream
 146     (let ((str (make-string 1))
 147           (ret nil))
 148       (flet ((fill-buf-or-eof ()
 149                (setf ret (fill-iobuf ib fd))
 150                (when (eq ret :eof)
 151                  (return-from stream-read-char :eof))))
 152         (cond ((zerop (iobuf-length ib))
 153                (iobuf-reset ib)
 154                (fill-buf-or-eof))
 155               ((< 0 (iobuf-end-space-length ib) 4)
 156                (iobuf-copy-data-to-start ib)))
 157         ;; line-end handling
 158         (multiple-value-bind (line-end bytes-consumed)
 159             (maybe-find-line-ending fd ib ef)
 160           (when line-end
 161             (incf pos bytes-consumed)
 162             (return-from stream-read-char line-end)))
 163         (tagbody :start
 164            (handler-case
 165                (setf ret (nth-value 1 (ioenc::%octets-to-string
 166                                        (iobuf-data ib) str
 167                                        (iobuf-start ib)
 168                                        (iobuf-end ib) ef 1)))
 169              (end-of-input-in-character (err)
 170                (declare (ignore err))
 171                (fill-buf-or-eof)
 172                (go :start)))
 173            (incf pos ret)
 174            (incf (iobuf-start ib) ret))
 175         (char str 0)))))
 176
 177 (defun maybe-find-line-ending-no-hang (fd ib ef)
 178   (declare (ignore fd))
 179   (let* ((start-off (iobuf-start ib))
 180          (char-code (bref ib start-off)))
 181     (block nil
 182       (ecase (ioenc:ef-line-terminator ef)
 183         (:unix (when (= char-code (char-code #\Linefeed))
 184                  (incf (iobuf-start ib))
 185                  (return (values #\Newline 1))))
 186         (:mac (when (= char-code (char-code #\Return))
 187                 (incf (iobuf-start ib))
 188                 (return (values #\Newline 1))))
 189         (:dos (when (= char-code (char-code #\Return))
 190                 (when (= (iobuf-length ib) 1)
 191                   (incf (iobuf-start ib))
 192                   (return :starvation))
 193                 (when (= (bref ib (1+ start-off))
 194                          (char-code #\Linefeed))
 195                   (incf (iobuf-start ib) 2)
 196                   (return (values #\Newline 2)))))))))
 197
 198 (defmethod stream-read-char-no-hang ((stream active-socket))
 199   (with-slots ((fd fd) (ib input-buffer)
 200                (pos istream-pos)
 201                (ef external-format)) stream
 202     (let ((str (make-string 1))
 203           (ret nil)
 204           (eof nil))
 205       (block nil
 206         (when (< 0 (iobuf-end-space-length ib) 4)
 207           (iobuf-copy-data-to-start ib))
 208         (when (and (iomux:fd-ready-p fd :read)
 209                    (eql :eof (fill-iobuf ib fd)))
 210           (setf eof t))
 211         (when (zerop (iobuf-length ib))
 212           (return (if eof :eof nil)))
 213         ;; line-end handling
 214         (multiple-value-bind (line-end bytes-consumed)
 215             (maybe-find-line-ending-no-hang fd ib ef)
 216           (cond ((eql line-end :starvation)
 217                  (if eof
 218                      (progn
 219                        (incf pos)
 220                        (return #\Return))
 221                      (return nil)))
 222                 ((characterp line-end)
 223                  (incf pos bytes-consumed)
 224                  (return line-end))))
 225         ;; octet decoding
 226         (handler-case
 227             (setf ret (nth-value 1 (ioenc::%octets-to-string
 228                                     (iobuf-data ib) str
 229                                     (iobuf-start ib)
 230                                     (iobuf-end ib) ef 1)))
 231           (end-of-input-in-character (err)
 232             (declare (ignore err))
 233             (return nil)))
 234         (incf pos ret)
 235         (incf (iobuf-start ib) ret)
 236         (char str 0)))))
 237
 238 (defmethod stream-peek-char ((stream active-socket))
 239   (let ((char (stream-read-char stream)))
 240     (if (eq char :eof)
 241         :eof
 242         (progn
 243           (stream-unread-char stream char)
 244           (values char)))))
 245
 246 ;; (defmethod stream-read-line ((stream active-socket))
 247 ;;   (with-slots ((fd fd) (ib input-buffer)
 248 ;;                (pos istream-pos)
 249 ;;                (ef external-format)) stream
 250 ;;     (let ((str (make-string 80)) (strsz 80) (strlen 0)
 251 ;;           (chars-out 0) (bytes-in 0)
 252 ;;           (ret nil))
 253 ;;       )))
 254
 255 (defmethod stream-listen ((stream active-socket))
 256   (characterp (stream-read-char-no-hang stream)))
 257
 258 ;; (defmethod stream-unread-char ((stream active-socket) character))
 259 \f
 260 ;;;;;;;;;;;;;;;;;;;;;;
 261 ;;                  ;;
 262 ;; Character Output ;;
 263 ;;                  ;;
 264 ;;;;;;;;;;;;;;;;;;;;;;
 265
 266 (defun buffer-string-to-octets (string buffer start end ef fd &optional max-char-num)
 267   (declare (string string)
 268            (type iobuf buffer)
 269            (type buffer-index start)
 270            (type buffer-index end)
 271            (ignore fd)
 272            (optimize (speed 3) (space 0) (safety 0) (debug 0)))
 273   (unless max-char-num (setf max-char-num -1))
 274   (let ((ptr start) oldptr
 275         (pos -1) oldpos
 276         (char-count -1))
 277     (tagbody
 278        (flet ((input ()
 279                 (prog1 (char string ptr) (incf ptr)))
 280               (output (octet)
 281                 (setf (bref buffer (incf pos)) octet))
 282               (error-fn (symbol)
 283                 (restart-case
 284                     (error symbol :string string
 285                            :start start :end end
 286                            :position oldptr
 287                            :external-format (ef-name ef))
 288                   (use-value (s)
 289                     :report "Supply a replacement character."
 290                     :interactive ioenc::read-replacement-char
 291                     s)
 292                   (use-standard-unicode-replacement ()
 293                     :report "Use standard UCS replacement character"
 294                     (code-char ioenc::+replacement-char+))
 295                   (stop-decoding ()
 296                     :report "Stop decoding and return to last good offset."
 297                     (setf pos oldpos)
 298                     (go :exit)))))
 299          (loop :while (and (< ptr end)
 300                            (/= (incf char-count) max-char-num))
 301             :do (setf oldpos pos oldptr ptr)
 302             (ioenc::char-to-octets ef #'input #'output #'error-fn (- end ptr))))
 303      :exit (return-from buffer-string-to-octets (1+ pos)))))
 304
 305 ;; (defmethod stream-write-char ((stream active-socket) character)
 306 ;;   )
 307
 308 ;; (defmethod stream-advance-to-column ((stream active-socket)
 309 ;;                                      (column integer)))
 310
 311 ;; (defmethod stream-line-column ((stream active-socket)))
 312
 313 ;; (defmethod stream-line-length ((stream active-socket)))
 314
 315 (defmethod stream-start-line-p ((stream active-socket))
 316   nil)
 317
 318 ;; (defmethod stream-terpri ((stream active-socket)))
 319
 320 ;; (defmethod stream-fresh-line ((stream active-socket)))
 321
 322 ;; (defmethod stream-write-string ((stream active-socket)
 323 ;;                                 (string string)
 324 ;;                                 &optional start end))
 325 \f
 326 ;;;;;;;;;;;;;;;;;;
 327 ;;              ;;
 328 ;; Binary Input ;;
 329 ;;              ;;
 330 ;;;;;;;;;;;;;;;;;;
 331
 332 (defmethod stream-read-byte ((stream active-socket))
 333   (with-slots ((fd fd) (ib input-buffer)
 334                (pos istream-pos)) stream
 335     (let ((ret nil))
 336       (flet ((fill-buf-or-eof ()
 337                (setf ret (fill-iobuf ib fd))
 338                (when (eq ret :eof)
 339                  (return-from stream-read-byte :eof))))
 340         (cond ((zerop (iobuf-length ib))
 341                (iobuf-reset ib)
 342                (fill-buf-or-eof))
 343               ((< 0 (iobuf-end-space-length ib) 4)
 344                (iobuf-copy-data-to-start ib)))
 345         (prog1 (bref ib (iobuf-start ib))
 346           (incf pos)
 347           (incf (iobuf-start ib)))))))
 348 \f
 349 ;;;;;;;;;;;;;;;;;;;
 350 ;;               ;;
 351 ;; Binary Output ;;
 352 ;;               ;;
 353 ;;;;;;;;;;;;;;;;;;;
 354
 355 ;; (defmethod stream-write-byte ((stream active-socket) (integer integer))
 356 ;;   )