/[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.8 by monnier, Thu Oct 18 20:22:53 2001 UTC revision 1.9 by monnier, Fri Dec 14 22:12:30 2001 UTC
# Line 73  Line 73 
73  ;;**  ;;**
74  ;;*******************************************************************  ;;*******************************************************************
75    
76  (defmacro xml-node-name       (node)  (defsubst xml-node-name (node)
77    "Return the tag associated with NODE.    "Return the tag associated with NODE.
78  The tag is a lower-case symbol."  The tag is a lower-case symbol."
79    (list 'car node))    (car node))
80    
81  (defmacro xml-node-attributes (node)  (defsubst xml-node-attributes (node)
82    "Return the list of attributes of NODE.    "Return the list of attributes of NODE.
83  The list can be nil."  The list can be nil."
84    (list 'nth 1 node))    (nth 1 node))
85    
86  (defmacro xml-node-children   (node)  (defsubst xml-node-children (node)
87    "Return the list of children of NODE.    "Return the list of children of NODE.
88  This is a list of nodes, and it can be nil."  This is a list of nodes, and it can be nil."
89    (list 'cddr node))    (cddr node))
90    
91  (defun xml-get-children (node child-name)  (defun xml-get-children (node child-name)
92    "Return the children of NODE whose tag is CHILD-NAME.    "Return the children of NODE whose tag is CHILD-NAME.
93  CHILD-NAME should be a lower case symbol."  CHILD-NAME should be a lower case symbol."
94    (let ((children (xml-node-children node))    (let ((match ()))
95          match)      (dolist (child (xml-node-children node))
96      (while children        (if child
97        (if (car children)            (if (equal (xml-node-name child) child-name)
98            (if (equal (xml-node-name (car children)) child-name)                (push child match))))
99                (set 'match (append match (list (car children))))))      (nreverse match)))
       (set 'children (cdr children)))  
     match))  
100    
101  (defun xml-get-attribute (node attribute)  (defun xml-get-attribute (node attribute)
102    "Get from NODE the value of ATTRIBUTE.    "Get from NODE the value of ATTRIBUTE.
# Line 155  and returned as the first element of the Line 153  and returned as the first element of the
153                (forward-char -1)                (forward-char -1)
154                (if (null xml)                (if (null xml)
155                    (progn                    (progn
156                      (set 'result (xml-parse-tag end parse-dtd))                      (setq result (xml-parse-tag end parse-dtd))
157                      (cond                      (cond
158                         ((null result))
159                       ((listp (car result))                       ((listp (car result))
160                        (set 'dtd (car result))                        (setq dtd (car result))
161                        (add-to-list 'xml (cdr result)))                        (add-to-list 'xml (cdr result)))
162                       (t                       (t
163                        (add-to-list 'xml result))))                        (add-to-list 'xml result))))
# Line 197  Returns one of: Line 196  Returns one of:
196     ((looking-at "<!DOCTYPE")     ((looking-at "<!DOCTYPE")
197      (let (dtd)      (let (dtd)
198        (if parse-dtd        (if parse-dtd
199            (set 'dtd (xml-parse-dtd end))            (setq dtd (xml-parse-dtd end))
200          (xml-skip-dtd end))          (xml-skip-dtd end))
201        (skip-chars-forward " \t\n")        (skip-chars-forward " \t\n")
202        (if dtd        (if dtd
# Line 206  Returns one of: Line 205  Returns one of:
205     ;;  skip comments     ;;  skip comments
206     ((looking-at "<!--")     ((looking-at "<!--")
207      (search-forward "-->" end)      (search-forward "-->" end)
208      (skip-chars-forward " \t\n")      nil)
     (xml-parse-tag end))  
209     ;;  end tag     ;;  end tag
210     ((looking-at "</")     ((looking-at "</")
211      '())      '())
212     ;;  opening tag     ;;  opening tag
213     ((looking-at "<\\([^/> \t\n]+\\)")     ((looking-at "<\\([^/> \t\n]+\\)")
214      (let* ((node-name (match-string 1))      (goto-char (match-end 1))
215             (children (list (intern node-name)))      (let* ((case-fold-search nil) ;; XML is case-sensitive.
216             (case-fold-search nil) ;; XML is case-sensitive             (node-name (match-string 1))
217               ;; Parse the attribute list.
218               (children (list (xml-parse-attlist end) (intern node-name)))
219             pos)             pos)
       (goto-char (match-end 1))  
   
       ;; parses the attribute list  
       (set 'children (append children (list (xml-parse-attlist end))))  
220    
221        ;; is this an empty element ?        ;; is this an empty element ?
222        (if (looking-at "/>")        (if (looking-at "/>")
223            (progn            (progn
224              (forward-char 2)              (forward-char 2)
225              (skip-chars-forward " \t\n")              (nreverse (cons '("") children)))
             (append children '("")))  
226    
227          ;; is this a valid start tag ?          ;; is this a valid start tag ?
228          (if (eq (char-after) ?>)          (if (eq (char-after) ?>)
229              (progn              (progn
230                (forward-char 1)                (forward-char 1)
231                (skip-chars-forward " \t\n")                ;;  Now check that we have the right end-tag. Note that this
232                ;;  Now check that we have the right end-tag. Note that this one might                ;;  one might contain spaces after the tag name
               ;;  contain spaces after the tag name  
233                (while (not (looking-at (concat "</" node-name "[ \t\n]*>")))                (while (not (looking-at (concat "</" node-name "[ \t\n]*>")))
234                  (cond                  (cond
235                   ((looking-at "</")                   ((looking-at "</")
# Line 244  Returns one of: Line 238  Returns one of:
238                            node-name                            node-name
239                            ") at pos " (number-to-string (point)))))                            ") at pos " (number-to-string (point)))))
240                   ((= (char-after) ?<)                   ((= (char-after) ?<)
241                    (set 'children (append children (list (xml-parse-tag end)))))                    (let ((tag (xml-parse-tag end)))
242                        (when tag
243                          (push tag children))))
244                   (t                   (t
245                    (set 'pos (point))                    (setq pos (point))
246                    (search-forward "<" end)                    (search-forward "<" end)
247                    (forward-char -1)                    (forward-char -1)
248                    (let ((string (buffer-substring-no-properties pos (point)))                    (let ((string (buffer-substring-no-properties pos (point)))
# Line 256  Returns one of: Line 252  Returns one of:
252                      ;; Not done, since as per XML specifications, the XML processor                      ;; Not done, since as per XML specifications, the XML processor
253                      ;; should always pass the whole string to the application.                      ;; should always pass the whole string to the application.
254                      ;;      (while (string-match "\\s +" string pos)                      ;;      (while (string-match "\\s +" string pos)
255                      ;;        (set 'string (replace-match " " t t string))                      ;;        (setq string (replace-match " " t t string))
256                      ;;        (set 'pos (1+ (match-beginning 0))))                      ;;        (setq pos (1+ (match-beginning 0))))
257                        
258                      (set 'children (append children                      (setq string (xml-substitute-special string))
259                                             (list (xml-substitute-special string))))))))                      (setq children
260                              (if (stringp (car children))
261                                  ;; The two strings were separated by a comment.
262                                  (cons (concat (car children) string)
263                                        (cdr children))
264                                (cons string children)))))))
265                (goto-char (match-end 0))                (goto-char (match-end 0))
               (skip-chars-forward " \t\n")  
266                (if (> (point) end)                (if (> (point) end)
267                    (error "XML: End tag for %s not found before end of region"                    (error "XML: End tag for %s not found before end of region"
268                           node-name))                           node-name))
269                children                (nreverse children))
               )  
270    
271            ;;  This was an invalid start tag            ;;  This was an invalid start tag
272            (error "XML: Invalid attribute list")            (error "XML: Invalid attribute list")
# Line 280  Returns one of: Line 279  Returns one of:
279    "Return the attribute-list that point is looking at.    "Return the attribute-list that point is looking at.
280  The search for attributes end at the position END in the current buffer.  The search for attributes end at the position END in the current buffer.
281  Leaves the point on the first non-blank character after the tag."  Leaves the point on the first non-blank character after the tag."
282    (let ((attlist '())    (let ((attlist ())
283          name)          name)
284      (skip-chars-forward " \t\n")      (skip-chars-forward " \t\n")
285      (while (looking-at "\\([a-zA-Z_:][-a-zA-Z0-9._:]*\\)[ \t\n]*=[ \t\n]*")      (while (looking-at "\\([a-zA-Z_:][-a-zA-Z0-9._:]*\\)[ \t\n]*=[ \t\n]*")
286        (set 'name (intern (match-string 1)))        (setq name (intern (match-string 1)))
287        (goto-char (match-end 0))        (goto-char (match-end 0))
288    
289        ;; Do we have a string between quotes (or double-quotes),        ;; Do we have a string between quotes (or double-quotes),
# Line 297  Leaves the point on the first non-blank Line 296  Leaves the point on the first non-blank
296        (if (assoc name attlist)        (if (assoc name attlist)
297            (error "XML: each attribute must be unique within an element"))            (error "XML: each attribute must be unique within an element"))
298                
299        (set 'attlist (append attlist        (push (cons name (match-string-no-properties 1)) attlist)
                             (list (cons name (match-string-no-properties 1)))))  
300        (goto-char (match-end 0))        (goto-char (match-end 0))
301        (skip-chars-forward " \t\n")        (skip-chars-forward " \t\n")
302        (if (> (point) end)        (if (> (point) end)
303            (error "XML: end of attribute list not found before end of region"))            (error "XML: end of attribute list not found before end of region"))
304        )        )
305      attlist      (nreverse attlist)))
     ))  
306    
307  ;;*******************************************************************  ;;*******************************************************************
308  ;;**  ;;**
# Line 335  This follows the rule [28] in the XML sp Line 332  This follows the rule [28] in the XML sp
332  (defun xml-parse-dtd (end)  (defun xml-parse-dtd (end)
333    "Parse the DTD that point is looking at.    "Parse the DTD that point is looking at.
334  The DTD must end before the position END in the current buffer."  The DTD must end before the position END in the current buffer."
335    (let (dtd type element end-pos)    (forward-char (length "<!DOCTYPE"))
336      (forward-char (length "<!DOCTYPE"))    (skip-chars-forward " \t\n")
337      (skip-chars-forward " \t\n")    (if (looking-at ">")
338      (if (looking-at ">")        (error "XML: invalid DTD (excepting name of the document)"))
339          (error "XML: invalid DTD (excepting name of the document)"))    
340      ;;  Get the name of the document
341      ;;  Get the name of the document    (looking-at "\\sw+")
342      (looking-at "\\sw+")    (let ((dtd (list (match-string-no-properties 0) 'dtd))
343      (set 'dtd (list 'dtd (match-string-no-properties 0)))          type element end-pos)
344      (goto-char (match-end 0))      (goto-char (match-end 0))
345    
346      (skip-chars-forward " \t\n")      (skip-chars-forward " \t\n")
# Line 367  The DTD must end before the position END Line 364  The DTD must end before the position END
364    
365          (setq element (intern (match-string-no-properties 1))          (setq element (intern (match-string-no-properties 1))
366                type    (match-string-no-properties 2))                type    (match-string-no-properties 2))
367          (set 'end-pos (match-end 0))          (setq end-pos (match-end 0))
368                    
369          ;;  Translation of rule [46] of XML specifications          ;;  Translation of rule [46] of XML specifications
370          (cond          (cond
371           ((string-match "^EMPTY[ \t\n]*$" type)     ;; empty declaration           ((string-match "^EMPTY[ \t\n]*$" type)     ;; empty declaration
372            (set 'type 'empty))            (setq type 'empty))
373           ((string-match "^ANY[ \t\n]*$" type)       ;; any type of contents           ((string-match "^ANY[ \t\n]*$" type)       ;; any type of contents
374            (set 'type 'any))            (setq type 'any))
375           ((string-match "^(\\(.*\\))[ \t\n]*$" type) ;; children ([47])           ((string-match "^(\\(.*\\))[ \t\n]*$" type) ;; children ([47])
376            (set 'type (xml-parse-elem-type (match-string-no-properties 1 type))))            (setq type (xml-parse-elem-type (match-string-no-properties 1 type))))
377           ((string-match "^%[^;]+;[ \t\n]*$" type)   ;; substitution           ((string-match "^%[^;]+;[ \t\n]*$" type)   ;; substitution
378            nil)            nil)
379           (t           (t
# Line 388  The DTD must end before the position END Line 385  The DTD must end before the position END
385                     (symbol-name element)))                     (symbol-name element)))
386                    
387          ;;  Store the element in the DTD          ;;  Store the element in the DTD
388          (set 'dtd (append dtd (list (list element type))))          (push (list element type) dtd)
389          (goto-char end-pos)          (goto-char end-pos))
         )  
390    
391    
392         (t         (t
# Line 400  The DTD must end before the position END Line 396  The DTD must end before the position END
396    
397      ;;  Skip the end of the DTD      ;;  Skip the end of the DTD
398      (search-forward ">" end)      (search-forward ">" end)
399    dtd      (nreverse dtd)))
   ))  
400    
401    
402  (defun xml-parse-elem-type (string)  (defun xml-parse-elem-type (string)
# Line 413  The DTD must end before the position END Line 408  The DTD must end before the position END
408            (setq elem     (match-string 1 string)            (setq elem     (match-string 1 string)
409                  modifier (match-string 2 string))                  modifier (match-string 2 string))
410            (if (string-match "|" elem)            (if (string-match "|" elem)
411                (set 'elem (append '(choice)                (setq elem (cons 'choice
412                                 (mapcar 'xml-parse-elem-type                                 (mapcar 'xml-parse-elem-type
413                                         (split-string elem "|"))))                                         (split-string elem "|"))))
414              (if (string-match "," elem)              (if (string-match "," elem)
415                  (set 'elem (append '(seq)                  (setq elem (cons 'seq
416                                   (mapcar 'xml-parse-elem-type                                   (mapcar 'xml-parse-elem-type
417                                           (split-string elem ","))))                                           (split-string elem ","))))
418                )))                )))
# Line 425  The DTD must end before the position END Line 420  The DTD must end before the position END
420            (setq elem     (match-string 1 string)            (setq elem     (match-string 1 string)
421                  modifier (match-string 2 string))))                  modifier (match-string 2 string))))
422    
423        (if (and (stringp elem)      (if (and (stringp elem) (string= elem "#PCDATA"))
424                 (string= elem "#PCDATA"))          (setq elem 'pcdata))
           (set 'elem 'pcdata))  
425            
426        (cond      (cond
427         ((string= modifier "+")       ((string= modifier "+")
428          (list '+ elem))        (list '+ elem))
429         ((string= modifier "*")       ((string= modifier "*")
430          (list '* elem))        (list '* elem))
431         ((string= modifier "?")       ((string= modifier "?")
432          (list '? elem))        (list '? elem))
433         (t       (t
434          elem))))        elem))))
435    
436    
437  ;;*******************************************************************  ;;*******************************************************************
# Line 449  The DTD must end before the position END Line 443  The DTD must end before the position END
443  (defun xml-substitute-special (string)  (defun xml-substitute-special (string)
444    "Return STRING, after subsituting special XML sequences."    "Return STRING, after subsituting special XML sequences."
445    (while (string-match "&amp;" string)    (while (string-match "&amp;" string)
446      (set 'string (replace-match "&"  t nil string)))      (setq string (replace-match "&"  t nil string)))
447    (while (string-match "&lt;" string)    (while (string-match "&lt;" string)
448      (set 'string (replace-match "<"  t nil string)))      (setq string (replace-match "<"  t nil string)))
449    (while (string-match "&gt;" string)    (while (string-match "&gt;" string)
450      (set 'string (replace-match ">"  t nil string)))      (setq string (replace-match ">"  t nil string)))
451    (while (string-match "&apos;" string)    (while (string-match "&apos;" string)
452      (set 'string (replace-match "'"  t nil string)))      (setq string (replace-match "'"  t nil string)))
453    (while (string-match "&quot;" string)    (while (string-match "&quot;" string)
454      (set 'string (replace-match "\"" t nil string)))      (setq string (replace-match "\"" t nil string)))
455    string)    string)
456    
457  ;;*******************************************************************  ;;*******************************************************************
# Line 468  The DTD must end before the position END Line 462  The DTD must end before the position END
462  ;;*******************************************************************  ;;*******************************************************************
463    
464  (defun xml-debug-print (xml)  (defun xml-debug-print (xml)
465    (while xml    (dolist (node xml)
466      (xml-debug-print-internal (car xml) "")      (xml-debug-print-internal node "")))
     (set 'xml (cdr xml)))  
   )  
467    
468  (defun xml-debug-print-internal (xml &optional indent-string)  (defun xml-debug-print-internal (xml indent-string)
469    "Outputs the XML tree in the current buffer.    "Outputs the XML tree in the current buffer.
470  The first line indented with INDENT-STRING."  The first line indented with INDENT-STRING."
471    (let ((tree xml)    (let ((tree xml)
472          attlist)          attlist)
     (unless indent-string  
       (set 'indent-string ""))  
       
473      (insert indent-string "<" (symbol-name (xml-node-name tree)))      (insert indent-string "<" (symbol-name (xml-node-name tree)))
474            
475      ;;  output the attribute list      ;;  output the attribute list
476      (set 'attlist (xml-node-attributes tree))      (setq attlist (xml-node-attributes tree))
477      (while attlist      (while attlist
478        (insert " ")        (insert " ")
479        (insert (symbol-name (caar attlist)) "=\"" (cdar attlist) "\"")        (insert (symbol-name (caar attlist)) "=\"" (cdar attlist) "\"")
480        (set 'attlist (cdr attlist)))        (setq attlist (cdr attlist)))
481            
482      (insert ">")      (insert ">")
483            
484      (set 'tree (xml-node-children tree))      (setq tree (xml-node-children tree))
485    
486      ;;  output the children      ;;  output the children
487      (while tree      (dolist (node tree)
488        (cond        (cond
489         ((listp (car tree))         ((listp node)
490          (insert "\n")          (insert "\n")
491          (xml-debug-print-internal (car tree) (concat indent-string "  "))          (xml-debug-print-internal node (concat indent-string "  ")))
492          )         ((stringp node) (insert node))
        ((stringp (car tree))  
         (insert (car tree))  
         )  
493         (t         (t
494          (error "Invalid XML tree")))          (error "Invalid XML tree"))))
       (set 'tree (cdr tree))  
      )  
495    
496      (insert "\n" indent-string      (insert "\n" indent-string
497              "</" (symbol-name (xml-node-name xml)) ">")              "</" (symbol-name (xml-node-name xml)) ">")))
     ))  
498    
499  (provide 'xml)  (provide 'xml)
500    

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9

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