X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=contrib%2Fxml.el;h=a495721330fc54279706a98f72367d3214d2c113;hb=f82adfd28c884445cb421bc0de8c430cc54e5240;hp=d128b83b34eccd087d9ccba8dc37f83beea01bc8;hpb=1fe2951f4f912ceb5d1402ca0bb7782835ea0f7a;p=gnus diff --git a/contrib/xml.el b/contrib/xml.el index d128b83b3..a49572133 100644 --- a/contrib/xml.el +++ b/contrib/xml.el @@ -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,16 +153,17 @@ and returned as the first element of the list" (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)))) ;; translation of rule [1] of XML specifications - (error "XML files can have only one toplevel tag."))) + (error "XML files can have only one toplevel tag"))) (goto-char end))) (if parse-dtd (cons dtd (reverse xml)) @@ -197,7 +196,7 @@ Returns one of: ((looking-at "" end) - (skip-chars-forward " \t\n") - (xml-parse-tag end)) + nil) ;; end 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 (= (char-after) ?>) + (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 ""))) (cond ((looking-at " (point) end) - (error "XML: End tag for %s not found before end of region." + (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") )))) (t ;; This is not a tag. - (error "XML: Invalid character.")) + (error "XML: Invalid character")) )) (defun xml-parse-attlist (end) "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), ;; or a simple word ? - (unless (looking-at "\"\\([^\"]+\\)\"") - (unless (looking-at "'\\([^\"]+\\)'") - (error "XML: Attribute values must be given between quotes."))) + (unless (looking-at "\"\\([^\"]*\\)\"") + (unless (looking-at "'\\([^']*\\)'") + (error "XML: Attribute values must be given between quotes"))) ;; Each attribute must be unique within a given element (if (assoc name attlist) - (error "XML: each attribute must be unique within an element.")) + (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.")) + (error "XML: end of attribute list not found before end of region")) ) - attlist - )) + (nreverse attlist))) ;;******************************************************************* ;;** @@ -335,25 +332,25 @@ This follows the rule [28] in the XML specifications." (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 "") - (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 "") + (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") ;; External DTDs => don't know how to handle them yet (if (looking-at "SYSTEM") - (error "XML: Don't know how to handle external DTDs.")) + (error "XML: Don't know how to handle external DTDs")) (if (not (= (char-after) ?\[)) - (error "XML: Unknown declaration in the DTD.")) + (error "XML: Unknown declaration in the DTD")) ;; Parse the rest of the DTD (forward-char 1) @@ -367,16 +364,16 @@ The DTD must end before the position END in the current buffer." (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 @@ -384,13 +381,12 @@ The DTD must end before the position END in the current buffer." ;; rule [45]: the element declaration must be unique (if (assoc element dtd) - (error "XML: elements declaration must be unique in a DTD (<%s>)." + (error "XML: elements declaration must be unique in a DTD (<%s>)" (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 @@ The DTD must end before the position END in the current buffer." ;; Skip the end of the DTD (search-forward ">" end) - dtd - )) + (nreverse dtd))) (defun xml-parse-elem-type (string) @@ -413,11 +408,11 @@ The DTD must end before the position END in the current buffer." (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 @@ The DTD must end before the position END in the current buffer." (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 @@ The DTD must end before the position END in the current buffer." (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 @@ The DTD must end before the position END in the current buffer." ;;******************************************************************* (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 - "") - )) + ""))) (provide 'xml)