/[emacs]/emacs/lisp/xml.el
ViewVC logotype

Diff of /emacs/lisp/xml.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.18 by lektu, Thu Mar 20 18:01:04 2003 UTC revision 1.19 by fx, Mon May 19 16:01:39 2003 UTC
# Line 1  Line 1 
1  ;;; xml.el --- XML parser  ;;; xml.el --- XML parser
2    
3  ;; Copyright (C) 2000, 2001 Free Software Foundation, Inc.  ;; Copyright (C) 2000, 2001, 2003 Free Software Foundation, Inc.
4    
5  ;; Author: Emmanuel Briot  <briot@gnat.com>  ;; Author: Emmanuel Briot  <briot@gnat.com>
6  ;; Maintainer: Emmanuel Briot <briot@gnat.com>  ;; Maintainer: FSF
7  ;; Keywords: xml  ;; Keywords: xml, data
8    
9  ;; This file is part of GNU Emacs.  ;; This file is part of GNU Emacs.
10    
# Line 25  Line 25 
25    
26  ;;; Commentary:  ;;; Commentary:
27    
28  ;; This file contains a full XML parser. It parses a file, and returns a list  ;; This file contains a somewhat incomplete non-validating XML parser.  It
29  ;; that can be used internally by any other lisp file.  ;; parses a file, and returns a list that can be used internally by
30  ;; See some example in todo.el  ;; any other lisp libraries.
31    
32  ;;; FILE FORMAT  ;;; FILE FORMAT
33    
34  ;; It does not parse the DTD, if present in the XML file, but knows how to  ;; The document type declaration may either be ignored or (optionally)
35  ;; ignore it. The XML file is assumed to be well-formed. In case of error, the  ;; parsed, but currently the parsing will only accept element
36  ;; parsing stops and the XML file is shown where the parsing stopped.  ;; declarations.  The XML file is assumed to be well-formed. In case
37    ;; of error, the parsing stops and the XML file is shown where the
38    ;; parsing stopped.
39  ;;  ;;
40  ;; It also knows how to ignore comments, as well as the special ?xml? tag  ;; It also knows how to ignore comments and processing instructions.
 ;; in the XML file.  
