1 ;;;; -*- mode: lisp -*-
  2 ;;;;
  3 ;;;; $Id: xml-struct-dom.lisp,v 1.3 2005/09/20 09:57:48 scaekenberghe Exp $
  4 ;;;;
  5 ;;;; XML-STRUCT implementation of the generic DOM parser and printer.
  6 ;;;;
  7 ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
  8 ;;;;
  9 ;;;; You are granted the rights to distribute and use this software
 10 ;;;; as governed by the terms of the Lisp Lesser General Public License
 11 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
 12 
 13 (in-package :s-xml)
 14 
 15 ;;; xml-element struct datastructure and API
 16 
 17 (defstruct xml-element
 18   name        ; :tag-name
 19   attributes  ; a assoc list of (:attribute-name . "attribute-value")
 20   children    ; a list of children/content either text strings or xml-elements
 21   )
 22 
 23 (setf (documentation 'xml-element-p 'function)
 24       "Return T when the argument is an xml-element struct"
 25       (documentation 'xml-element-attributes 'function)
 26       "Return the alist of attribute names and values dotted pairs from an xml-element struct"
 27       (documentation 'xml-element-children 'function)
 28       "Return the list of children from an xml-element struct"
 29       (documentation 'xml-element-name 'function)
 30       "Return the name from an xml-element struct"
 31       (documentation 'make-xml-element 'function)
 32       "Make and return a new xml-element struct")
 33 
 34 (defun xml-element-attribute (xml-element key)
 35   "Return the string value of the attribute with name the keyword :key
 36   of xml-element if any, return null if not found"
 37   (let ((pair (assoc key (xml-element-attributes xml-element) :test #'eq)))
 38     (when pair (cdr pair))))
 39 
 40 (defun (setf xml-element-attribute) (value xml-element key)
 41   "Set the string value of the attribute with name the keyword :key of
 42   xml-element, creating a new attribute if necessary or overwriting an
 43   existing one, returning the value"
 44   (let ((attributes (xml-element-attributes xml-element)))
 45     (if (null attributes)
 46 	(push (cons key value) (xml-element-attributes xml-element))
 47       (let ((pair (assoc key attributes :test #'eq)))
 48 	(if pair
 49 	    (setf (cdr pair) value)
 50 	  (push (cons key value) (xml-element-attributes xml-element)))))
 51     value))
 52 
 53 (defun new-xml-element (name &rest children)
 54   "Make a new xml-element with name and children"
 55   (make-xml-element :name name :children children))
 56 
 57 (defun first-xml-element-child (xml-element)
 58   "Get the first child of an xml-element"
 59   (first (xml-element-children xml-element)))
 60 
 61 (defun xml-equal (xml-1 xml-2)
 62   (and (xml-element-p xml-1)
 63        (xml-element-p xml-2)
 64        (eq (xml-element-name xml-1)
 65 	   (xml-element-name xml-2))
 66        (equal (xml-element-attributes xml-1)
 67 	      (xml-element-attributes xml-2))
 68        (reduce #'(lambda (&optional (x t) (y t)) (and x y))
 69 	       (mapcar #'(lambda (x y)
 70 			   (or (and (stringp x) (stringp y) (string= x y))
 71 			       (xml-equal x y)))
 72 		       (xml-element-children xml-1)
 73 		       (xml-element-children xml-2)))))
 74 
 75 ;;; printing xml structures
 76 
 77 (defmethod print-xml-dom (xml-element (input-type (eql :xml-struct)) stream pretty level)
 78   (declare (special *namespaces*))
 79   (let ((*namespaces* (extend-namespaces (xml-element-attributes xml-element)
 80                                          *namespaces*)))
 81     (write-char #\< stream)
 82     (print-identifier (xml-element-name xml-element) stream)
 83     (loop :for (name . value) :in (xml-element-attributes xml-element)
 84           :do (print-attribute name value stream))
 85     (let ((children (xml-element-children xml-element))) 
 86       (if children
 87           (progn
 88             (write-char #\> stream)
 89             (if (and (= (length children) 1) (stringp (first children)))
 90                 (print-string-xml (first children) stream)
 91               (progn
 92                 (dolist (child children)
 93                   (when pretty (print-spaces (* 2 level) stream))
 94                   (if (stringp child)
 95                       (print-string-xml child stream)
 96                     (print-xml-dom child input-type stream pretty (1+ level))))
 97                 (when pretty (print-spaces (* 2 (1- level)) stream))))
 98             (print-closing-tag (xml-element-name xml-element) stream))
 99         (write-string "/>" stream)))))
100 
101 ;;; the standard hooks to generate xml-element structs
102 
103 (defun standard-new-element-hook (name attributes seed)
104   (declare (ignore name attributes seed))
105   '())
106 
107 (defun standard-finish-element-hook (name attributes parent-seed seed)
108   (let ((xml-element (make-xml-element :name name
109 				       :attributes attributes
110 				       :children (nreverse seed))))
111     (cons xml-element parent-seed)))
112 
113 (defun standard-text-hook (string seed)
114   (cons string seed))
115 
116 ;;; top level standard parser interfaces
117 
118 (defmethod parse-xml-dom (stream (output-type (eql :xml-struct)))
119   (car (start-parse-xml stream
120 			(make-instance 'xml-parser-state
121 				       :new-element-hook #'standard-new-element-hook
122 				       :finish-element-hook #'standard-finish-element-hook
123 				       :text-hook #'standard-text-hook))))
124 
125 ;;;; eof