1 ;;;; -*- mode: lisp -*-
 2 ;;;;
 3 ;;;; $Id: sxml-dom.lisp,v 1.5 2005/11/20 14:34:15 scaekenberghe Exp $
 4 ;;;;
 5 ;;;; LXML implementation of the generic DOM parser and printer.
 6 ;;;;
 7 ;;;; Copyright (C) 2003, 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 ;;; the sxml hooks to generate sxml
16 
17 (defun sxml-new-element-hook (name attributes seed)
18   (declare (ignore name attributes seed))
19   '())
20 
21 (defun sxml-finish-element-hook (name attributes parent-seed seed)
22   (let ((xml-element (append (list name)
23 			     (when attributes
24 			       (list (let (list)
25 				       (dolist (attribute attributes (cons :@ list))
26 					 (push (list (car attribute) (cdr attribute)) list)))))
27 			     (nreverse seed))))
28     (cons xml-element parent-seed)))
29 
30 (defun sxml-text-hook (string seed)
31   (cons string seed))
32 
33 ;;; the standard DOM interfaces
34 
35 (defmethod parse-xml-dom (stream (output-type (eql :sxml)))
36   (car (start-parse-xml stream
37 			(make-instance 'xml-parser-state
38 				       :new-element-hook #'sxml-new-element-hook
39 				       :finish-element-hook #'sxml-finish-element-hook
40 				       :text-hook #'sxml-text-hook))))
41 
42 (defmethod print-xml-dom (dom (input-type (eql :sxml)) stream pretty level)
43   (declare (special *namespaces*))
44   (cond ((stringp dom) (print-string-xml dom stream))
45 	((consp dom)
46 	 (let ((tag (first dom))
47 	       attributes
48 	       children)
49 	   (if (and (consp (second dom)) (eq (first (second dom)) :@))
50 	       (setf attributes (rest (second dom))
51 		     children (rest (rest dom)))
52 	     (setf children (rest dom)))
53            (let ((*namespaces* (extend-namespaces (loop :for (name value) :in attributes 
54                                                         :collect (cons name value))
55                                                   *namespaces*)))
56              (write-char #\< stream)
57              (print-identifier tag stream)
58              (loop :for (name value) :in attributes
59                    :do (print-attribute name value stream))
60              (if children
61                  (progn
62                    (write-char #\> stream)
63                    (if (and (= (length children) 1) (stringp (first children)))
64                        (print-string-xml (first children) stream)
65                      (progn
66                        (dolist (child children)
67                          (when pretty (print-spaces (* 2 level) stream))
68                          (if (stringp child)
69                              (print-string-xml child stream)
70                            (print-xml-dom child input-type stream pretty (1+ level))))
71                        (when pretty (print-spaces (* 2 (1- level)) stream))))
72                    (print-closing-tag tag stream))
73                (write-string "/>" stream)))))
74 	(t (error "Input not recognized as SXML ~s" dom))))
75 
76 ;;;; eof