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