41  ;;  ;;
42  ;; The XML file should have the following format:  ;; The XML file should have the following format:
43  ;;    <node1 attr1="name1" attr2="name2" ...>value  ;;    <node1 attr1="name1" attr2="name2" ...>value
# Line 63  Line 64 
64  ;;                       | nil  ;;                       | nil
65  ;;    string     ::= "..."  ;;    string     ::= "..."
66  ;;  ;;
67  ;; Some macros are provided to ease the parsing of this list  ;; Some macros are provided to ease the parsing of this list.
68    ;; Whitespace is preserved.  Fixme: There should be a tree-walker that
69    ;; can remove it.
70    
71  ;;; Code:  ;;; Code:
72    
73    ;; Note that {buffer-substring,match-string}-no-properties were
74    ;; formerly used in several places, but that removes composition info.
75    
76  ;;*******************************************************************  ;;*******************************************************************
77  ;;**  ;;**
78  ;;**  Macros to parse the list  ;;**  Macros to parse the list
# Line 114  An empty string is returned if the attri Line 120  An empty string is returned if the attri
120  ;;**  ;;**
121  ;;*******************************************************************  ;;*******************************************************************
122    
123    ;;;###autoload
124  (defun xml-parse-file (file &optional parse-dtd)  (defun xml-parse-file (file &optional parse-dtd)
125    "Parse the well-formed XML FILE.    "Parse the well-formed XML file FILE.
126  If FILE is already edited, this will keep the buffer alive.  If FILE is already visited, use its buffer and don't kill it.
127  Returns the top node with all its children.  Returns the top node with all its children.
128  If PARSE-DTD is non-nil, the DTD is parsed rather than skipped."  If PARSE-DTD is non-nil, the DTD is parsed rather than skipped."
129    (let ((keep))    (let ((keep))
# Line 124  If PARSE-DTD is non-nil, the DTD is pars Line 131  If PARSE-DTD is non-nil, the DTD is pars
131          (progn          (progn
132            (set-buffer (get-file-buffer file))            (set-buffer (get-file-buffer file))
133            (setq keep (point)))            (setq keep (point)))
134        (find-file file))        (let (auto-mode-alist)            ; no need for xml-mode
135            (find-file file)))
136    
137      (let ((xml (xml-parse-region (point-min)      (let ((xml (xml-parse-region (point-min)
138                                   (point-max)                                   (point-max)
# Line 135  If PARSE-DTD is non-nil, the DTD is pars Line 143  If PARSE-DTD is non-nil, the DTD is pars
143          (kill-buffer (current-buffer)))          (kill-buffer (current-buffer)))
144        xml)))        xml)))
145    
146    ;; Note that this is setup so that we can do whitespace-skipping with
147    ;; `(skip-syntax-forward " ")', inter alia.  Previously this was slow
148    ;; compared with `re-search-forward', but that has been fixed.  Also
149    ;; note that the standard syntax table contains other characters with
150    ;; whitespace syntax, like NBSP, but they are invalid in contexts in
151    ;; which we might skip whitespace -- specifically, they're not
152    ;; NameChars [XML 4].
153    
154    (defvar xml-syntax-table
155      (let ((table (make-syntax-table)))
156        ;; Get space syntax correct per XML [3].
157        (dotimes (c 31)
158          (modify-syntax-entry c "." table)) ; all are space in standard table
159        (dolist (c '(?\t ?\n ?\r))          ; these should be space
160          (modify-syntax-entry c " " table))
161        ;; For skipping attributes.
162        (modify-syntax-entry ?\" "\"" table)
163        (modify-syntax-entry ?' "\"" table)
164        ;; Non-alnum name chars should be symbol constituents (`-' and `_'
165        ;; are OK by default).
166        (modify-syntax-entry ?. "_" table)
167        (modify-syntax-entry ?: "_" table)
168        ;; XML [89]
169        (dolist (c '(#x00B7 #x02D0 #x02D1 #x0387 #x0640 #x0E46 #x0EC6 #x3005
170                     #x3031 #x3032 #x3033 #x3034 #x3035 #x309D #x309E #x30FC
171                     #x30FD #x30FE))
172          (modify-syntax-entry (decode-char 'ucs c) "w" table))
173        ;; Fixme: rest of [4]
174        table)
175      "Syntax table used by `xml-parse-region'.")
176    
177    ;; XML [5]
178    ;; Note that [:alpha:] matches all multibyte chars with word syntax.
179    (defconst xml-name-regexp "[[:alpha:]_:][[:alnum:]._:-]*")
180    
181    ;; Fixme:  This needs re-writing to deal with the XML grammar properly, i.e.
182    ;;   document    ::=    prolog element Misc*
183    ;;   prolog    ::=    XMLDecl? Misc* (doctypedecl Misc*)?
184    
185    ;;;###autoload
186  (defun xml-parse-region (beg end &optional buffer parse-dtd)  (defun xml-parse-region (beg end &optional buffer parse-dtd)
187    "Parse the region from BEG to END in BUFFER.    "Parse the region from BEG to END in BUFFER.
188  If BUFFER is nil, it defaults to the current buffer.  If BUFFER is nil, it defaults to the current buffer.
189  Returns the XML list for the region, or raises an error if the region  Returns the XML list for the region, or raises an error if the region
190  is not a well-formed XML file.  is not a well-formed XML file.
191  If PARSE-DTD is non-nil, the DTD is parsed rather than skipped,  If PARSE-DTD is non-nil, the DTD is parsed rather than skipped,
192  and returned as the first element of the list"  and returned as the first element of the list."
193    (let (xml result dtd)    (save-restriction
194      (save-excursion      (narrow-to-region beg end)
195        (if buffer      ;; Use fixed syntax table to ensure regexp char classes and syntax
196            (set-buffer buffer))      ;; specs DTRT.
197        (goto-char beg)      (with-syntax-table (standard-syntax-table)
198        (while (< (point) end)        (let ((case-fold-search nil)      ; XML is case-sensitive.
199          (if (search-forward "<" end t)              xml result dtd)
200              (progn          (save-excursion
201                (forward-char -1)            (if buffer
202                (if (null xml)                (set-buffer buffer))
203                    (progn            (goto-char (point-min))
204                      (setq result (xml-parse-tag end parse-dtd))            (while (not (eobp))
205                (if (search-forward "<" nil t)
206                    (progn
207                      (forward-char -1)
208                      (if xml
209                          ;;  translation of rule [1] of XML specifications
210                          (error "XML files can have only one toplevel tag")
211                        (setq result (xml-parse-tag parse-dtd))
212                      (cond                      (cond
213                       ((null result))                       ((null result))
214                       ((listp (car result))                       ((listp (car result))
215                        (setq dtd (car result))                        (setq dtd (car result))
216                        (add-to-list 'xml (cdr result)))                        (if (cdr result)  ; possible leading comment
217                              (add-to-list 'xml (cdr result))))
218                       (t                       (t
219                        (add-to-list 'xml result))))                        (add-to-list 'xml result)))))
220                  (goto-char (point-max))))
221                  ;;  translation of rule [1] of XML specifications            (if parse-dtd
222                  (error "XML files can have only one toplevel tag")))                (cons dtd (nreverse xml))
223            (goto-char end)))              (nreverse xml)))))))
       (if parse-dtd  
           (cons dtd (reverse xml))  
         (reverse xml)))))  
224    
225    
226  (defun xml-parse-tag (end &optional parse-dtd)  (defun xml-parse-tag (&optional parse-dtd)
227    "Parse the tag that is just in front of point.    "Parse the tag at point.
 The end tag must be found before the position END in the current buffer.  
228  If PARSE-DTD is non-nil, the DTD of the document, if any, is parsed and  If PARSE-DTD is non-nil, the DTD of the document, if any, is parsed and
229  returned as the first element in the list.  returned as the first element in the list.
230  Returns one of:  Returns one of:
231     - a list : the matching node   - a list : the matching node
232     - nil    : the point is not looking at a tag.   - nil    : the point is not looking at a tag.
233     - a cons cell: the first element is the DTD, the second is the node"   - a pair : the first element is the DTD, the second is the node."
234    (cond    (cond
235     ;; Processing instructions (like the <?xml version="1.0"?> tag at the     ;; Processing instructions (like the <?xml version="1.0"?> tag at the
236     ;; beginning of a document)     ;; beginning of a document).
237     ((looking-at "<\\?")     ((looking-at "<\\?")
238      (search-forward "?>" end)      (search-forward "?>")
239      (goto-char (- (re-search-forward "[^ \t\n\r]") 1))      (skip-syntax-forward " ")
240      (xml-parse-tag end))      (xml-parse-tag parse-dtd))
241     ;;  Character data (CDATA) sections, in which no tag should be interpreted     ;;  Character data (CDATA) sections, in which no tag should be interpreted
242     ((looking-at "<!\\[CDATA\\[")     ((looking-at "<!\\[CDATA\\[")
243      (let ((pos (match-end 0)))      (let ((pos (match-end 0)))
244        (unless (search-forward "]]>" end t)        (unless (search-forward "]]>" nil t)
245          (error "CDATA section does not end anywhere in the document"))          (error "CDATA section does not end anywhere in the document"))
246        (buffer-substring-no-properties pos (match-beginning 0))))        (buffer-substring pos (match-beginning 0))))
247     ;;  DTD for the document     ;;  DTD for the document
248     ((looking-at "<!DOCTYPE")     ((looking-at "<!DOCTYPE")
249      (let (dtd)      (let (dtd)
250        (if parse-dtd        (if parse-dtd
251            (setq dtd (xml-parse-dtd end))            (setq dtd (xml-parse-dtd))
252          (xml-skip-dtd end))          (xml-skip-dtd))
253        (goto-char (- (re-search-forward "[^ \t\n\r]") 1))        (skip-syntax-forward " ")
254        (if dtd        (if dtd
255            (cons dtd (xml-parse-tag end))            (cons dtd (xml-parse-tag))
256          (xml-parse-tag end))))          (xml-parse-tag))))
257     ;;  skip comments     ;;  skip comments
258     ((looking-at "<!--")     ((looking-at "<!--")
259      (search-forward "-->" end)      (search-forward "-->")
260      nil)      nil)
261     ;;  end tag     ;;  end tag
262     ((looking-at "</")     ((looking-at "</")
263      '())      '())
264     ;;  opening tag     ;;  opening tag
265     ((looking-at "<\\([^/> \t\n\r]+\\)")     ((looking-at "<\\([^/>[:space:]]+\\)")
266      (goto-char (match-end 1))      (goto-char (match-end 1))
267      (let* ((case-fold-search nil) ;; XML is case-sensitive.      (let* ((node-name (match-string 1))
            (node-name (match-string 1))  
268             ;; Parse the attribute list.             ;; Parse the attribute list.
269             (children (list (xml-parse-attlist end) (intern node-name)))             (children (list (xml-parse-attlist) (intern node-name)))
270             pos)             pos)
271    
272        ;; is this an empty element ?        ;; is this an empty element ?
273        (if (looking-at "/[ \t\n\r]*>")        (if (looking-at "/>")
274            (progn            (progn
275              (forward-char 2)              (forward-char 2)
276                ;; Fixme:  Inconsistent with the nil content returned from
277                ;; `<tag></tag>'.
278              (nreverse (cons '("") children)))              (nreverse (cons '("") children)))
279    
280          ;; is this a valid start tag ?          ;; is this a valid start tag ?
# Line 230  Returns one of: Line 283  Returns one of:
283                (forward-char 1)                (forward-char 1)
284                ;;  Now check that we have the right end-tag. Note that this                ;;  Now check that we have the right end-tag. Note that this
285                ;;  one might contain spaces after the tag name                ;;  one might contain spaces after the tag name
286                (while (not (looking-at (concat "</" node-name "[ \t\n\r]*>")))                (let ((end (concat "</" node-name "\\s-*>")))
287                  (cond                  (while (not (looking-at end))
288                   ((looking-at "</")                    (cond
289                    (error (concat                     ((looking-at "</")
290                            "XML: invalid syntax -- invalid end tag (expecting "                      (error "XML: Invalid end tag (expecting %s) at pos %d"
291                            node-name                             node-name (point)))
292                            ") at pos " (number-to-string (point)))))                     ((= (char-after) ?<)
293                   ((= (char-after) ?<)                      (let ((tag (xml-parse-tag)))
294                    (let ((tag (xml-parse-tag end)))                        (when tag
295                      (when tag                          (push tag children))))
296                        (push tag children))))                     (t
297                   (t                      (setq pos (point))
298                    (setq pos (point))                      (search-forward "<")
299                    (search-forward "<" end)                      (forward-char -1)
300                    (forward-char -1)                      (let ((string (buffer-substring pos (point)))
301                    (let ((string (buffer-substring-no-properties pos (point)))                            (pos 0))
302                          (pos 0))  
303                          ;; Clean up the string.  As per XML
304                          ;; specifications, the XML processor should
305                          ;; always pass the whole string to the
306                          ;; application.  But \r's should be replaced:
307                          ;; http://www.w3.org/TR/2000/REC-xml-20001006#sec-line-ends
308                          (while (string-match "\r\n?" string pos)
309                            (setq string (replace-match "\n" t t string))
310                            (setq pos (1+ (match-beginning 0))))
311    
312                          (setq string (xml-substitute-special string))
313                          (setq children
314                                (if (stringp (car children))
315                                    ;; The two strings were separated by a comment.
316                                    (cons (concat (car children) string)
317                                          (cdr children))
318                                  (cons string children))))))))
319    
                     ;; Clean up the string.  As per XML  
                     ;; specifications, the XML processor should  
                     ;; always pass the whole string to the  
                     ;; application.  But \r's should be replaced:  
                     ;; http://www.w3.org/TR/2000/REC-xml-20001006#sec-line-ends  
                     (while (string-match "\r\n?" string pos)  
                       (setq string (replace-match "\n" t t string))  
                       (setq pos (1+ (match-beginning 0))))  
   
                     (setq string (xml-substitute-special string))  
                     (setq children  
                           (if (stringp (car children))  
                               ;; The two strings were separated by a comment.  
                               (cons (concat (car children) string)  
                                     (cdr children))  
                             (cons string children)))))))  
320                (goto-char (match-end 0))                (goto-char (match-end 0))
               (if (> (point) end)  
                   (error "XML: End tag for %s not found before end of region"  
                          node-name))  
321                (nreverse children))                (nreverse children))
   
322            ;;  This was an invalid start tag            ;;  This was an invalid start tag
323            (error "XML: Invalid attribute list")            (error "XML: Invalid attribute list")))))
           ))))  
324     (t ;; This is not a tag.     (t ;; This is not a tag.
325      (error "XML: Invalid character"))      (error "XML: Invalid character"))))
    ))  
326    
327  (defun xml-parse-attlist (end)  (defun xml-parse-attlist ()
328    "Return the attribute-list that point is looking at.    "Return the attribute-list after point.
329  The search for attributes end at the position END in the current buffer.  Leave point at the first non-blank character after the tag."
 Leaves the point on the first non-blank character after the tag."  
330    (let ((attlist ())    (let ((attlist ())
331          start-pos name)          start-pos name)
332      (goto-char (- (re-search-forward "[^ \t\n\r]") 1))      (skip-syntax-forward " ")
333      (while (looking-at "\\([a-zA-Z_:][-a-zA-Z0-9._:]*\\)[ \t\n\r]*=[ \t\n\r]*")      (while (looking-at (eval-when-compile
334                             (concat "\\(" xml-name-regexp "\\)\\s-*=\\s-*")))
335        (setq name (intern (match-string 1)))        (setq name (intern (match-string 1)))
336        (goto-char (match-end 0))        (goto-char (match-end 0))
337    
# Line 304  Leaves the point on the first non-blank Line 351  Leaves the point on the first non-blank
351    
352        ;; Multiple whitespace characters should be replaced with a single one        ;; Multiple whitespace characters should be replaced with a single one
353        ;; in the attributes        ;; in the attributes
354        (let ((string (match-string-no-properties 1))        (let ((string (match-string 1))
355              (pos 0))              (pos 0))
356          (while (string-match "[ \t\n\r]+" string pos)          (replace-regexp-in-string "\\s-\\{2,\\}" " " string)
           (setq string (replace-match " " t nil string))  
           (setq pos (1+ (match-beginning 0))))  
357          (push (cons name (xml-substitute-special string)) attlist))          (push (cons name (xml-substitute-special string)) attlist))
358    
359        (goto-char start-pos)        (goto-char start-pos)
360        (if (looking-at "\"\\([^\"]*\\)\"")        (forward-sexp)                    ; we have string syntax
           (goto-char (match-end 0))  
         (if (looking-at "'\\([^']*\\)'")  
             (goto-char (match-end 0))))  
361    
362        (goto-char (- (re-search-forward "[^ \t\n\r]") 1))        (skip-syntax-forward " "))
       (if (> (point) end)  
           (error "XML: end of attribute list not found before end of region")))  
363      (nreverse attlist)))      (nreverse attlist)))
364    
365  ;;*******************************************************************  ;;*******************************************************************
# Line 330  Leaves the point on the first non-blank Line 370  Leaves the point on the first non-blank
370  ;;**  ;;**
371  ;;*******************************************************************  ;;*******************************************************************
372    
373  (defun xml-skip-dtd (end)  ;; Fixme: This fails at least if the DTD contains conditional sections.
374    "Skip the DTD that point is looking at.  
375  The DTD must end before the position END in the current buffer.  (defun xml-skip-dtd ()
376  The point must be just before the starting tag of the DTD.    "Skip the DTD at point.
377  This follows the rule [28] in the XML specifications."  This follows the rule [28] in the XML specifications."
378    (forward-char (length "<!DOCTYPE"))    (forward-char (length "<!DOCTYPE"))
379    (if (looking-at "[ \t\n\r]*>")    (if (looking-at "\\s-*>")
380        (error "XML: invalid DTD (excepting name of the document)"))        (error "XML: invalid DTD (excepting name of the document)"))
381    (condition-case nil    (condition-case nil
382        (progn        (progn
383          (forward-word 1)          (forward-sexp)
384          (goto-char (- (re-search-forward "[ \t\n\r]") 1))          (skip-syntax-forward " ")
         (goto-char (- (re-search-forward "[^ \t\n\r]") 1))  
385          (if (looking-at "\\[")          (if (looking-at "\\[")
386              (re-search-forward "\\][ \t\n\r]*>" end)              (re-search-forward "]\\s-*>")
387            (search-forward ">" end)))            (search-forward ">")))
388      (error (error "XML: No end to the DTD"))))      (error (error "XML: No end to the DTD"))))
389    
390  (defun xml-parse-dtd (end)  (defun xml-parse-dtd ()
391    "Parse the DTD that point is looking at.    "Parse the DTD at point."
392  The DTD must end before the position END in the current buffer."    (forward-char (eval-when-compile (length "<!DOCTYPE")))
393    (forward-char (length "<!DOCTYPE"))    (skip-syntax-forward " ")
   (goto-char (- (re-search-forward "[^ \t\n\r]") 1))  
394    (if (looking-at ">")    (if (looking-at ">")
395        (error "XML: invalid DTD (excepting name of the document)"))        (error "XML: invalid DTD (excepting name of the document)"))
396    
397    ;;  Get the name of the document    ;;  Get the name of the document
398    (looking-at "\\sw+")    (looking-at xml-name-regexp)
399    (let ((dtd (list (match-string-no-properties 0) 'dtd))    (let ((dtd (list (match-string 0) 'dtd))
400          type element end-pos)          type element end-pos)
401      (goto-char (match-end 0))      (goto-char (match-end 0))
402    
403      (goto-char (- (re-search-forward "[^ \t\n\r]") 1))      (skip-syntax-forward " ")
404        ;; XML [75]
405      ;;  External DTDs => don't know how to handle them yet      (cond ((looking-at "PUBLIC\\s-+")
406      (if (looking-at "SYSTEM")             (goto-char (match-end 0))
407          (error "XML: Don't know how to handle external DTDs"))             (unless (or (re-search-forward
408                            "\\=\"\\([[:space:][:alnum:]-'()+,./:=?;!*#@$_%]*\\)\""
409      (if (not (= (char-after) ?\[))                          nil t)
410          (error "XML: Unknown declaration in the DTD"))                         (re-search-forward
411                            "\\='\\([[:space:][:alnum:]-()+,./:=?;!*#@$_%]*\\)'"
412      ;;  Parse the rest of the DTD                          nil t))
413      (forward-char 1)               (error "XML: missing public id"))
414      (while (and (not (looking-at "[ \t\n\r]*\\]"))             (let ((pubid (match-string 1)))
415                  (<= (point) end))               (unless (or (re-search-forward "\\='\\([^']*\\)'" nil t)
416        (cond                           (re-search-forward "\\=\"\\([^\"]*\\)\"" nil t))
417                   (error "XML: missing system id"))
418         ;;  Translation of rule [45] of XML specifications               (push (list pubid (match-string 1) 'public) dtd)))
419         ((looking-at            ((looking-at "SYSTEM\\s-+")
420           "[ \t\n\r]*<!ELEMENT[ \t\n\r]+\\([a-zA-Z0-9.%;]+\\)[ \t\n\r]+\\([^>]+\\)>")             (goto-char (match-end 0))
421               (unless (or (re-search-forward "\\='\\([^']*\\)'" nil t)
422          (setq element (intern (match-string-no-properties 1))                         (re-search-forward "\\=\"\\([^\"]*\\)\"" nil t))
423                type    (match-string-no-properties 2))               (error "XML: missing system id"))
424          (setq end-pos (match-end 0))             (push (list (match-string 1) 'system) dtd)))
425        (skip-syntax-forward " ")
426          ;;  Translation of rule [46] of XML specifications      (if (eq ?> (char-after))
427          (cond          (forward-char)
428           ((string-match "^EMPTY[ \t\n\r]*$" type)     ;; empty declaration        (skip-syntax-forward " ")
429            (setq type 'empty))        (if (not (eq (char-after) ?\[))
430           ((string-match "^ANY[ \t\n\r]*$" type)       ;; any type of contents            (error "XML: bad DTD")
431            (setq type 'any))          (forward-char)
432           ((string-match "^(\\(.*\\))[ \t\n\r]*$" type) ;; children ([47])          ;;  Parse the rest of the DTD
433            (setq type (xml-parse-elem-type (match-string-no-properties 1 type))))          ;;  Fixme: Deal with ENTITY, ATTLIST, NOTATION, PIs.
434           ((string-match "^%[^;]+;[ \t\n\r]*$" type)   ;; substitution          (while (not (looking-at "\\s-*\\]"))
435            nil)            (skip-syntax-forward " ")
436           (t            (cond
437            (error "XML: Invalid element type in the DTD")))  
438               ;;  Translation of rule [45] of XML specifications
439          ;;  rule [45]: the element declaration must be unique             ((looking-at
440          (if (assoc element dtd)               "<!ELEMENT\\s-+\\([[:alnum:].%;]+\\)\\s-+\\([^>]+\\)>")
441              (error "XML: elements declaration must be unique in a DTD (<%s>)"  
442                     (symbol-name element)))              (setq element (intern (match-string 1))
443                      type    (match-string-no-properties 2))
444          ;;  Store the element in the DTD              (setq end-pos (match-end 0))
445          (push (list element type) dtd)  
446          (goto-char end-pos))              ;;  Translation of rule [46] of XML specifications
447                (cond
448                 ((string-match "^EMPTY[ \t\n\r]*$" type) ;; empty declaration
449                  (setq type 'empty))
450                 ((string-match "^ANY[ \t\n\r]*$" type) ;; any type of contents
451                  (setq type 'any))
452                 ((string-match "^(\\(.*\\))[ \t\n\r]*$" type) ;; children ([47])
453                  (setq type (xml-parse-elem-type (match-string 1 type))))
454                 ((string-match "^%[^;]+;[ \t\n\r]*$" type) ;; substitution
455                  nil)
456                 (t
457                  (error "XML: Invalid element type in the DTD")))
458    
459                ;;  rule [45]: the element declaration must be unique
460                (if (assoc element dtd)
461                    (error "XML: element declarations must be unique in a DTD (<%s>)"
462                           (symbol-name element)))
463    
464                ;;  Store the element in the DTD
465                (push (list element type) dtd)
466                (goto-char end-pos))
467               ((looking-at "<!--")
468                (search-forward "-->"))
469    
470               (t
471                (error "XML: Invalid DTD item")))
472    
473         (t            ;;  Skip the end of the DTD
474          (error "XML: Invalid DTD item"))            (search-forward ">"))))
        )  
       )  
   
     ;;  Skip the end of the DTD  
     (search-forward ">" end)  
475      (nreverse dtd)))      (nreverse dtd)))
476    
477    
478  (defun xml-parse-elem-type (string)  (defun xml-parse-elem-type (string)
479    "Convert a STRING for an element type into an elisp structure."    "Convert element type STRING into a Lisp structure."
480    
481    (let (elem modifier)    (let (elem modifier)
482      (if (string-match "(\\([^)]+\\))\\([+*?]?\\)" string)      (if (string-match "(\\([^)]+\\))\\([+*?]?\\)" string)
# Line 433  The DTD must end before the position END Line 490  The DTD must end before the position END
490              (if (string-match "," elem)              (if (string-match "," elem)
491                  (setq elem (cons 'seq                  (setq elem (cons 'seq
492                                   (mapcar 'xml-parse-elem-type                                   (mapcar 'xml-parse-elem-type
493                                           (split-string elem ","))))                                           (split-string elem ",")))))))
               )))  
494        (if (string-match "[ \t\n\r]*\\([^+*?]+\\)\\([+*?]?\\)" string)        (if (string-match "[ \t\n\r]*\\([^+*?]+\\)\\([+*?]?\\)" string)
495            (setq elem     (match-string 1 string)            (setq elem     (match-string 1 string)
496                  modifier (match-string 2 string))))                  modifier (match-string 2 string))))
# Line 454  The DTD must end before the position END Line 510  The DTD must end before the position END
510    
511  ;;*******************************************************************  ;;*******************************************************************
512  ;;**  ;;**
513  ;;**  Converting code points to strings  ;;**  Substituting special XML sequences
514  ;;**  ;;**
515  ;;*******************************************************************  ;;*******************************************************************
516    
517  (defun xml-ucs-to-string (codepoint)  (eval-when-compile
518    "Return a string representation of CODEPOINT.  If it can't be    (defvar str))                ; dynamic from replace-regexp-in-string
 converted, return '?'."  
   (cond ((boundp 'decode-char)  
          (char-to-string (decode-char 'ucs codepoint)))  
         ((and (< codepoint 128)  
               (> codepoint 31))  
          (char-to-string codepoint))  
         (t "?"))) ; FIXME: There's gotta be a better way to  
                   ; designate an unknown character.  
519    
520  ;;*******************************************************************  ;; Fixme:  Take declared entities from the DTD when they're available.
521  ;;**  (defun xml-substitute-entity (match)
522  ;;**  Substituting special XML sequences    "Subroutine of xml-substitute-special."
523  ;;**    (save-match-data
524  ;;*******************************************************************      (let ((match1 (match-string 1 str)))
525          (cond ((string= match1 "lt") "<")
526                ((string= match1 "gt") ">")
527                ((string= match1 "apos") "'")
528                ((string= match1 "quot") "\"")
529                ((string= match1 "amp") "&")
530                ((and (string-match "#\\([0-9]+\\)" match1)
531                      (let ((c (decode-char
532                                'ucs
533                                (string-to-number (match-string 1 match1)))))
534                        (if c (string c))))) ; else unrepresentable
535                ((and (string-match "#x\\([[:xdigit:]]+\\)" match1)
536                      (let ((c (decode-char
537                                'ucs
538                                (string-to-number (match-string 1 match1) 16))))
539                        (if c (string c)))))
540                ;; Default to asis.  Arguably, unrepresentable code points
541                ;; might be best replaced with U+FFFD.
542                (t match)))))
543    
544  (defun xml-substitute-special (string)  (defun xml-substitute-special (string)
545    "Return STRING, after subsituting special XML sequences."    "Return STRING, after subsituting entity references."
546    (while (string-match "&lt;" string)    ;; This originally made repeated passes through the string from the
547      (setq string (replace-match "<"  t nil string)))    ;; beginning, which isn't correct, since then either "&amp;amp;" or
548    (while (string-match "&gt;" string)    ;; "&#38;amp;" won't DTRT.
549      (setq string (replace-match ">"  t nil string)))    (replace-regexp-in-string "&\\([^;]+\\);"
550    (while (string-match "&apos;" string)                              #'xml-substitute-entity string t t))
     (setq string (replace-match "'"  t nil string)))  
   (while (string-match "&quot;" string)  
     (setq string (replace-match "\"" t nil string)))  
   (while (string-match "&#\\([0-9]+\\);" string)  
     (setq string (replace-match (xml-ucs-to-string  
                                  (string-to-number  
                                   (match-string-no-properties 1 string)))  
                                 t nil string)))  
   (while (string-match "&#x\\([0-9a-fA-F]+\\);" string)  
     (setq string (replace-match (xml-ucs-to-string  
                                  (string-to-number  
                                   (match-string-no-properties 1 string)  
                                   16))  
                                 t nil string)))  
   
   ;; This goes last so it doesn't confuse the matches above.  
   (while (string-match "&amp;" string)  
     (setq string (replace-match "&"  t nil string)))  
   string)  
551    
552  ;;*******************************************************************  ;;*******************************************************************
553  ;;**  ;;**
# Line 515  converted, return '?'." Line 562  converted, return '?'."
562    
563  (defun xml-debug-print-internal (xml indent-string)  (defun xml-debug-print-internal (xml indent-string)
564    "Outputs the XML tree in the current buffer.    "Outputs the XML tree in the current buffer.
565  The first line indented with INDENT-STRING."  The first line is indented with INDENT-STRING."
566    (let ((tree xml)    (let ((tree xml)
567          attlist)          attlist)
568      (insert indent-string "<" (symbol-name (xml-node-name tree)))      (insert indent-string ?< (symbol-name (xml-node-name tree)))
569    
570      ;;  output the attribute list      ;;  output the attribute list
571      (setq attlist (xml-node-attributes tree))      (setq attlist (xml-node-attributes tree))
572      (while attlist      (while attlist
573        (insert " ")        (insert ?\  (symbol-name (caar attlist)) "=\"" (cdar attlist) ?\")
       (insert (symbol-name (caar attlist)) "=\"" (cdar attlist) "\"")  
574        (setq attlist (cdr attlist)))        (setq attlist (cdr attlist)))
575    
576      (insert ">")      (insert ?>)
577    
578      (setq tree (xml-node-children tree))      (setq tree (xml-node-children tree))
579    
# Line 535  The first line indented with INDENT-STRI Line 581  The first line indented with INDENT-STRI
581      (dolist (node tree)      (dolist (node tree)
582        (cond        (cond
583         ((listp node)         ((listp node)
584          (insert "\n")          (insert ?\n)
585          (xml-debug-print-internal node (concat indent-string "  ")))          (xml-debug-print-internal node (concat indent-string "  ")))
586         ((stringp node) (insert node))         ((stringp node) (insert node))
587         (t         (t
588          (error "Invalid XML tree"))))          (error "Invalid XML tree"))))
589    
590      (insert "\n" indent-string      (insert ?\n indent-string
591              "</" (symbol-name (xml-node-name xml)) ">")))              ?< ?/ (symbol-name (xml-node-name xml)) ?>)))
592    
593  (provide 'xml)  (provide 'xml)
594    

Legend:
Removed from v.1.18  
changed lines
  Added in v.1.19

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26