119 lines
3.8 KiB
Common Lisp
119 lines
3.8 KiB
Common Lisp
;;;; xml-compat.lisp -- XMLS-compatible data structures
|
|
;;;;
|
|
;;;; 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
|
|
|
|
(defpackage cxml-xmls
|
|
(:use :cl)
|
|
(:export #:make-node #:node-name #:node-attrs #:node-children
|
|
#:make-xmls-builder #:map-node))
|
|
|
|
(in-package :cxml-xmls)
|
|
|
|
|
|
;;;; 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 node-name (node)
|
|
(car node))
|
|
|
|
(defun (setf node-name) (newval node)
|
|
(setf (car node) newval))
|
|
|
|
(defun node-attrs (node)
|
|
(cadr node))
|
|
|
|
(defun (setf node-attrs) (newval node)
|
|
(setf (cadr node) newval))
|
|
|
|
(defun node-children (node)
|
|
(cddr node))
|
|
|
|
(defun (setf node-children) (newval node)
|
|
(setf (cddr node) newval))
|
|
|
|
|
|
;;;; SAX-Handler (Parser)
|
|
|
|
(defclass xmls-builder ()
|
|
((element-stack :initform nil :accessor element-stack)
|
|
(root :initform nil :accessor root)))
|
|
|
|
(defun make-xmls-builder ()
|
|
(make-instance 'xmls-builder))
|
|
|
|
(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))
|
|
(let* ((attributes
|
|
(mapcar (lambda (attr)
|
|
(list (sax:attribute-qname attr)
|
|
(sax:attribute-value attr)))
|
|
attributes))
|
|
(node (make-node :name qname :attrs attributes))
|
|
(parent (car (element-stack handler))))
|
|
(if parent
|
|
(push node (node-children parent))
|
|
(setf (root handler) node))
|
|
(push node (element-stack handler))))
|
|
|
|
(defmethod sax:end-element
|
|
((handler xmls-builder) namespace-uri local-name qname)
|
|
(declare (ignore namespace-uri local-name qname))
|
|
(let ((node (pop (element-stack handler))))
|
|
(setf (node-children node) (reverse (node-children node)))))
|
|
|
|
(defmethod sax:characters ((handler xmls-builder) data)
|
|
(let* ((parent (car (element-stack handler)))
|
|
(prev (car (node-children parent))))
|
|
(if (stringp prev)
|
|
;; 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))
|
|
(push data (node-children parent)))))
|
|
|
|
|
|
;;;; SAX-Treiber (fuer Serialisierung)
|
|
|
|
(defun map-node
|
|
(handler node
|
|
&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)))
|
|
;; fixme: namespaces
|
|
(sax:start-element handler nil nil qname attlist)
|
|
(dolist (child (node-children node))
|
|
(typecase child
|
|
(list (walk child))
|
|
(string (sax:characters handler child))))
|
|
(sax:end-element handler nil nil qname))))
|
|
(walk node))
|
|
(sax:end-document handler))
|
|
|
|
(defun compute-attributes (node xmlnsp)
|
|
(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
|
|
:specified-p t)
|
|
nil)))
|
|
(node-attrs node))))
|