Update of /project/s-xml/cvsroot/s-xml/src
In directory common-lisp.net:/tmp/cvs-serv14302/src
Modified Files:
dom.lisp lxml-dom.lisp sxml-dom.lisp xml-struct-dom.lisp
xml.lisp
Log Message:
redesigned the namespaces implementation
separated namespace definition (incl package mapping, default prefix) from namespace binding (using xmlns attributes)
cleanup of printing code (added ns-awareness)
added *ignore-namespaces* switch to disable ns-awareness (backward compatibility)
Date: Mon Aug 29 17:01:48 2005
Author: scaekenberghe
Index: s-xml/src/dom.lisp
diff -u s-xml/src/dom.lisp:1.1.1.1 s-xml/src/dom.lisp:1.2
--- s-xml/src/dom.lisp:1.1.1.1 Mon Jun 7 20:49:56 2004
+++ s-xml/src/dom.lisp Mon Aug 29 17:01:47 2005
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: dom.lisp,v 1.1.1.1 2004/06/07 18:49:56 scaekenberghe Exp $
+;;;; $Id: dom.lisp,v 1.2 2005/08/29 15:01:47 scaekenberghe Exp $
;;;;
;;;; This is the generic simple DOM parser and printer interface.
;;;;
@@ -46,5 +46,30 @@
"Generate XML output to a string from a DOM of input-type (:lxml by default), optionally pretty printing (off by default)"
(with-output-to-string (stream)
(print-xml dom :stream stream :pretty pretty :input-type input-type)))
+
+;;; shared/common support functions
+
+(defun print-spaces (n stream &optional (preceding-newline t))
+ (when preceding-newline
+ (terpri stream))
+ (loop :repeat n
+ :do (write-char #\Space stream)))
+
+(defun print-solitary-tag (tag stream)
+ (write-char #\< stream)
+ (print-identifier tag stream)
+ (write-string "/>" stream))
+
+(defun print-closing-tag (tag stream)
+ (write-string "</" stream)
+ (print-identifier tag stream)
+ (write-char #\> stream))
+
+(defun print-attribute (name value stream)
+ (write-char #\space stream)
+ (print-identifier name stream t)
+ (write-string "=\"" stream)
+ (print-string-xml value stream)
+ (write-char #\" stream))
;;;; eof
Index: s-xml/src/lxml-dom.lisp
diff -u s-xml/src/lxml-dom.lisp:1.3 s-xml/src/lxml-dom.lisp:1.4
--- s-xml/src/lxml-dom.lisp:1.3 Mon Aug 29 10:54:41 2005
+++ s-xml/src/lxml-dom.lisp Mon Aug 29 17:01:47 2005
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: lxml-dom.lisp,v 1.3 2005/08/29 08:54:41 scaekenberghe Exp $
+;;;; $Id: lxml-dom.lisp,v 1.4 2005/08/29 15:01:47 scaekenberghe Exp $
;;;;
;;;; LXML implementation of the generic DOM parser and printer.
;;;;
@@ -44,40 +44,40 @@
:finish-element-hook #'lxml-finish-element-hook
:text-hook #'lxml-text-hook))))
+(defun plist->alist (plist)
+ (when plist
+ (cons (cons (first plist) (second plist))
+ (plist->alist (rest (rest plist))))))
+
(defmethod print-xml-dom (dom (input-type (eql :lxml)) stream pretty level)
- (cond ((symbolp dom) (format stream "<~a/>" (print-identifier dom nil)))
+ (declare (special *namespaces))
+ (cond ((symbolp dom) (print-solitary-tag dom stream))
((stringp dom) (print-string-xml dom stream))
((consp dom)
(let (tag attributes)
- (cond ((symbolp (car dom)) (setf tag (car dom)))
- ((consp (car dom)) (setf tag (caar dom) attributes (cdar dom)))
+ (cond ((symbolp (first dom)) (setf tag (first dom)))
+ ((consp (first dom)) (setf tag (first (first dom))
+ attributes (plist->alist (rest (first dom)))))
(t (error "Input not recognized as LXML ~s" dom)))
- (format stream "<~a" (print-identifier tag nil))
- (labels ((print-attributes (attributes)
- (unless (null attributes)
- (format stream " ~a=\"" (print-identifier (car attributes) nil t))
- (print-string-xml (cadr attributes) stream)
- (format stream "\"")
- (print-attributes (cddr attributes)))))
- (when attributes (print-attributes attributes)))
- (if (cdr dom)
- (let ((children (cdr dom)))
- (format stream ">")
- (if (and (= (length children) 1) (stringp (first children)))
- (print-string-xml (first children) stream)
- (progn
- (dolist (child children)
- (when pretty
- (terpri stream)
- (dotimes (i (* 2 level)) (write-char #\space stream)))
- (if (stringp child)
- (print-string-xml child stream)
- (print-xml-dom child input-type stream pretty (1+ level))))
- (when pretty
- (terpri stream)
- (dotimes (i (* 2 (1- level))) (write-char #\space stream)))))
- (format stream "</~a>" (print-identifier tag nil)))
- (format stream "/>"))))
+ (let ((*namespaces* (extend-namespaces attributes *namespaces*)))
+ (write-char #\< stream)
+ (print-identifier tag stream)
+ (loop :for (name . value) :in attributes
+ :do (print-attribute name value stream))
+ (if (rest dom)
+ (let ((children (rest dom)))
+ (write-char #\> stream)
+ (if (and (= (length children) 1) (stringp (first children)))
+ (print-string-xml (first children) stream)
+ (progn
+ (dolist (child children)
+ (when pretty (print-spaces (* 2 level) stream))
+ (if (stringp child)
+ (print-string-xml child stream)
+ (print-xml-dom child input-type stream pretty (1+ level))))
+ (when pretty (print-spaces (* 2 level) stream))))
+ (print-closing-tag tag stream))
+ (write-string "/>" stream)))))
(t (error "Input not recognized as LXML ~s" dom))))
;;;; eof
Index: s-xml/src/sxml-dom.lisp
diff -u s-xml/src/sxml-dom.lisp:1.2 s-xml/src/sxml-dom.lisp:1.3
--- s-xml/src/sxml-dom.lisp:1.2 Wed Aug 17 10:06:01 2005
+++ s-xml/src/sxml-dom.lisp Mon Aug 29 17:01:47 2005
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: sxml-dom.lisp,v 1.2 2005/08/17 08:06:01 scaekenberghe Exp $
+;;;; $Id: sxml-dom.lisp,v 1.3 2005/08/29 15:01:47 scaekenberghe Exp $
;;;;
;;;; LXML implementation of the generic DOM parser and printer.
;;;;
@@ -40,38 +40,37 @@
:text-hook #'sxml-text-hook))))
(defmethod print-xml-dom (dom (input-type (eql :sxml)) stream pretty level)
+ (declare (special *namespaces))
(cond ((stringp dom) (print-string-xml dom stream))
((consp dom)
- (let ((tag (car dom))
+ (let ((tag (first dom))
attributes
children)
- (if (and (consp (cadr dom)) (eq (caadr dom) :@))
- (setf attributes (cdadr dom)
- children (cddr dom))
- (setf children (cdr dom)))
- (format stream "<~a" tag)
- (dolist (pair attributes)
- (format stream " ~a=\"" (car pair))
- (print-string-xml (cadr pair) stream)
- (format stream "\""))
- (if children
- (progn
- (format stream ">")
- (if (and (= (length children) 1) (stringp (first children)))
- (print-string-xml (first children) stream)
- (progn
- (dolist (child children)
- (when pretty
- (terpri stream)
- (dotimes (i (* 2 level)) (write-char #\space stream)))
- (if (stringp child)
- (print-string-xml child stream)
- (print-xml-dom child input-type stream pretty (1+ level))))
- (when pretty
- (terpri stream)
- (dotimes (i (* 2 (1- level))) (write-char #\space stream)))))
- (format stream "</~a>" tag))
- (format stream "/>"))))
+ (if (and (consp (second dom)) (eq (first (second dom)) :@))
+ (setf attributes (rest (second dom))
+ children (rest (rest dom)))
+ (setf children (rest dom)))
+ (let ((*namespaces* (extend-namespaces (loop :for (name value) :in attributes
+ :collect (cons name value))
+ *namespaces*)))
+ (write-char #\< stream)
+ (print-identifier tag stream)
+ (loop :for (name value) :in attributes
+ :do (print-attribute name value stream))
+ (if children
+ (progn
+ (write-char #\> stream)
+ (if (and (= (length children) 1) (stringp (first children)))
+ (print-string-xml (first children) stream)
+ (progn
+ (dolist (child children)
+ (when pretty (print-spaces (* 2 level) stream))
+ (if (stringp child)
+ (print-string-xml child stream)
+ (print-xml-dom child input-type stream pretty (1+ level))))
+ (when pretty (print-spaces (* 2 level) stream))))
+ (print-closing-tag tag stream))
+ (write-string "/>" stream)))))
(t (error "Input not recognized as SXML ~s" dom))))
;;;; eof
Index: s-xml/src/xml-struct-dom.lisp
diff -u s-xml/src/xml-struct-dom.lisp:1.1.1.1 s-xml/src/xml-struct-dom.lisp:1.2
--- s-xml/src/xml-struct-dom.lisp:1.1.1.1 Mon Jun 7 20:49:57 2004
+++ s-xml/src/xml-struct-dom.lisp Mon Aug 29 17:01:47 2005
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: xml-struct-dom.lisp,v 1.1.1.1 2004/06/07 18:49:57 scaekenberghe Exp $
+;;;; $Id: xml-struct-dom.lisp,v 1.2 2005/08/29 15:01:47 scaekenberghe Exp $
;;;;
;;;; XML-STRUCT implementation of the generic DOM parser and printer.
;;;;
@@ -75,30 +75,28 @@
;;; printing xml structures
(defmethod print-xml-dom (xml-element (input-type (eql :xml-struct)) stream pretty level)
- (format stream "<~a" (xml-element-name xml-element))
- (dolist (attribute (xml-element-attributes xml-element))
- (format stream " ~a=\"" (car attribute))
- (print-string-xml (cdr attribute) stream)
- (format stream "\""))
- (let ((children (xml-element-children xml-element)))
- (if children
- (progn
- (format stream ">")
- (if (and (= (length children) 1) (stringp (first children)))
- (print-string-xml (first children) stream)
- (progn
- (dolist (child children)
- (when pretty
- (terpri stream)
- (dotimes (i (* 2 level)) (write-char #\space stream)))
- (if (stringp child)
- (print-string-xml child stream)
- (print-xml-dom child input-type stream pretty (1+ level))))
- (when pretty
- (terpri stream)
- (dotimes (i (* 2 (1- level))) (write-char #\space stream)))))
- (format stream "</~a>" (xml-element-name xml-element)))
- (format stream "/>"))))
+ (declare (special *namespaces*))
+ (let ((*namespaces* (extend-namespaces (xml-element-attributes xml-element)
+ *namespaces*)))
+ (write-char #\< stream)
+ (print-identifier (xml-element-name xml-element) stream)
+ (loop :for (name . value) :in (xml-element-attributes xml-element)
+ :do (print-attribute name value stream))
+ (let ((children (xml-element-children xml-element)))
+ (if children
+ (progn
+ (write-char #\> stream)
+ (if (and (= (length children) 1) (stringp (first children)))
+ (print-string-xml (first children) stream)
+ (progn
+ (dolist (child children)
+ (when pretty (print-spaces (* 2 level) stream))
+ (if (stringp child)
+ (print-string-xml child stream)
+ (print-xml-dom child input-type stream pretty (1+ level))))
+ (when pretty (print-spaces (* 2 level) stream))))
+ (print-closing-tag (xml-element-name xml-element) stream))
+ (write-string "/>" stream)))))
;;; the standard hooks to generate xml-element structs
Index: s-xml/src/xml.lisp
diff -u s-xml/src/xml.lisp:1.9 s-xml/src/xml.lisp:1.10
--- s-xml/src/xml.lisp:1.9 Mon Aug 29 10:54:42 2005
+++ s-xml/src/xml.lisp Mon Aug 29 17:01:47 2005
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: xml.lisp,v 1.9 2005/08/29 08:54:42 scaekenberghe Exp $
+;;;; $Id: xml.lisp,v 1.10 2005/08/29 15:01:47 scaekenberghe Exp $
;;;;
;;;; This is a Common Lisp implementation of a basic but usable XML parser.
;;;; The parser is non-validating and not complete (no CDATA).
@@ -137,11 +137,14 @@
;;; namespace support
+(defvar *ignore-namespaces* nil
+ "When t, namespaces are ignored like in the old version of S-XML")
+
(defclass xml-namespace ()
((uri :documentation "The URI used to identify this namespace"
:accessor get-uri
:initarg :uri)
- (prefix :documentation "The prefix assigned to this namespace"
+ (prefix :documentation "The preferred prefix assigned to this namespace"
:accessor get-prefix
:initarg :prefix
:initform nil)
@@ -157,11 +160,37 @@
:package (find-package :keyword))
"The local (global default) XML namespace")
-(defvar *namespaces* (list *local-namespace*)
- "Ordered list of XML namespaces currently in effect")
+(defvar *known-namespaces* (list *local-namespace*)
+ "The list of known/defined namespaces")
+
+(defun find-namespace (uri)
+ "Find a registered XML namespace identified by uri"
+ (find uri *known-namespaces* :key #'get-uri :test #'string-equal))
+
+(defun register-namespace (uri prefix package)
+ "Register a new or redefine an existing XML namespace defined by uri with prefix and package"
+ (let ((namespace (find-namespace uri)))
+ (if namespace
+ (setf (get-prefix namespace) prefix
+ (get-package namespace) (find-package package))
+ (push (setf namespace (make-instance 'xml-namespace
+ :uri uri
+ :prefix prefix
+ :package (find-package package)))
+ *known-namespaces*))
+ namespace))
+
+(defvar *namespaces* `(("" . *local-namespace*))
+ "Ordered list of (prefix . XML-namespace) bindings currently in effect - special variable")
+
+(defun find-namespace-binding (prefix namespaces)
+ "Find the XML namespace currently bound to prefix in the namespaces bindings"
+ (cdr (assoc prefix namespaces :test #'string-equal)))
(defun split-identifier (identifier)
"Split an identifier 'prefix:name' and return (values prefix name)"
+ (when (symbolp identifier)
+ (setf identifier (symbol-name identifier)))
(let ((colon-position (position #\: identifier :test #'char=)))
(if colon-position
(values (subseq identifier 0 colon-position)
@@ -175,71 +204,78 @@
"If t, export newly interned symbols form their packages")
(defun resolve-identifier (identifier namespaces &optional as-attribute)
- "Resolve the string identifier in the list of namespaces"
- (flet ((intern-symbol (string package)
- (if *require-existing-symbols*
- (let ((symbol (find-symbol string package)))
- (or symbol
- (error "Symbol ~s does not exist in ~s" string package)))
- (let ((symbol (intern string package)))
- (when (and *auto-export-symbols*
- (not (eql package (find-package :keyword))))
- (export symbol package))
- symbol))))
- (multiple-value-bind (prefix name)
- (split-identifier identifier)
- (if (or (null prefix) (string= prefix "xmlns"))
- (if as-attribute
- (intern (if (string= prefix "xmlns") identifier name) (get-package *local-namespace*))
- (let ((default-namespace (find "" namespaces :key #'get-prefix :test #'string-equal)))
- (intern-symbol name (get-package default-namespace))))
- (let ((namespace (find prefix namespaces :key #'get-prefix :test #'string-equal)))
- (if namespace
- (intern-symbol name (get-package namespace))
- (error "namespace not found for prefix ~s" prefix)))))))
+ "Resolve the string identifier in the list of namespace bindings"
+ (if *ignore-namespaces*
+ (intern identifier :keyword)
+ (flet ((intern-symbol (string package) ; intern string as a symbol in package
+ (if *require-existing-symbols*
+ (let ((symbol (find-symbol string package)))
+ (or symbol
+ (error "Symbol ~s does not exist in ~s" string package)))
+ (let ((symbol (intern string package)))
+ (when (and *auto-export-symbols*
+ (not (eql package (find-package :keyword))))
+ (export symbol package))
+ symbol))))
+ (multiple-value-bind (prefix name)
+ (split-identifier identifier)
+ (if (or (null prefix) (string= prefix "xmlns"))
+ (if as-attribute
+ (intern (if (string= prefix "xmlns") identifier name) (get-package *local-namespace*))
+ (let ((default-namespace (find-namespace-binding "" namespaces)))
+ (intern-symbol name (get-package default-namespace))))
+ (let ((namespace (find-namespace-binding prefix namespaces)))
+ (if namespace
+ (intern-symbol name (get-package namespace))
+ (error "namespace not found for prefix ~s" prefix))))))))
(defvar *auto-create-namespace-packages* t
"If t, new packages will be created for namespaces, if needed, named by the prefix")
(defun extend-namespaces (attributes namespaces)
- "Given possible 'xmlns[:prefix]' attributes, extend namespaces"
- (let (default-namespace-uri)
- (loop :for (key . value) :in attributes
- :do (if (string= key "xmlns")
- (setf default-namespace-uri value)
- (multiple-value-bind (prefix name)
- (split-identifier key)
- (when (string= prefix "xmlns")
- (push (make-instance 'xml-namespace
- :uri value
- :prefix name
- :package (or (find-package name)
- (if *auto-create-namespace-packages*
- (make-package name :nicknames (list (string-upcase name)))
- (error "Cannot find or create package ~s" name))))
- namespaces)))))
- (when default-namespace-uri
- (let ((namespace (find default-namespace-uri namespaces :key #'get-uri :test #'string-equal)))
- (if namespace
- (push (make-instance 'xml-namespace
- :uri (get-uri namespace)
- :prefix ""
- :package (get-package namespace))
- namespaces)
- (error "No prefix found for default namespace ~s" default-namespace-uri)))))
+ "Given possible 'xmlns[:prefix]' attributes, extend the namespaces bindings"
+ (unless *ignore-namespaces*
+ (let (default-namespace-uri)
+ (loop :for (key . value) :in attributes
+ :do (if (string= key "xmlns")
+ (setf default-namespace-uri value)
+ (multiple-value-bind (prefix name)
+ (split-identifier key)
+ (when (string= prefix "xmlns")
+ (let* ((uri value)
+ (prefix name)
+ (namespace (find-namespace uri)))
+ (unless namespace
+ (setf namespace
+ (register-namespace uri
+ prefix
+ (or (find-package prefix)
+ (if *auto-create-namespace-packages*
+ (make-package prefix :nicknames `(,(string-upcase prefix)))
+ (error "Cannot find or create package ~s" prefix))))))
+ (push `(,prefix . ,namespace) namespaces))))))
+ (when default-namespace-uri
+ (let ((namespace (find-namespace default-namespace-uri)))
+ (if namespace
+ (push `("" . namespace) namespaces)
+ (error "No prefix found for default namespace ~s" default-namespace-uri))))))
namespaces)
(defun print-identifier (identifier stream &optional as-attribute)
"Print identifier on stream using namespace conventions"
- (declare (ignore as-attribute))
- (let (prefix name)
+ (declare (ignore as-attribute) (special *namespaces*))
+ (if *ignore-namespaces*
+ (princ identifier stream)
(if (symbolp identifier)
- (setf prefix (package-name (symbol-package identifier))
- name (symbol-name identifier))
- (setf (values prefix name) (split-identifier identifier)))
- (if (equal prefix "KEYWORD")
- (format stream "~a" name)
- (format stream "~a:~a" prefix name))))
+ (let ((package (symbol-package identifier))
+ (name (symbol-name identifier)))
+ (let* ((namespace (find package *known-namespaces* :key #'get-package))
+ (prefix (or (car (find namespace *namespaces* :key #'cdr))
+ (get-prefix namespace))))
+ (if (string= prefix "")
+ (princ name stream)
+ (format stream "~a:~a" prefix name))))
+ (princ identifier stream))))
;;; the parser state
