...
 
Commits (1)
;;;; dom-builder.lisp -- DOM-building SAX handler
;;;;
;;;; This file is part of the CXML parser, released under (L)LGPL.
;;;; See file COPYING for details.
;;;;
;;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
;;;; Author: Henrik Motakef <hmot@henrik-motakef.de>
;;;; Author: David Lichteblau <david@lichteblau.com>
;;;; Author: knowledgeTools Int. GmbH
;;; XXX this DOM builder knows too much about the specifics of the DOM
;;; implementation for my taste. While document creation is not specified
;;; by the DOM Level 1 spec, we shouldn't really be manually setting slots
;;; in other nodes IMHO.
;;;
;;; As a follow-up to that, the children list is created in the wrong order
;;; and then reversed. Is it really worth the improved speed to do this?
;;; Calling APPEND-NODE would be portable.
;;;
;;; In particular, that design choice has lead to other bugs, for example the
;;; PARENT slot has to be set manually, too. A DOM test finally showed
;;; that this had been forgotten for Text nodes and PIs.
;;;
;;; Opinions?
;;;
;;; -- David
;;; Now at least the children list isn't reversed anymore, because I changed
;;; the representation to be an extensible vector. Still its not clear to
;;; me whether the DOM Builder should be affected by such changes at all.
;;;
;;; -- David
;;; implementation for my taste. We need a sensible protocol for fast DOM
;;; building.
(in-package :dom-impl)
......@@ -41,13 +32,16 @@
(push document (element-stack handler))))
(defmethod sax:end-document ((handler dom-builder))
(setf (slot-value (document handler) 'entities) xml::*entities*)
(setf (slot-value (document handler) 'dtd) (cxml::dtd cxml::*ctx*))
(let ((doctype (dom:doctype (document handler))))
(when doctype
(setf (slot-value (dom:entities doctype) 'read-only-p) t)
(setf (slot-value (dom:notations doctype) 'read-only-p) t)))
(document handler))
(defmethod sax:entity-resolver ((handler dom-builder) resolver)
(setf (slot-value (document handler) 'entity-resolver) resolver))
(defmethod sax:start-dtd ((handler dom-builder) name publicid systemid)
(declare (ignore publicid systemid))
(let* ((document (document handler))
......@@ -62,17 +56,36 @@
(setf (slot-value doctype 'dom-impl::owner) document
(slot-value document 'dom-impl::doc-type) doctype)))
(defmethod sax:start-element ((handler dom-builder) namespace-uri local-name qname attributes)
(defmethod sax:start-element
((handler dom-builder) namespace-uri local-name qname attributes)
(declare (ignore namespace-uri local-name))
(with-slots (document element-stack) handler
(let ((element (dom:create-element document qname))
(parent (car element-stack)))
(let ((element (make-instance 'element
:tag-name qname
:owner document))
(parent (car element-stack))
(anodes '()))
(dolist (attr attributes)
(dom:set-attribute element (xml::attribute-qname attr) (xml::attribute-value attr)))
(let ((anode
(dom:create-attribute document (sax:attribute-qname attr)))
(text
(dom:create-text-node document (sax:attribute-value attr))))
(setf (slot-value anode 'dom-impl::specified-p)
(sax:attribute-specified-p attr))
(dom:append-child anode text)
(push anode anodes)))
(setf (slot-value element 'dom-impl::parent) parent)
(fast-push element (slot-value parent 'dom-impl::children))
(setf (slot-value element 'dom-impl::attributes)
(make-instance 'attribute-node-map
:items anodes
:element-type :attribute
:element element
:owner document))
(push element element-stack))))
(defmethod sax:end-element ((handler dom-builder) namespace-uri local-name qname)
(declare (ignore namespace-uri local-name qname))
(pop (element-stack handler)))
(defmethod sax:characters ((handler dom-builder) data)
......@@ -121,13 +134,29 @@
(defmethod sax:unparsed-entity-declaration
((handler dom-builder) name public-id system-id notation-name)
(set-entity handler name public-id system-id notation-name))
(defmethod sax:external-entity-declaration
((handler dom-builder) kind name public-id system-id)
(ecase kind
(:general (set-entity handler name public-id system-id nil))
(:parameter)))
(defmethod sax:internal-entity-declaration
((handler dom-builder) kind name value)
(declare (ignore value))
(ecase kind
(:general (set-entity handler name nil nil nil))
(:parameter)))
(defun set-entity (handler name pid sid notation)
(dom:set-named-item (dom:entities (dom:doctype (document handler)))
(make-instance 'dom-impl::entity
:owner (document handler)
:name name
:public-id public-id
:system-id system-id
:notation-name notation-name)))
:public-id pid
:system-id sid
:notation-name notation)))
(defmethod sax:notation-declaration
((handler dom-builder) name public-id system-id)
......
;;;; dom-sax.lisp -- DOM walker
;;;;
;;;; This file is part of the CXML parser, released under (L)LGPL.
;;;; See file COPYING for details.
;;;;
;;;; Author: David Lichteblau <david@lichteblau.com>
;;;; Copyright (c) 2004 knowledgeTools Int. GmbH
(in-package :dom-impl)
(defun dom:map-document
......@@ -8,15 +16,20 @@
(let ((doctype (dom:doctype document)))
(when doctype
(sax:start-dtd handler (dom:name doctype) nil nil)
(let ((ns (dom:notations doctype)))
;; need notations for canonical mode 2
(let* ((ns (dom:notations doctype))
(a (make-array (dom:length ns))))
;; get them
(dotimes (k (dom:length ns))
(let ((n (dom:item ns k)))
(sax:notation-declaration handler
(dom:name n)
(dom:public-id n)
(dom:system-id n)))
;; fixme: entities!
)
(setf (elt a k) (dom:item ns k)))
;; sort them
(setf a (sort a #'rod< :key #'dom:name))
(loop for n across a do
(sax:notation-declaration handler
(dom:name n)
(dom:public-id n)
(dom:system-id n)))
;; fixme: entities!
(sax:end-dtd handler))))
(labels ((walk (node)
(dom:do-node-list (child (dom:child-nodes node))
......@@ -53,8 +66,8 @@
(when (and (or defaultp (dom:specified a))
(or xmlnsp (not (cxml::xmlns-attr-p (dom:name a)))))
(push
(cxml::make-attribute :qname (dom:name a)
:value (dom:value a)
:specified-p (dom:specified a))
(sax:make-attribute :qname (dom:name a)
:value (dom:value a)
:specified-p (dom:specified a))
results)))
(reverse results)))
;;;; package.lisp -- Paketdefinition
;;;;
;;;; This file is part of the CXML parser, released under (L)LGPL.
;;;; See file COPYING for details.
(in-package :cl-user)
(defpackage :dom
......@@ -108,4 +113,6 @@
#:named-node-map-p
#:map-node-list
#:do-node-list))
#:do-node-list
#:create-document
#:map-document))
(in-package :xml)
(in-package :cxml)
;;; Implementation of a simple but faster DOM.
......
;;; XXX delete this file
;;;
;;; A wrapper package STRING-DOM around the ordinary DOM presents
;;; DOMString as Lisp STRING. This was a workaround until
;;; RUNE-IS-CHARACTER was implemented, but might still be useful on
;;; Lisps without Unicode support.
;;;
;;; Copyright (c) 2004 knowledgeTools Int. GmbH
(defpackage :string-dom
(:use))
......
......@@ -178,19 +178,4 @@
(format stream "\\u~4,'0X" x))))
(princ #\" stream))
#-rune-is-character
(set-pprint-dispatch '(satisfies really-rod-p) #'rod-printer)
(set-dispatch-macro-character #\# #\" 'rod-reader)
#||
(defun longish-array-p (arr)
(and (arrayp arr)
(> (array-total-size arr) 10)))
(set-pprint-dispatch '(satisfies longish-array-p)
#'(lambda (stream object)
(let ((*print-array* nil)
(*print-pretty* nil))
(prin1 object stream))))
||#
This diff is collapsed.
;;; XXX wird derzeit in DOM:CREATE-ATTRIBUTE verwendet. Muesste aber wohl vom
;;; Parser auch schon geprueft werden. Vorher sollte man allerdings die
;;; Geschwindigkeit der Sache mal untersuchen.
;;;; characters.lisp -- character class definitions
;;;;
;;;; This file is part of the CXML parser, released under (L)LGPL.
;;;; See file COPYING for details.
;;;;
;;;; Author: David Lichteblau
;;;; Copyright (C) 2004 knowledgeTools Int. GmbH
(in-package :xml)
;;; XXX xml-name-rune-p.lisp habe ich erst nach dem Schreiben dieses
;;; Files gefunden...
(defun valid-name-p (rod)
(and (not (zerop (length rod)))
(let ((initial (elt rod 0)))
(or (rune-in-range-p initial *base-char-ranges*)
(rune-in-range-p initial *ideographic-ranges*)
(eql initial #.(char-code #\_))
(eql initial #.(char-code #\:))))
(every #'rune-name-char-p rod)))
;;; XXX wird derzeit in DOM:CREATE-ATTRIBUTE verwendet. Muesste aber
;;; wohl vom Parser auch schon geprueft werden (oder tut der das
;;; schon?). Vorher sollte man allerdings die Geschwindigkeit der Sache
;;; mal untersuchen.
(defun rune-name-char-p (rune)
(or (rune-in-range-p rune *base-char-ranges*)
(rune-in-range-p rune *ideographic-ranges*)
(eql rune #.(char-code #\.))
(eql rune #.(char-code #\-))
(eql rune #.(char-code #\_))
(eql rune #.(char-code #\:))
(rune-in-range-p rune *combining-char-ranges*)
(rune-in-range-p rune *extender-ranges*)))
(defun rune-in-range-p (rune range)
;; XXX FIXME, das geht doch besser
(block nil
(map nil (lambda (range)
(when (< rune (car range))
(return nil))
(when (<= rune (cadr range))
(return t)))
range)))
(in-package :cxml)
(defparameter *base-char-ranges*
#((#x0041 #x005A) (#x0061 #x007A) (#x00C0 #x00D6) (#x00D8 #x00F6)
......@@ -87,7 +70,7 @@
(#x3105 #x312C) (#xAC00 #xD7A3)))
(defparameter *ideographic-ranges*
#((#x4E00 #x9FA5) (#x3007 #x3007) (#x3021 #x3029)))
#((#x3007 #x3007) (#x3021 #x3029)(#x4E00 #x9FA5)))
(defparameter *combining-char-ranges*
#((#x0300 #x0345) (#x0360 #x0361) (#x0483 #x0486) (#x0591 #x05A1)
......@@ -125,3 +108,38 @@
#((#x00B7 #x00B7) (#x02D0 #x02D0) (#x02D1 #x02D1) (#x0387 #x0387)
(#x0640 #x0640) (#x0E46 #x0E46) (#x0EC6 #x0EC6) (#x3005 #x3005)
(#x3031 #x3035) (#x309D #x309E) (#x30FC #x30FE)))
(defun valid-name-p (rod)
(and (not (zerop (length rod)))
(let ((initial (elt rod 0)))
(or (rune-in-range-p initial *base-char-ranges*)
(rune-in-range-p initial *ideographic-ranges*)
(rune= initial #/_)
(eql initial #/:)))
(every #'rune-name-char-p rod)))
(defun valid-nmtoken-p (rod)
(and (not (zerop (length rod)))
(every #'rune-name-char-p rod)))
(defun rune-name-char-p (rune)
(or (rune-in-range-p rune *base-char-ranges*)
(rune-in-range-p rune *ideographic-ranges*)
(rune-in-range-p rune *digit-ranges*)
(eql rune #/.)
(eql rune #/-)
(eql rune #/_)
(eql rune #/:)
(rune-in-range-p rune *combining-char-ranges*)
(rune-in-range-p rune *extender-ranges*)))
(defun rune-in-range-p (rune range)
;; XXX FIXME, das geht doch besser
(let ((code (rune-code rune)))
(block nil
(map nil (lambda (range)
(when (< code (car range))
(return nil))
(when (<= code (cadr range))
(return t)))
range))))
;;;; recoder.lisp -- SAX handler for string conversion
;;;;
;;;; This file is part of the CXML parser, released under (L)LGPL.
;;;; See file COPYING for details.
;;;;
;;;; Developed 2004 for headcraft - http://headcraft.de/
;;;; Copyright: David Lichteblau
(in-package :cxml)
(defclass recoder ()
......
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SAX; readtable: glisp; Encoding: utf-8; -*-
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SAX; readtable: runes; Encoding: utf-8; -*-
;;; ---------------------------------------------------------------------------
;;; Title: A SAX2-like API for the xml parser
;;; Created: 2003-06-30
;;; Author: Henrik Motakef <hmot@henrik-motakef.de>
;;; Author: David Lichteblau (DTD-related changes)
;;; License: BSD
;;; ---------------------------------------------------------------------------
;;; © copyright 2003 by Henrik Motakef
;;; © copyright 2004 knowledgeTools Int. GmbH
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions are
......@@ -40,23 +42,22 @@
;; * document-locator/(setf document-locator)
;; (probably implies a handler class with an appropriate slot)
;; * skipped-entity
;; * notation-declaration
;; * unparsed-entity-declaration
;; * The whole ErrorHandler class, this is better handled using
;; conditions (but isn't yet)
;; * The LexicalHandler (start-cdata etc) would be nice
;; * The DeclHandler interface (element-decl, attribute-decl...)
;; is useful, but the Java interface sucks.
;; o Despite all the namespace-uri etc arguments, namespaces are not
;; really supported yet, the xml parser always passes nil. This will
;; hopefully change Real Soon Now, and I didn't want to have to
;; rewrite the interface then
;; * The LexicalHandler (start-cdata etc) would be nice [-- partly done]
(defpackage :sax
(:use :common-lisp)
(:export #:*namespace-processing*
#:*include-xmlns-attributes*
#:*use-xmlns-namespace*
#:make-attribute
#:attribute-namespace-uri
#:attribute-local-name
#:attribute-qname
#:attribute-value
#:attribute-specified-p
#:start-document
#:start-prefix-mapping
......@@ -68,7 +69,16 @@
#:end-document
#:comment
#:start-cdata
#:end-cdata))
#:end-cdata
#:start-dtd
#:end-dtd
#:unparsed-entity-declaration
#:external-entity-declaration
#:internal-entity-declaration
#:notation-declaration
#:element-declaration
#:attribute-declaration
#:entity-resolver))
(in-package :sax)
......@@ -118,6 +128,13 @@ qname: #\"xmlns:ex\"
Setting this variable has no effect unless both
`*namespace-processing*' and `*include-xmlns-attributes*' are non-nil.")
(defstruct attribute
namespace-uri
local-name
qname
value
specified-p)
(defgeneric start-document (handler)
(:documentation "Called at the beginning of the parsing process,
before any element, processing instruction or comment is reported.
......@@ -126,9 +143,6 @@ Handlers that need to maintain internal state may use this to perform
any neccessary initializations.")
(:method ((handler t)) nil))
;; How should attributes be represented?
;; Currently its just a (name . value) alist, but this isn't too
;; useful wrt namespaced attributes. Probably a struct.
(defgeneric start-element (handler namespace-uri local-name qname attributes)
(:documentation "Called to report the beginning of an element.
......@@ -147,7 +161,9 @@ local-name properties, the same rules as for the element name
apply. Additionally, namespace-declaring attributes (those whose name
is \"xmlns\" or starts with \"xmlns:\") are only included if
*namespace-prefixes* is non-nil.")
(:method ((handler t) namespace-uri local-name qname attributes) nil))
(:method ((handler t) namespace-uri local-name qname attributes)
(declare (ignore namespace-uri local-name qname attributes))
nil))
(defgeneric start-prefix-mapping (handler prefix uri)
(:documentation "Called when the scope of a new prefix -> namespace-uri mapping begins.
......@@ -159,7 +175,7 @@ Clients don't usually have to implement this except under special
circumstances, for example when they have to deal with qualified names
in textual content. The parser will handle namespaces of elements and
attributes on its own.")
(:method ((handler t) prefix uri) nil))
(:method ((handler t) prefix uri) (declare (ignore prefix uri)) nil))
(defgeneric characters (handler data)
(:documentation "Called for textual element content.
......@@ -167,13 +183,13 @@ attributes on its own.")
The data is passed as a rod, with all entity references resolved.
It is possible that the character content of an element is reported
via multiple subsequent calls to this generic function.")
(:method ((handler t) data) nil))
(:method ((handler t) data) (declare (ignore data)) nil))
(defgeneric processing-instruction (handler target data)
(:documentation "Called when a processing instruction is read.
Both target and data are rods.")
(:method ((handler t) target data) nil))
(:method ((handler t) target data) (declare (ignore target data)) nil))
(defgeneric end-prefix-mapping (handler prefix)
(:documentation "Called when a prefix -> namespace-uri mapping goes out of scope.
......@@ -186,14 +202,16 @@ Clients don't usually have to implement this except under special
circumstances, for example when they have to deal with qualified names
in textual content. The parser will handle namespaces of elements and
attributes on its own.")
(:method ((handler t) prefix) nil))
(:method ((handler t) prefix) prefix nil))
(defgeneric end-element (handler namespace-uri local-name qname)
(:documentation "Called to report the end of an element.
See the documentation for `start-element' for a description of the
parameters.")
(:method ((handler t) namespace-uri local-name qname) nil))
(:method ((handler t) namespace-uri local-name qname)
(declare (ignore namespace-uri local-name qname))
nil))
(defgeneric end-document (handler)
(:documentation "Called at the end of parsing a document.
......@@ -206,7 +224,7 @@ is significant, it will be returned by the parse-file/stream/string function.")
;; LexicalHandler
(defgeneric comment (handler data)
(:method ((handler t) data) nil))
(:method ((handler t) data) data nil))
(defgeneric start-cdata (handler)
(:documentation "Called at the beginning of parsing a CDATA section.
......@@ -224,4 +242,78 @@ Handlers only have to implement this if they are interested in the
lexical structure of the parsed document. The content of the CDATA
section is reported via the `characters' generic function like all
other textual content.")
(:method ((handler t)) nil))
\ No newline at end of file
(:method ((handler t)) nil))
(defgeneric start-dtd (handler name public-id system-id)
(:documentation "Called at the beginning of parsing a DTD.")
(:method ((handler t) name public-id system-id)
(declare (ignore name public-id system-id))
nil))
(defgeneric end-dtd (handler)
(:documentation "Called at the end of parsing a DTD.")
(:method ((handler t)) nil))
(defgeneric unparsed-entity-declaration
(handler name public-id system-id notation-name)
(:documentation
"Called when an unparsed entity declaration is seen in a DTD.")
(:method ((handler t) name public-id system-id notation-name)
(declare (ignore name public-id system-id notation-name))
nil))
(defgeneric external-entity-declaration
(handler kind name public-id system-id)
(:documentation
"Called when a parsed external entity declaration is seen in a DTD.")
(:method ((handler t) kind name public-id system-id)
(declare (ignore kind name public-id system-id))
nil))
(defgeneric internal-entity-declaration
(handler kind name value)
(:documentation
"Called when an internal entity declaration is seen in a DTD.")
(:method ((handler t) kind name value)
(declare (ignore kind name value))
nil))
(defgeneric notation-declaration
(handler name public-id system-id)
(:documentation
"Called when a notation declaration is seen while parsing a DTD.")
(:method ((handler t) name public-id system-id)
(declare (ignore name public-id system-id))
nil))
(defgeneric element-declaration (handler name model)
(:documentation
"Called when a element declaration is seen in a DTD. Model is not a string,
but a nested list, with *, ?, +, OR, and AND being the operators, rods
as names, :EMPTY and :PCDATA as special tokens. (AND represents
sequences.)")
(:method ((handler t) name model)
(declare (ignore name model))
nil))
(defgeneric attribute-declaration
(handler element-name attribute-name type default)
(:documentation
"Called when an attribute declaration is seen in a DTD.
type one of :CDATA, :ID, :IDREF, :IDREFS,
:ENTITY, :ENTITIES, :NMTOKEN, :NMTOKENS,
(:NOTATION <name>*), or (:ENUMERATION <name>*)
default :REQUIRED, :IMPLIED, (:FIXED content), or (:DEFAULT content)")
(:method ((handler t) element-name attribute-name type value)
(declare (ignore element-name attribute-name type value))
nil))
(defgeneric entity-resolver
(handler resolver)
(:documentation
"Called between sax:end-dtd and sax:end-document to register an entity
resolver, a function of two arguments: An entity name and SAX handler.
When called, the resolver function will parse the named entities data.")
(:method ((handler t) resolver)
(declare (ignore resolver))
nil))
(in-package :sax-tests)
(defun first-start-element-event (string)
(let ((events (xml:parse-string string (make-instance 'event-collecting-handler))))
(let ((events (xml::parse-string string (make-instance 'event-collecting-handler))))
(find :start-element events :key #'car)))
......@@ -17,7 +17,7 @@
(deftest attribute-uniqueness-1
(handler-case
(xml:parse-string "<x xmlns:a='http://example.com' xmlns:b='http://example.com' a:a='1' b:a='1'/>")
(xml::parse-string "<x xmlns:a='http://example.com' xmlns:b='http://example.com' a:a='1' b:a='1'/>")
(error () t)
(:no-error (&rest junk)
(declare (ignore junk))
......@@ -26,7 +26,7 @@
(deftest attribute-uniqueness-2
(handler-case
(xml:parse-string "<x xmlns:a='http://example.com' xmlns='http://example.com' a:a='1' a='1'/>")
(xml::parse-string "<x xmlns:a='http://example.com' xmlns='http://example.com' a:a='1' a='1'/>")
(error () nil)
(:no-error (&rest junk)
(declare (ignore junk))
......@@ -36,7 +36,7 @@
(deftest attribute-uniqueness-3
(let ((sax:*namespace-processing* nil))
(handler-case
(xml:parse-string "<x xmlns:a='http://example.com' xmlns:b='http://example.com' a:a='1' b:a='1'/>")
(xml::parse-string "<x xmlns:a='http://example.com' xmlns:b='http://example.com' a:a='1' b:a='1'/>")
(error () nil)
(:no-error (&rest junk)
(declare (ignore junk))
......@@ -46,7 +46,7 @@
;;; Namespace undeclaring
(deftest undeclare-default-namespace-1
(let* ((evts (xml:parse-string "<x xmlns='http://example.com'><y xmlns='' a='1'/></x>"
(let* ((evts (xml::parse-string "<x xmlns='http://example.com'><y xmlns='' a='1'/></x>"
(make-instance 'event-collecting-handler)))
(start-elt-events (remove :start-element evts :test (complement #'eql) :key #'car))
(evt1 (first start-elt-events))
......@@ -59,7 +59,7 @@
(deftest undeclare-other-namespace
(handler-case
(xml:parse-string "<x:x xmlns:x='http://example.com'><x:y xmlns:x='' a='1'/></x:x>")
(xml::parse-string "<x:x xmlns:x='http://example.com'><x:y xmlns:x='' a='1'/></x:x>")
(error () t)
(:no-error (&rest junk)
(declare (ignore junk))
......@@ -71,7 +71,7 @@
(deftest pi-names-are-ncnames-when-namespace-processing-1
(handler-case
(xml:parse-string "<?a:b c?><x/>")
(xml::parse-string "<?a:b c?><x/>")
(error () t)
(:no-error (&rest junk)
(declare (ignore junk))
......@@ -81,7 +81,7 @@
(deftest pi-names-are-ncnames-when-namespace-processing-2
(let ((sax:*namespace-processing* nil))
(handler-case
(xml:parse-string "<?a:b c?><x/>")
(xml::parse-string "<?a:b c?><x/>")
(error () nil)
(:no-error (&rest junk)
(declare (ignore junk))
......@@ -90,7 +90,7 @@
(deftest entity-names-are-ncnames-when-namespace-processing-1
(handler-case
(xml:parse-string "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x>&y:z;</x>")
(xml::parse-string "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x>&y:z;</x>")
(error () t)
(:no-error (&rest junk)
(declare (ignore junk))
......@@ -99,7 +99,7 @@
(deftest entity-names-are-ncnames-when-namespace-processing-2
(handler-case
(xml:parse-string "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x/>")
(xml::parse-string "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x/>")
(error () t)
(:no-error (&rest junk)
(declare (ignore junk))
......@@ -109,7 +109,7 @@
(deftest entity-names-are-ncnames-when-namespace-processing-3
(let ((sax:*namespace-processing* nil))
(handler-case
(xml:parse-string "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x>&y:z;</x>")
(xml::parse-string "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x>&y:z;</x>")
(error () nil)
(:no-error (&rest junk)
(declare (ignore junk))
......@@ -119,7 +119,7 @@
(deftest entity-names-are-ncnames-when-namespace-processing-4
(let ((sax:*namespace-processing* nil))
(handler-case
(xml:parse-string "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x/>")
(xml::parse-string "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x/>")
(error () nil)
(:no-error (&rest junk)
(declare (ignore junk))
......@@ -259,7 +259,7 @@
(deftest redefine-xml-namespace-1
(handler-case
(xml:parse-string "<x xmlns:xml='http://www.w3.org/XML/1998/namespace'/>")
(xml::parse-string "<x xmlns:xml='http://www.w3.org/XML/1998/namespace'/>")
(error () nil)
(:no-error (&rest junk)
(declare (ignore junk))
......@@ -268,7 +268,7 @@
(deftest redefine-xml-namespace-2
(handler-case
(xml:parse-string "<x xmlns:xml='http://example.com/wrong-uri'/>")
(xml::parse-string "<x xmlns:xml='http://example.com/wrong-uri'/>")
(error () t)
(:no-error (&rest junk)
(declare (ignore junk))
......@@ -277,7 +277,7 @@
(deftest redefine-xml-namespace-3
(handler-case
(xml:parse-string "<x xmlns:wrong='http://www.w3.org/XML/1998/namespace'/>")
(xml::parse-string "<x xmlns:wrong='http://www.w3.org/XML/1998/namespace'/>")
(error () t)
(:no-error (&rest junk)
(declare (ignore junk))
......@@ -286,7 +286,7 @@
(deftest redefine-xml-namespace-4
(handler-case
(xml:parse-string "<x xmlns:wrong='http://www.w3.org/XML/1998/namespace'/>")
(xml::parse-string "<x xmlns:wrong='http://www.w3.org/XML/1998/namespace'/>")
(error () t)
(:no-error (&rest junk)
(declare (ignore junk))
......@@ -295,7 +295,7 @@
(deftest redefine-xmlns-namespace-1
(handler-case
(xml:parse-string "<x xmlns:xmlns='http://www.w3.org/2000/xmlns/'/>")
(xml::parse-string "<x xmlns:xmlns='http://www.w3.org/2000/xmlns/'/>")
(error () t)
(:no-error (&rest junk)
(declare (ignore junk))
......@@ -304,7 +304,7 @@
(deftest redefine-xmlns-namespace-2
(handler-case
(xml:parse-string "<x xmlns:xmlns='http://example.com/wrong-ns'/>")
(xml::parse-string "<x xmlns:xmlns='http://example.com/wrong-ns'/>")
(error () t)
(:no-error (&rest junk)
(declare (ignore junk))
......@@ -313,7 +313,7 @@
(deftest redefine-xmlns-namespace-3
(handler-case
(xml:parse-string "<x xmlns:wrong='http://www.w3.org/2000/xmlns/'/>")
(xml::parse-string "<x xmlns:wrong='http://www.w3.org/2000/xmlns/'/>")
(error () t)
(:no-error (&rest junk)
(declare (ignore junk))
......@@ -322,7 +322,7 @@
(deftest redefine-xmlns-namespace-4
(handler-case
(xml:parse-string "<x xmlns='http://www.w3.org/2000/xmlns/'/>")
(xml::parse-string "<x xmlns='http://www.w3.org/2000/xmlns/'/>")
(error () t)
(:no-error (&rest junk)
(declare (ignore junk))
......
......@@ -8,6 +8,8 @@
;;; License: LGPL (See file COPYING for details).
;;; ---------------------------------------------------------------------------
;;; © copyright 1999 by Gilbert Baumann
;;; © copyright 2004 by knowledgeTools Int. GmbH
;;; © copyright 2004 by David Lichteblau (for headcraft.de)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
......@@ -77,6 +79,7 @@
(notations :initform (make-buffer :element-type t) :accessor notations)
(name-for-dtd :accessor name-for-dtd)
(previous-notation :initform nil :accessor previous-notation)
(have-doctype :initform nil :accessor have-doctype)
(stack :initform nil :accessor stack)))
(defmethod initialize-instance :after ((instance sink) &key)
......@@ -154,9 +157,32 @@
;;;; doctype and notations
(defmethod sax:start-document ((sink sink))
(unless (canonical sink)
(write-rod #"<?xml version=\"1.0\" encoding=\"UTF-8\"?>" sink)
(write-rune #/U+000A sink)))
(defmethod sax:start-dtd ((sink sink) name public-id system-id)
(declare (ignore public-id system-id))
(setf (name-for-dtd sink) name))
(setf (name-for-dtd sink) name)
(unless (canonical sink)
(ensure-doctype sink public-id system-id)))
(defun ensure-doctype (sink &optional public-id system-id)
(unless (have-doctype sink)
(setf (have-doctype sink) t)
(write-rod #"<!DOCTYPE " sink)
(write-rod (name-for-dtd sink) sink)
(cond
(public-id
(write-rod #" PUBLIC \"" sink)
(unparse-string public-id sink)
(write-rod #"\" \"" sink)
(unparse-string system-id sink)
(write-rod #"\"" sink))
(system-id
(write-rod #" SYSTEM \"" sink)
(unparse-string public-id sink)
(write-rod #"\"" sink)))))
(defmethod sax:notation-declaration ((sink sink) name public-id system-id)
(when (and (canonical sink) (>= (canonical sink) 2))
......@@ -166,9 +192,7 @@
(unless (rod< prev name)
(error "misordered notations; cannot unparse canonically")))
(t
;; need a doctype declaration
(write-rod #"<!DOCTYPE " sink)
(write-rod (name-for-dtd sink) sink)
(ensure-doctype sink)
(write-rod #" [" sink)
(write-rune #/U+000A sink)))
(setf (previous-notation sink) name))
......@@ -193,24 +217,38 @@
(write-rune #/U+000A sink)))
(defmethod sax:end-dtd ((sink sink))
(when (previous-notation sink)
(write-rod #"]>" sink)
(when (have-doctype sink)
(when (previous-notation sink)
(write-rod #"]" sink))
(write-rod #">" sink)
(write-rune #/U+000A sink)))
;;;; elements
(defstruct (tag (:constructor make-tag (name)))
name
(n-children 0)
(have-gt nil))
(defun sink-fresh-line (sink)
(unless (zerop (column sink))
(write-rune-0 10 sink)
(indent sink)))
(defun maybe-close-tag (sink)
(let ((tag (car (stack sink))))
(when (and (tag-p tag) (not (tag-have-gt tag)))
(setf (tag-have-gt tag) t)
(write-rune #/> sink))))
(defmethod sax:start-element
((sink sink) namespace-uri local-name qname attributes)
(declare (ignore namespace-uri local-name))
(maybe-close-tag sink)
(when (stack sink)
(incf (cdr (first (stack sink)))))
(push (cons qname 0) (stack sink))
(incf (tag-n-children (first (stack sink)))))
(push (make-tag qname) (stack sink))
(when (indentation sink)
(sink-fresh-line sink)
(start-indentation-block sink))
......@@ -224,26 +262,32 @@
(write-rune #/\" sink)
(map nil (lambda (c) (unparse-datachar c sink)) (sax:attribute-value a))
(write-rune #/\" sink)))
(write-rod '#.(string-rod ">") sink))
(when (canonical sink)
(maybe-close-tag sink)))
(defmethod sax:end-element
((sink sink) namespace-uri local-name qname)
(declare (ignore namespace-uri local-name))
(let ((cons (pop (stack sink))))
(unless (consp cons)
(let ((tag (pop (stack sink))))
(unless (tag-p tag)
(error "output does not nest: not in an element"))
(unless (rod= (car cons) qname)
(unless (rod= (tag-name tag) qname)
(error "output does not nest: expected ~A but got ~A"
(rod qname) (rod (car cons))))
(rod qname) (rod (tag-name tag))))
(when (indentation sink)
(end-indentation-block sink)
(unless (zerop (cdr cons))
(sink-fresh-line sink))))
(write-rod '#.(string-rod "</") sink)
(write-rod qname sink)
(write-rod '#.(string-rod ">") sink))
(unless (zerop (tag-n-children tag))
(sink-fresh-line sink)))
(cond
((tag-have-gt tag)
(write-rod '#.(string-rod "</") sink)
(write-rod qname sink)
(write-rod '#.(string-rod ">") sink))
(t
(write-rod #"/>" sink)))))
(defmethod sax:processing-instruction ((sink sink) target data)
(maybe-close-tag sink)
(unless (rod-equal target '#.(string-rod "xml"))
(write-rod '#.(string-rod "<?") sink)
(write-rod target sink)
......@@ -252,9 +296,11 @@
(write-rod '#.(string-rod "?>") sink)))
(defmethod sax:start-cdata ((sink sink))
(maybe-close-tag sink)
(push :cdata (stack sink)))
(defmethod sax:characters ((sink sink) data)
(maybe-close-tag sink)
(cond
((and (eq (car (stack sink)) :cdata)
(not (canonical sink))
......@@ -312,6 +358,9 @@
(t
(write-rune-0 32 sink))))))
(defun unparse-string (str sink)
(map nil (lambda (c) (unparse-datachar c sink)) str))
(defun unparse-datachar (c sink)
(cond ((rune= c #/&) (write-rod '#.(string-rod "&amp;") sink))
((rune= c #/<) (write-rod '#.(string-rod "&lt;") sink))
......@@ -399,8 +448,8 @@
(sax:end-document *sink*)))
(defmacro with-element (qname &body body)
;; XXX Statt qname soll man in zukunft auch mal (lname uri) angeben koennen.
;; Hat aber Zeit bis DOM 2.
;; XXX Statt qname soll man in zukunft auch mal (lname prefix) angeben
;; koennen. Hat aber Zeit bis DOM 2.
(when (listp qname)
(destructuring-bind (n) qname
(setf qname n)))
......@@ -414,6 +463,7 @@
(setf *current-element* nil)))
(defun invoke-with-element (fn qname)
(setf qname (rod qname))
(maybe-emit-start-tag)
(let ((*current-element* (list qname)))
(multiple-value-prog1
......@@ -422,17 +472,29 @@
(sax:end-element *sink* nil nil qname))))
(defun attribute (name value)
(push (sax:make-attribute :qname name :value value)
(push (sax:make-attribute :qname (rod name) :value (rod value))
(cdr *current-element*))
value)
(defun cdata (data)
(sax:start-cdata *sink*)
(sax:characters *sink* data)
(sax:characters *sink* (rod data))
(sax:end-cdata *sink*)
data)
(defun text (data)
(maybe-emit-start-tag)
(sax:characters *sink* data)
(sax:characters *sink* (rod data))
data)
(defun rod-to-utf8-string (rod)
(with-output-to-string (s)
(write-rod rod (cxml:make-character-stream-sink s))))
(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 (decode-sequence :utf-8 bytes 0 (length bytes) buffer 0 0 nil))
(result (make-array n :element-type 'rod)))
(map-into result #'code-rune buffer)
result))
......@@ -3,12 +3,15 @@
;;;; This file is part of the CXML parser, released under (L)LGPL.
;;;; See file COPYING for details.
;;;;
;;;; Copyright (c) 2004 headcraft GmbH
;;;; Author: David Lichteblau
;;;; Developed 2004 for headcraft - http://headcraft.de/
;;;; Copyright: David Lichteblau
;;;; XXX Der namespace-Support in xmls kommt mir zweifelhaft vor.
;;;; Wir immitieren das soweit es gebraucht wurde bisher.
(defpackage cxml-xmls
(:use :cl)
(:export #:make-node #:node-name #:node-attrs #:node-children
(:use :cl :runes)
(:export #:make-node #:node-name #:node-ns #:node-attrs #:node-children
#:make-xmls-builder #:map-node))
(in-package :cxml-xmls)
......@@ -16,16 +19,35 @@
;;;; Knoten
;; XXX Wie namespaces in xmls funktionieren nsollen verstehe ich noch nicht so
;; ganz. Daher verzichte ich vorerst auf NODE-NS und verwende durchweg QNAMEs.
(defun make-node (&key name attrs children)
`(,name ,attrs ,@children))
(defun make-node (&key name ns attrs children)
`(,(if ns (cons name ns) name)
,attrs
,@children))
(defun node-name (node)
(car node))
(let ((car (car node)))
(if (consp car)
(car car)
car)))
(defun (setf node-name) (newval node)
(setf (car node) newval))
(let ((car (car node)))
(if (consp car)
(setf (car car) newval)
(setf (car node) newval))))
(defun node-ns (node)
(let ((car (car node)))
(if (consp car)
(cdr car)
nil)))
(defun (setf node-ns) (newval node)
(let ((car (car node)))
(if (consp car)
(setf (cdr car) newval)
(setf (car node) (cons car newval)))
newval))
(defun node-attrs (node)
(cadr node))
......@@ -44,23 +66,36 @@
(defclass xmls-builder ()
((element-stack :initform nil :accessor element-stack)
(root :initform nil :accessor root)))
(root :initform nil :accessor root)
(include-default-values :initform t
:initarg :include-default-values
:accessor include-default-values)))
(defun make-xmls-builder ()
(make-instance 'xmls-builder))
(defun make-xmls-builder (&key (include-default-values t))
(make-instance 'xmls-builder :include-default-values include-default-values))
(defmethod sax:end-document ((handler xmls-builder))
(root handler))
(defmethod sax:start-element
((handler xmls-builder) namespace-uri local-name qname attributes)
(declare (ignore namespace-uri local-name))
(declare (ignore namespace-uri))
(setf local-name (or local-name qname))
(let* ((attributes
(mapcar (lambda (attr)
(list (sax:attribute-qname attr)
(sax:attribute-value attr)))
attributes))
(node (make-node :name qname :attrs attributes))
(loop
for attr in attributes
when (or (sax:attribute-specified-p attr)
(include-default-values handler))
collect
(list (sax:attribute-qname attr)
(sax:attribute-value attr))))
(node (make-node :name local-name
:ns (let ((lq (length qname))
(ll (length local-name)))
(if (eql lq ll)
nil
(subseq qname 0 (- lq ll 1))))
:attrs attributes))
(parent (car (element-stack handler))))
(if parent
(push node (node-children parent))
......@@ -76,13 +111,17 @@
(defmethod sax:characters ((handler xmls-builder) data)
(let* ((parent (car (element-stack handler)))
(prev (car (node-children parent))))
(if (stringp prev)
;; Be careful to accept both rods and strings here, so that xmls can be
;; used with strings even if cxml is configured to use octet string rods.
(if (typep prev '(or rod string))
;; um entities herum wird SAX:CHARACTERS mehrfach aufgerufen fuer
;; den gleichen Textknoten. Hier muessen wir den bestehenden Knoten
;; erweitern, sonst ist das Dokument nicht normalisiert.
;; (XXX Oder sollte man besser den Parser entsprechend aendern?)
(setf (car (node-children parent))
(concatenate 'runes:rod prev data))
(concatenate `(vector ,(array-element-type prev))
prev
data))
(push data (node-children parent)))))
......@@ -93,16 +132,18 @@
&key (include-xmlns-attributes sax:*include-xmlns-attributes*))
(sax:start-document handler)
(labels ((walk (node)
(let ((attlist
(compute-attributes node include-xmlns-attributes))
(qname (node-name node)))
(let* ((attlist
(compute-attributes node include-xmlns-attributes))
(lname (rod (node-name node)))
(ns (rod (node-ns node)))
(qname (concatenate 'rod ns (rod ":") lname)))
;; fixme: namespaces
(sax:start-element handler nil nil qname attlist)
(sax:start-element handler nil lname qname attlist)
(dolist (child (node-children node))
(typecase child
(list (walk child))
(string (sax:characters handler child))))
(sax:end-element handler nil nil qname))))
((or string rod) (sax:characters handler (rod child)))))
(sax:end-element handler nil lname qname))))
(walk node))
(sax:end-document handler))
......@@ -110,9 +151,9 @@
(remove nil
(mapcar (lambda (a)
(destructuring-bind (name value) a
(if (or xmlnsp (not (cxml::xmlns-attr-p name)))
(sax:make-attribute :qname name
:value value
(if (or xmlnsp (not (cxml::xmlns-attr-p (rod name))))
(sax:make-attribute :qname (rod name)
:value (rod value)
:specified-p t)
nil)))
(node-attrs node))))