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