[cxml-cvs] CVS cxml/runes
dlichteblau
dlichteblau at common-lisp.net
Sat Jun 16 11:27:19 UTC 2007
Update of /project/cxml/cvsroot/cxml/runes
In directory clnet:/tmp/cvs-serv20513/runes
Modified Files:
package.lisp ystream.lisp
Added Files:
stream-scl.lisp
Log Message:
SCL support (thanks to Douglas Crosher). Includes support for
implementations where URIs are valid namestrings, and a mode
where normal streams are used instead of xstreams and ystreams
(albeit both SCL-specific at this point).
--- /project/cxml/cvsroot/cxml/runes/package.lisp 2006/12/02 13:21:36 1.7
+++ /project/cxml/cvsroot/cxml/runes/package.lisp 2007/06/16 11:27:19 1.8
@@ -79,7 +79,11 @@
#:make-string-ystream/utf8
;; #+rune-is-integer
#:make-character-stream-ystream/utf8
- #:runes-to-utf8/adjustable-string))
+ #:runes-to-utf8/adjustable-string
+
+ #:rod-to-utf8-string
+ #:utf8-string-to-rod
+ #:make-octet-input-stream))
(defpackage :utf8-runes
(:use :cl)
--- /project/cxml/cvsroot/cxml/runes/ystream.lisp 2006/12/02 13:21:36 1.5
+++ /project/cxml/cvsroot/cxml/runes/ystream.lisp 2007/06/16 11:27:19 1.6
@@ -248,3 +248,50 @@
(defmethod close-ystream ((ystream string-ystream/utf8))
(get-output-stream-string (ystream-os-stream ystream))))
+
+
+;;;; helper functions
+
+(defun rod-to-utf8-string (rod)
+ (let ((out (make-buffer :element-type 'character)))
+ (runes-to-utf8/adjustable-string out rod (length rod))
+ out))
+
+(defun utf8-string-to-rod (str)
+ (let* ((bytes (map '(vector (unsigned-byte 8)) #'char-code str))
+ (buffer (make-array (length bytes) :element-type '(unsigned-byte 16)))
+ (n (runes-encoding:decode-sequence
+ :utf-8 bytes 0 (length bytes) buffer 0 0 nil))
+ (result (make-array n :element-type 'rune)))
+ (map-into result #'code-rune buffer)
+ result))
+
+(defclass octet-input-stream
+ (trivial-gray-stream-mixin fundamental-binary-input-stream)
+ ((octets :initarg :octets)
+ (pos :initform 0)))
+
+(defmethod close ((stream octet-input-stream) &key abort)
+ (declare (ignore abort))
+ (open-stream-p stream))
+
+(defmethod stream-read-byte ((stream octet-input-stream))
+ (with-slots (octets pos) stream
+ (if (>= pos (length octets))
+ :eof
+ (prog1
+ (elt octets pos)
+ (incf pos)))))
+
+(defmethod stream-read-sequence
+ ((stream octet-input-stream) sequence start end &key &allow-other-keys)
+ (with-slots (octets pos) stream
+ (let* ((length (min (- end start) (- (length octets) pos)))
+ (end1 (+ start length))
+ (end2 (+ pos length)))
+ (replace sequence octets :start1 start :end1 end1 :start2 pos :end2 end2)
+ (setf pos end2)
+ end1)))
+
+(defun make-octet-input-stream (octets)
+ (make-instance 'octet-input-stream :octets octets))
--- /project/cxml/cvsroot/cxml/runes/stream-scl.lisp 2007/06/16 11:27:19 NONE
+++ /project/cxml/cvsroot/cxml/runes/stream-scl.lisp 2007/06/16 11:27:19 1.1
;;; -*- 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))
More information about the Cxml-cvs
mailing list