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