Mercurial > emacs
diff lisp/xml.el @ 42031:54db4085a7df
Use setq rather than (set 'foo bar).
Use push+nreverse rather than append.
(xml-node-name, xml-node-attributes, xml-node-children):
Use defsubst rather than macros.
(xml-parse-region): Handle a nil return value from xml-parse-tag.
(xml-parse-tag): Don't skip white space. Return nil for a comment.
Concat the two strings surrounding a comment into a single string.
author | Stefan Monnier <monnier@iro.umontreal.ca> |
---|---|
date | Fri, 14 Dec 2001 22:12:30 +0000 |
parents | 7507bd185307 |
children | 373960858ccc |
line wrap: on
line diff
--- a/lisp/xml.el Fri Dec 14 21:53:29 2001 +0000 +++ b/lisp/xml.el Fri Dec 14 22:12:30 2001 +0000 @@ -73,32 +73,30 @@ ;;** ;;******************************************************************* -(defmacro xml-node-name (node) +(defsubst xml-node-name (node) "Return the tag associated with NODE. The tag is a lower-case symbol." - (list 'car node)) + (car node)) -(defmacro xml-node-attributes (node) +(defsubst xml-node-attributes (node) "Return the list of attributes of NODE. The list can be nil." - (list 'nth 1 node)) + (nth 1 node)) -(defmacro xml-node-children (node) +(defsubst xml-node-children (node) "Return the list of children of NODE. This is a list of nodes, and it can be nil." - (list 'cddr node)) + (cddr node)) (defun xml-get-children (node child-name) "Return the children of NODE whose tag is CHILD-NAME. CHILD-NAME should be a lower case symbol." - (let ((children (xml-node-children node)) - match) - (while children - (if (car children) - (if (equal (xml-node-name (car children)) child-name) - (set 'match (append match (list (car children)))))) - (set 'children (cdr children))) - match)) + (let ((match ())) + (dolist (child (xml-node-children node)) + (if child + (if (equal (xml-node-name child) child-name) + (push child match)))) + (nreverse match))) (defun xml-get-attribute (node attribute) "Get from NODE the value of ATTRIBUTE. @@ -155,10 +153,11 @@ (forward-char -1) (if (null xml) (progn - (set 'result (xml-parse-tag end parse-dtd)) + (setq result (xml-parse-tag end parse-dtd)) (cond + ((null result)) ((listp (car result)) - (set 'dtd (car result)) + (setq dtd (car result)) (add-to-list 'xml (cdr result))) (t (add-to-list 'xml result)))) @@ -197,7 +196,7 @@ ((looking-at "<!DOCTYPE") (let (dtd) (if parse-dtd - (set 'dtd (xml-parse-dtd end)) + (setq dtd (xml-parse-dtd end)) (xml-skip-dtd end)) (skip-chars-forward " \t\n") (if dtd @@ -206,36 +205,31 @@ ;; skip comments ((looking-at "<!--") (search-forward "-->" end) - (skip-chars-forward " \t\n") - (xml-parse-tag end)) + nil) ;; end tag ((looking-at "</") '()) ;; opening tag ((looking-at "<\\([^/> \t\n]+\\)") - (let* ((node-name (match-string 1)) - (children (list (intern node-name))) - (case-fold-search nil) ;; XML is case-sensitive + (goto-char (match-end 1)) + (let* ((case-fold-search nil) ;; XML is case-sensitive. + (node-name (match-string 1)) + ;; Parse the attribute list. + (children (list (xml-parse-attlist end) (intern node-name))) pos) - (goto-char (match-end 1)) - - ;; parses the attribute list - (set 'children (append children (list (xml-parse-attlist end)))) ;; is this an empty element ? (if (looking-at "/>") (progn (forward-char 2) - (skip-chars-forward " \t\n") - (append children '(""))) + (nreverse (cons '("") children))) ;; is this a valid start tag ? (if (eq (char-after) ?>) (progn (forward-char 1) - (skip-chars-forward " \t\n") - ;; Now check that we have the right end-tag. Note that this one might - ;; contain spaces after the tag name + ;; Now check that we have the right end-tag. Note that this + ;; one might contain spaces after the tag name (while (not (looking-at (concat "</" node-name "[ \t\n]*>"))) (cond ((looking-at "</") @@ -244,9 +238,11 @@ node-name ") at pos " (number-to-string (point))))) ((= (char-after) ?<) - (set 'children (append children (list (xml-parse-tag end))))) + (let ((tag (xml-parse-tag end))) + (when tag + (push tag children)))) (t - (set 'pos (point)) + (setq pos (point)) (search-forward "<" end) (forward-char -1) (let ((string (buffer-substring-no-properties pos (point))) @@ -256,18 +252,21 @@ ;; Not done, since as per XML specifications, the XML processor ;; should always pass the whole string to the application. ;; (while (string-match "\\s +" string pos) - ;; (set 'string (replace-match " " t t string)) - ;; (set 'pos (1+ (match-beginning 0)))) - - (set 'children (append children - (list (xml-substitute-special string)))))))) + ;; (setq string (replace-match " " 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))))))) (goto-char (match-end 0)) - (skip-chars-forward " \t\n") (if (> (point) end) (error "XML: End tag for %s not found before end of region" node-name)) - children - ) + (nreverse children)) ;; This was an invalid start tag (error "XML: Invalid attribute list") @@ -280,11 +279,11 @@ "Return the attribute-list that point is looking at. The search for attributes end at the position END in the current buffer. Leaves the point on the first non-blank character after the tag." - (let ((attlist '()) + (let ((attlist ()) name) (skip-chars-forward " \t\n") (while (looking-at "\\([a-zA-Z_:][-a-zA-Z0-9._:]*\\)[ \t\n]*=[ \t\n]*") - (set 'name (intern (match-string 1))) + (setq name (intern (match-string 1))) (goto-char (match-end 0)) ;; Do we have a string between quotes (or double-quotes), @@ -297,15 +296,13 @@ (if (assoc name attlist) (error "XML: each attribute must be unique within an element")) - (set 'attlist (append attlist - (list (cons name (match-string-no-properties 1))))) + (push (cons name (match-string-no-properties 1)) attlist) (goto-char (match-end 0)) (skip-chars-forward " \t\n") (if (> (point) end) (error "XML: end of attribute list not found before end of region")) ) - attlist - )) + (nreverse attlist))) ;;******************************************************************* ;;** @@ -335,15 +332,15 @@ (defun xml-parse-dtd (end) "Parse the DTD that point is looking at. The DTD must end before the position END in the current buffer." - (let (dtd type element end-pos) - (forward-char (length "<!DOCTYPE")) - (skip-chars-forward " \t\n") - (if (looking-at ">") - (error "XML: invalid DTD (excepting name of the document)")) - - ;; Get the name of the document - (looking-at "\\sw+") - (set 'dtd (list 'dtd (match-string-no-properties 0))) + (forward-char (length "<!DOCTYPE")) + (skip-chars-forward " \t\n") + (if (looking-at ">") + (error "XML: invalid DTD (excepting name of the document)")) + + ;; Get the name of the document + (looking-at "\\sw+") + (let ((dtd (list (match-string-no-properties 0) 'dtd)) + type element end-pos) (goto-char (match-end 0)) (skip-chars-forward " \t\n") @@ -367,16 +364,16 @@ (setq element (intern (match-string-no-properties 1)) type (match-string-no-properties 2)) - (set 'end-pos (match-end 0)) + (setq end-pos (match-end 0)) ;; Translation of rule [46] of XML specifications (cond ((string-match "^EMPTY[ \t\n]*$" type) ;; empty declaration - (set 'type 'empty)) + (setq type 'empty)) ((string-match "^ANY[ \t\n]*$" type) ;; any type of contents - (set 'type 'any)) + (setq type 'any)) ((string-match "^(\\(.*\\))[ \t\n]*$" type) ;; children ([47]) - (set 'type (xml-parse-elem-type (match-string-no-properties 1 type)))) + (setq type (xml-parse-elem-type (match-string-no-properties 1 type)))) ((string-match "^%[^;]+;[ \t\n]*$" type) ;; substitution nil) (t @@ -388,9 +385,8 @@ (symbol-name element))) ;; Store the element in the DTD - (set 'dtd (append dtd (list (list element type)))) - (goto-char end-pos) - ) + (push (list element type) dtd) + (goto-char end-pos)) (t @@ -400,8 +396,7 @@ ;; Skip the end of the DTD (search-forward ">" end) - dtd - )) + (nreverse dtd))) (defun xml-parse-elem-type (string) @@ -413,11 +408,11 @@ (setq elem (match-string 1 string) modifier (match-string 2 string)) (if (string-match "|" elem) - (set 'elem (append '(choice) + (setq elem (cons 'choice (mapcar 'xml-parse-elem-type (split-string elem "|")))) (if (string-match "," elem) - (set 'elem (append '(seq) + (setq elem (cons 'seq (mapcar 'xml-parse-elem-type (split-string elem ",")))) ))) @@ -425,19 +420,18 @@ (setq elem (match-string 1 string) modifier (match-string 2 string)))) - (if (and (stringp elem) - (string= elem "#PCDATA")) - (set 'elem 'pcdata)) + (if (and (stringp elem) (string= elem "#PCDATA")) + (setq elem 'pcdata)) - (cond - ((string= modifier "+") - (list '+ elem)) - ((string= modifier "*") - (list '* elem)) - ((string= modifier "?") - (list '? elem)) - (t - elem)))) + (cond + ((string= modifier "+") + (list '+ elem)) + ((string= modifier "*") + (list '* elem)) + ((string= modifier "?") + (list '? elem)) + (t + elem)))) ;;******************************************************************* @@ -449,15 +443,15 @@ (defun xml-substitute-special (string) "Return STRING, after subsituting special XML sequences." (while (string-match "&" string) - (set 'string (replace-match "&" t nil string))) + (setq string (replace-match "&" t nil string))) (while (string-match "<" string) - (set 'string (replace-match "<" t nil string))) + (setq string (replace-match "<" t nil string))) (while (string-match ">" string) - (set 'string (replace-match ">" t nil string))) + (setq string (replace-match ">" t nil string))) (while (string-match "'" string) - (set 'string (replace-match "'" t nil string))) + (setq string (replace-match "'" t nil string))) (while (string-match """ string) - (set 'string (replace-match "\"" t nil string))) + (setq string (replace-match "\"" t nil string))) string) ;;******************************************************************* @@ -468,50 +462,39 @@ ;;******************************************************************* (defun xml-debug-print (xml) - (while xml - (xml-debug-print-internal (car xml) "") - (set 'xml (cdr xml))) - ) + (dolist (node xml) + (xml-debug-print-internal node ""))) -(defun xml-debug-print-internal (xml &optional indent-string) +(defun xml-debug-print-internal (xml indent-string) "Outputs the XML tree in the current buffer. The first line indented with INDENT-STRING." (let ((tree xml) attlist) - (unless indent-string - (set 'indent-string "")) - (insert indent-string "<" (symbol-name (xml-node-name tree))) ;; output the attribute list - (set 'attlist (xml-node-attributes tree)) + (setq attlist (xml-node-attributes tree)) (while attlist (insert " ") (insert (symbol-name (caar attlist)) "=\"" (cdar attlist) "\"") - (set 'attlist (cdr attlist))) + (setq attlist (cdr attlist))) (insert ">") - (set 'tree (xml-node-children tree)) + (setq tree (xml-node-children tree)) ;; output the children - (while tree + (dolist (node tree) (cond - ((listp (car tree)) + ((listp node) (insert "\n") - (xml-debug-print-internal (car tree) (concat indent-string " ")) - ) - ((stringp (car tree)) - (insert (car tree)) - ) + (xml-debug-print-internal node (concat indent-string " "))) + ((stringp node) (insert node)) (t - (error "Invalid XML tree"))) - (set 'tree (cdr tree)) - ) + (error "Invalid XML tree")))) (insert "\n" indent-string - "</" (symbol-name (xml-node-name xml)) ">") - )) + "</" (symbol-name (xml-node-name xml)) ">"))) (provide 'xml)