stream-scl.lisp

   1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; readtable: runes; Encoding: utf-8; -*-
   2 ;;; ---------------------------------------------------------------------------
   3 ;;;     Title: Fast streams
   4 ;;;   Created: 1999-07-17
   5 ;;;    Author: Douglas Crosher
   6 ;;;   License: Lisp-LGPL (See file COPYING for details).
   7 ;;; ---------------------------------------------------------------------------
   8 ;;;  (c) copyright 2007 by Douglas Crosher
   9
  10 ;;; This library is free software; you can redistribute it and/or
  11 ;;; modify it under the terms of the GNU Library General Public
  12 ;;; License as published by the Free Software Foundation; either
  13 ;;; version 2 of the License, or (at your option) any later version.
  14 ;;;
  15 ;;; This library is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;;; Library General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU Library General Public
  21 ;;; License along with this library; if not, write to the
  22 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;;; Boston, MA  02111-1307  USA.
  24
  25 (in-package :runes)
  26
  27 (eval-when (:compile-toplevel :load-toplevel :execute)
  28   (defparameter *fast* '(optimize (speed 3) (safety 3))))
  29
  30 (deftype runes-encoding:encoding-error ()
  31   'ext:character-conversion-error)
  32
  33 \f
  34 ;;; xstream
  35
  36 (eval-when (:compile-toplevel :load-toplevel :execute)
  37
  38 (defclass xstream (ext:character-stream)
  39   ((name :initarg :name :initform nil
  40          :accessor xstream-name)
  41    (column :initarg :column :initform 0)
  42    (line :initarg :line :initform 1)
  43    (unread-column :initarg :unread-column :initform 0)))
  44
  45 (defclass eol-conversion-xstream (lisp::eol-conversion-input-stream xstream)
  46   ())
  47
  48 ) ; eval-when
  49
  50 (defun make-eol-conversion-xstream (source-stream)
  51   "Returns a character stream that conversion CR-LF pairs and lone CR
  52   characters into single linefeed character."
  53   (declare (type stream source-stream))
  54   (let ((stream (ext:make-eol-conversion-stream source-stream
  55                                                 :input t
  56                                                 :close-stream-p t)))
  57     (change-class stream 'eol-conversion-xstream)))
  58
  59 (definline xstream-p (stream)
  60   (typep stream 'xstream))
  61
  62 (defun close-xstream (input)
  63   (close input))
  64
  65 (definline read-rune (input)
  66   (declare (type stream input)
  67            (inline read-char)
  68            #.*fast*)
  69   (let ((char (read-char input nil :eof)))
  70     (cond ((member char '(#\UFFFE #\UFFFF))
  71            ;; These characters are illegal within XML documents.
  72            (simple-error 'ext:character-conversion-error
  73                          "~@<Illegal XML document character: ~S~:@>" char))
  74           ((eql char #\linefeed)
  75            (setf (slot-value input 'unread-column) (slot-value input 'column))
  76            (setf (slot-value input 'column) 0)
  77            (incf (the kernel:index (slot-value input 'line))))
  78           (t
  79            (incf (the kernel:index (slot-value input 'column)))))
  80     char))
  81
  82 (definline peek-rune (input)
  83   (declare (type stream input)
  84            (inline peek-char)
  85            #.*fast*)
  86   (peek-char nil input nil :eof))
  87
  88 (definline consume-rune (input)
  89   (declare (type stream input)
  90            (inline read-rune)
  91            #.*fast*)
  92   (read-rune input)
  93   nil)
  94
  95 (definline unread-rune (rune input)
  96   (declare (type stream input)
  97            (inline unread-char)
  98            #.*fast*)
  99   (unread-char rune input)
 100   (cond ((eql rune #\linefeed)
 101          (setf (slot-value input 'column) (slot-value input 'unread-column))
 102          (setf (slot-value input 'unread-column) 0)
 103          (decf (the kernel:index (slot-value input 'line))))
 104         (t
 105          (decf (the kernel:index (slot-value input 'column)))))
 106   nil)
 107
 108 (defun fread-rune (input)
 109   (read-rune input))
 110
 111 (defun fpeek-rune (input)
 112   (peek-rune input))
 113
 114 (defun xstream-position (input)
 115   (file-position input))
 116
 117 (defun runes-encoding:find-encoding (encoding)
 118   encoding)
 119
 120 (defun make-xstream (os-stream &key name
 121                                     (speed 8192)
 122                                     (initial-speed 1)
 123                                     (initial-encoding :guess))
 124   (declare (ignore speed))
 125   (assert (eql initial-speed 1))
 126   (assert (eq initial-encoding :guess))
 127   (let* ((stream (ext:make-xml-character-conversion-stream os-stream
 128                                                            :input t
 129                                                            :close-stream-p t))
 130          (xstream (make-eol-conversion-xstream stream)))
 131     (setf (xstream-name xstream) name)
 132     xstream))
 133
 134
 135 (defclass xstream-string-input-stream (lisp::string-input-stream xstream)
 136   ())
 137
 138 (defun make-rod-xstream (string &key name)
 139   (declare (type string string))
 140   (let ((stream (make-string-input-stream string)))
 141     (change-class stream 'xstream-string-input-stream :name name)))
 142
 143 ;;; already at 'full speed' so just return the buffer size.
 144 (defun set-to-full-speed (stream)
 145   (length (ext:stream-in-buffer stream)))
 146
 147 (defun xstream-speed (stream)
 148   (length (ext:stream-in-buffer stream)))
 149
 150 (defun xstream-line-number (stream)
 151   (slot-value stream 'line))
 152
 153 (defun xstream-column-number (stream)
 154   (slot-value stream 'column))
 155
 156 (defun xstream-encoding (stream)
 157   (stream-external-format stream))
 158
 159 ;;; the encoding will have already been detected, but it is checked against the
 160 ;;; declared encoding here.
 161 (defun (setf xstream-encoding) (declared-encoding stream)
 162   (let* ((initial-encoding (xstream-encoding stream))
 163          (canonical-encoding
 164           (cond ((and (eq initial-encoding :utf-16le)
 165                       (member declared-encoding '(:utf-16 :utf16 :utf-16le :utf16le)
 166                               :test 'string-equal))
 167                  :utf-16le)
 168                 ((and (eq initial-encoding :utf-16be)
 169                       (member declared-encoding '(:utf-16 :utf16 :utf-16be :utf16be)
 170                               :test 'string-equal))
 171                  :utf-16be)
 172                 ((and (eq initial-encoding :ucs-4be)
 173                       (member declared-encoding '(:ucs-4 :ucs4 :ucs-4be :ucs4be)
 174                               :test 'string-equal))
 175                  :ucs4-be)
 176                 ((and (eq initial-encoding :ucs-4le)
 177                       (member declared-encoding '(:ucs-4 :ucs4 :ucs-4le :ucs4le)
 178                               :test 'string-equal))
 179                  :ucs4-le)
 180                 (t
 181                  declared-encoding))))
 182     (unless (string-equal initial-encoding canonical-encoding)
 183       (warn "Unable to change xstream encoding from ~S to ~S (~S)~%"
 184             initial-encoding declared-encoding canonical-encoding))
 185     declared-encoding))
 186
 187 \f
 188 ;;; ystream - a run output stream.
 189
 190 (deftype ystream () 'stream)
 191
 192 (defun ystream-column (stream)
 193   (ext:line-column stream))
 194
 195 (definline write-rune (rune stream)
 196   (declare (inline write-char))
 197   (write-char rune stream))
 198
 199 (defun write-rod (rod stream)
 200   (declare (type rod rod)
 201            (type stream stream))
 202   (write-string rod stream))
 203
 204 (defun make-rod-ystream ()
 205   (make-string-output-stream))
 206
 207 (defun close-ystream (stream)
 208   (etypecase stream
 209     (ext:string-output-stream
 210      (get-output-stream-string stream))
 211     (ext:character-conversion-output-stream
 212      (let ((target (slot-value stream 'stream)))
 213        (close stream)
 214        (if (typep target 'ext:byte-output-stream)
 215            (ext:get-output-stream-bytes target)
 216            stream)))))
 217
 218 ;;;; CHARACTER-STREAM-YSTREAM
 219
 220 (defun make-character-stream-ystream (target-stream)
 221   target-stream)
 222
 223
 224 ;;;; OCTET-VECTOR-YSTREAM
 225
 226 (defun make-octet-vector-ystream ()
 227   (let ((target (ext:make-byte-output-stream)))
 228     (ext:make-character-conversion-stream target :output t
 229                                           :external-format :utf-8
 230                                           :close-stream-p t)))
 231
 232 ;;;; OCTET-STREAM-YSTREAM
 233
 234 (defun make-octet-stream-ystream (os-stream)
 235   (ext:make-character-conversion-stream os-stream :output t
 236                                         :external-format :utf-8
 237                                         :close-stream-p t))
 238
 239 \f
 240 ;;;; helper functions
 241
 242 (defun rod-to-utf8-string (rod)
 243   (ext:make-string-from-bytes (ext:make-bytes-from-string rod :utf8)
 244                               :iso-8859-1))
 245
 246 (defun utf8-string-to-rod (str)
 247   (let ((bytes (map '(vector (unsigned-byte 8)) #'char-code str)))
 248     (ext:make-string-from-bytes bytes :utf-8)))
 249
 250 (defun make-octet-input-stream (octets)
 251   (ext:make-byte-input-stream octets))
 252
 253 \f