cl-closure-common 20101107-1 / usr / share / common-lisp / source / closure-common / stream-scl.lisp

;;; -*- Mode: Lisp; Syntax: Common-Lisp; readtable: runes; Encoding: utf-8; -*-
;;; ---------------------------------------------------------------------------
;;;     Title: Fast streams
;;;   Created: 1999-07-17
;;;    Author: Douglas Crosher
;;;   License: Lisp-LGPL (See file COPYING for details).
;;; ---------------------------------------------------------------------------
;;;  (c) copyright 2007 by Douglas Crosher

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the 
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
;;; Boston, MA  02111-1307  USA.

(in-package :runes)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter *fast* '(optimize (speed 3) (safety 3))))

(deftype runes-encoding:encoding-error ()
  'ext:character-conversion-error)


;;; xstream

(eval-when (:compile-toplevel :load-toplevel :execute)

(defclass xstream (ext:character-stream)
  ((name :initarg :name :initform nil
	 :accessor xstream-name)
   (column :initarg :column :initform 0)
   (line :initarg :line :initform 1)
   (unread-column :initarg :unread-column :initform 0)))

(defclass eol-conversion-xstream (lisp::eol-conversion-input-stream xstream)
  ())

) ; eval-when

(defun make-eol-conversion-xstream (source-stream)
  "Returns a character stream that conversion CR-LF pairs and lone CR
  characters into single linefeed character."
  (declare (type stream source-stream))
  (let ((stream (ext:make-eol-conversion-stream source-stream
						:input t
						:close-stream-p t)))
    (change-class stream 'eol-conversion-xstream)))

(definline xstream-p (stream)
  (typep stream 'xstream))

(defun close-xstream (input)
  (close input))

(definline read-rune (input)
  (declare (type stream input)
	   (inline read-char)
	   #.*fast*)
  (let ((char (read-char input nil :eof)))
    (cond ((member char '(#\UFFFE #\UFFFF))
	   ;; These characters are illegal within XML documents.
	   (simple-error 'ext:character-conversion-error
			 "~@<Illegal XML document character: ~S~:@>" char))
	  ((eql char #\linefeed)
	   (setf (slot-value input 'unread-column) (slot-value input 'column))
	   (setf (slot-value input 'column) 0)
	   (incf (the kernel:index (slot-value input 'line))))
	  (t
	   (incf (the kernel:index (slot-value input 'column)))))
    char))

(definline peek-rune (input)
  (declare (type stream input)
	   (inline peek-char)
	   #.*fast*)
  (peek-char nil input nil :eof))

(definline consume-rune (input)
  (declare (type stream input)
	   (inline read-rune)
	   #.*fast*)
  (read-rune input)
  nil)

(definline unread-rune (rune input)
  (declare (type stream input)
	   (inline unread-char)
	   #.*fast*)
  (unread-char rune input)
  (cond ((eql rune #\linefeed)
	 (setf (slot-value input 'column) (slot-value input 'unread-column))
	 (setf (slot-value input 'unread-column) 0)
	 (decf (the kernel:index (slot-value input 'line))))
	(t
	 (decf (the kernel:index (slot-value input 'column)))))
  nil)

(defun fread-rune (input)
  (read-rune input))

(defun fpeek-rune (input)
  (peek-rune input))

(defun xstream-position (input)
  (file-position input))

(defun runes-encoding:find-encoding (encoding)
  encoding)

(defun make-xstream (os-stream &key name
                                    (speed 8192)
                                    (initial-speed 1)
                                    (initial-encoding :guess))
  (declare (ignore speed))
  (assert (eql initial-speed 1))
  (assert (eq initial-encoding :guess))
  (let* ((stream (ext:make-xml-character-conversion-stream os-stream
							   :input t
							   :close-stream-p t))
	 (xstream (make-eol-conversion-xstream stream)))
    (setf (xstream-name xstream) name)
    xstream))


(defclass xstream-string-input-stream (lisp::string-input-stream xstream)
  ())

(defun make-rod-xstream (string &key name)
  (declare (type string string))
  (let ((stream (make-string-input-stream string)))
    (change-class stream 'xstream-string-input-stream :name name)))

;;; already at 'full speed' so just return the buffer size.
(defun set-to-full-speed (stream)
  (length (ext:stream-in-buffer stream)))

(defun xstream-speed (stream)
  (length (ext:stream-in-buffer stream)))

(defun xstream-line-number (stream)
  (slot-value stream 'line))

(defun xstream-column-number (stream)
  (slot-value stream 'column))

(defun xstream-encoding (stream)
  (stream-external-format stream))

;;; the encoding will have already been detected, but it is checked against the
;;; declared encoding here.
(defun (setf xstream-encoding) (declared-encoding stream)
  (let* ((initial-encoding (xstream-encoding stream))
	 (canonical-encoding
	  (cond ((and (eq initial-encoding :utf-16le)
		      (member declared-encoding '(:utf-16 :utf16 :utf-16le :utf16le)
			      :test 'string-equal))
		 :utf-16le)
		((and (eq initial-encoding :utf-16be)
		      (member declared-encoding '(:utf-16 :utf16 :utf-16be :utf16be)
			      :test 'string-equal))
		 :utf-16be)
		((and (eq initial-encoding :ucs-4be)
		      (member declared-encoding '(:ucs-4 :ucs4 :ucs-4be :ucs4be)
			      :test 'string-equal))
		 :ucs4-be)
		((and (eq initial-encoding :ucs-4le)
		      (member declared-encoding '(:ucs-4 :ucs4 :ucs-4le :ucs4le)
			      :test 'string-equal))
		 :ucs4-le)
		(t
		 declared-encoding))))
    (unless (string-equal initial-encoding canonical-encoding)
      (warn "Unable to change xstream encoding from ~S to ~S (~S)~%"
	    initial-encoding declared-encoding canonical-encoding))
    declared-encoding))


;;; ystream - a run output stream.

(deftype ystream () 'stream)

(defun ystream-column (stream)
  (ext:line-column stream))

(definline write-rune (rune stream)
  (declare (inline write-char))
  (write-char rune stream))

(defun write-rod (rod stream)
  (declare (type rod rod)
	   (type stream stream))
  (write-string rod stream))

(defun make-rod-ystream ()
  (make-string-output-stream))

(defun close-ystream (stream)
  (etypecase stream
    (ext:string-output-stream
     (get-output-stream-string stream))
    (ext:character-conversion-output-stream
     (let ((target (slot-value stream 'stream)))
       (close stream)
       (if (typep target 'ext:byte-output-stream)
	   (ext:get-output-stream-bytes target)
	   stream)))))

;;;; CHARACTER-STREAM-YSTREAM

(defun make-character-stream-ystream (target-stream)
  target-stream)


;;;; OCTET-VECTOR-YSTREAM

(defun make-octet-vector-ystream ()
  (let ((target (ext:make-byte-output-stream)))
    (ext:make-character-conversion-stream target :output t
					  :external-format :utf-8
					  :close-stream-p t)))

;;;; OCTET-STREAM-YSTREAM

(defun make-octet-stream-ystream (os-stream)
  (ext:make-character-conversion-stream os-stream :output t
					:external-format :utf-8
					:close-stream-p t))


;;;; helper functions

(defun rod-to-utf8-string (rod)
  (ext:make-string-from-bytes (ext:make-bytes-from-string rod :utf8)
			      :iso-8859-1))

(defun utf8-string-to-rod (str)
  (let ((bytes (map '(vector (unsigned-byte 8)) #'char-code str)))
    (ext:make-string-from-bytes bytes :utf-8)))

(defun make-octet-input-stream (octets)
  (ext:make-byte-input-stream octets))