blob: e3465753f60438de809702a25c1509cc0a848e2f (
plain)
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
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
|
;; pg-xml.el XML functions for Proof General
;;
;; Copyright (C) 2000-2002 LFCS Edinburgh.
;; Author: David Aspinall <David.Aspinall@ed.ac.uk>
;; License: GPL (GNU GENERAL PUBLIC LICENSE)
;;
;; $Id$
;;
;; XML functions for Proof General.
;;
(require 'proof-utils) ;; for pg-internal-warning
(cond
;; We want to find a good version of xml.el
(proof-running-on-XEmacs
(require 'xml-fixed)) ;; XEmacs: used PG bundled fixed version
(t ;; Otherwise use GNU Emacs distrib version.
(require 'xml)))
;; Elisp format of XML trees (see xml.el)
;;
;; xml-list ::= (node node ...)
;; node ::= (qname attribute-list . child_node_list)
;; child_node_list ::= child_node child_node ...
;; child_node ::= node | string
;; qname ::= (:namespace-uri . "name") | "name"
;; attribute_list ::= ((qname . "value") (qname . "value") ...)
;; | nil
;; string ::= "..."
;;
;; NB [da]: without namespace aware parsing, qnames are symbols.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Parsing function: pg-xml-parse-buffer
;;
;;;###autoload
(defun pg-xml-parse-string (arg)
"Parse string in ARG, same as pg-xml-parse-buffer."
(let
((tempbuffer (get-buffer-create " *xml-parse*")))
(save-excursion
(set-buffer tempbuffer)
(delete-region (point-min) (point-max))
(insert-string arg)
(pg-xml-parse-buffer (current-buffer) 'nomessage))))
(defun pg-xml-parse-buffer (&optional buffer nomsg)
"Parse an XML documment in BUFFER (defaulting to current buffer).
Parsing according to `xml-parse-file' of xml.el."
(unless nomsg
(message "Parsing %s..." (buffer-name buffer)))
(let ((xml (xml-parse-region (point-min)
(point-max)
(current-buffer)
nil)))
(unless nomsg
(message "Parsing %s...done" (buffer-name buffer)))
xml))
;; Check that the empty parsing bug isn't present
(if (xml-node-children (car (pg-xml-parse-string "<foo/>")))
(pg-internal-warning "An old version of xml.el was loaded! It is buggy. See Proof General FAQ."))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Helper functions for parsing
;;
(defun pg-xml-get-attr (attribute node &optional optional defaultval)
(let ((val (cdr (assoc attribute (xml-node-attributes node)))))
(or val
(if optional
defaultval
(pg-pgip-error "pg-xml-get-attr: Didn't find required %s attribute in %s element"
attribute (xml-node-name node))))))
(defun pg-xml-child-elts (node)
"Return list of *element* children of NODE (ignoring strings)."
(let ((children (xml-node-children node)))
(mapcan (lambda (x) (if (listp x) (list x))) children)))
(defun pg-xml-child-elt (node)
"Return unique element child of NODE."
(let ((children (pg-xml-child-elts node)))
(if (= (length children) 1)
(car children)
(pg-internal-warning "pg-xml-child-elt: expected single element child of %s"
(xml-node-name node)))))
(defun pg-xml-get-child (child node)
"Return single element CHILD of node, give error if more than one."
(let ((children (xml-get-children node child)))
(if (> (length children) 1)
(progn
(pg-internal-warning "pg-xml-get-child: got more than one %s child of %s node, ignoring rest"
child (xml-node-name node))
(car children))
children)))
(defun pg-xml-get-text-content (node)
"Return the concatenation of all the text children of node NODE."
(mapconcat (lambda (x) (if (stringp x) x "")) (xml-node-children node) ""))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Producing functions: constructing an XML tree in xml.el format
;; and converting to a string
(defmacro pg-xml-attr (name val) `(cons (quote ,name) ,val))
(defmacro pg-xml-node (name atts children)
`(cons (quote ,name) (cons ,atts ,children)))
(defconst pg-xml-header
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n")
(defun pg-xml-string-of (xmls)
"Convert the XML trees in XMLS into a string (without additional indentation)."
(let ((insertfn (lambda (&rest args)
(setq strs (cons (reduce 'concat args) strs))))
strs)
(dolist (xml xmls)
(pg-xml-output-internal xml nil insertfn))
(reduce 'concat (reverse strs))))
;; based on xml-debug-print from xml.el
(defun pg-xml-output-internal (xml indent-string outputfn)
"Outputs the XML tree using OUTPUTFN, which should accept a list of args.
Output with indentation INDENT-STRING (or none if nil)."
(let ((tree xml)
attlist)
(funcall outputfn (or indent-string "") "<" (symbol-name (xml-node-name tree)))
;; output the attribute list
(setq attlist (xml-node-attributes tree))
(while attlist
(funcall outputfn " ")
(funcall outputfn (symbol-name (caar attlist)) "=\"" (cdar attlist) "\"")
(setq attlist (cdr attlist)))
(setq tree (xml-node-children tree))
(if tree
(progn
(funcall outputfn ">")
;; output the children
(dolist (node tree)
(cond
((listp node)
(if indent-string (funcall outputfn "\n"))
(pg-xml-output-internal node (if indent-string (concat indent-string " ")) outputfn))
((stringp node) (funcall outputfn node))
(t
(error "pg-xml-output-internal: Invalid XML tree"))))
(funcall outputfn (if indent-string (concat "\n" indent-string) "")
"</" (symbol-name (xml-node-name xml)) ">"))
(funcall outputfn "/>"))))
(defun pg-xml-cdata (str)
(concat "<!\\[CDATA\\[" str "\\]"))
(provide 'pg-xml)
;; End of `pg-xml.el'
|
