comparison 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.

42030:74a3864ffe9a

;;**
;;**  Macros to parse the list
;;**
;;*******************************************************************

(defmacro xml-node-name       (node)
  "Return the tag associated with NODE.
The tag is a lower-case symbol."
  (list 'car node))

(defmacro xml-node-attributes (node)
  "Return the list of attributes of NODE.
The list can be nil."
  (list 'nth 1 node))

(defmacro 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))

(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))

(defun xml-get-attribute (node attribute)
  "Get from NODE the value of ATTRIBUTE.
An empty string is returned if the attribute was not found."
  (if (xml-node-attributes node)

	(if (search-forward "<" end t)
	    (progn
	      (forward-char -1)
	      (if (null xml)
		  (progn
		    (set 'result (xml-parse-tag end parse-dtd))
		    (cond
		     ((listp (car result))
		      (set 'dtd (car result))
		      (add-to-list 'xml (cdr result)))
		     (t
		      (add-to-list 'xml result))))

		;;  translation of rule [1] of XML specifications

      (buffer-substring-no-properties pos (match-beginning 0))))
   ;;  DTD for the document
   ((looking-at "<!DOCTYPE")
    (let (dtd)
      (if parse-dtd
	  (set 'dtd (xml-parse-dtd end))
	(xml-skip-dtd end))
      (skip-chars-forward " \t\n")
      (if dtd
	  (cons dtd (xml-parse-tag end))
	(xml-parse-tag end))))
   ;;  skip comments
   ((looking-at "<!--")
    (search-forward "-->" end)
    (skip-chars-forward " \t\n")
    (xml-parse-tag end))
   ;;  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
	   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 '("")))

	;; 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
	      (while (not (looking-at (concat "</" node-name "[ \t\n]*>")))
		(cond
		 ((looking-at "</")
		  (error (concat
			  "XML: invalid syntax -- invalid end tag (expecting "
			  node-name
			  ") at pos " (number-to-string (point)))))
		 ((= (char-after) ?<)
		  (set 'children (append children (list (xml-parse-tag end)))))
		 (t
		  (set 'pos (point))
		  (search-forward "<" end)
		  (forward-char -1)
		  (let ((string (buffer-substring-no-properties pos (point)))
			(pos 0))
		    
		    ;; Clean up the string (no newline characters)
		    ;; 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))))))))
	      (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
	      )

	  ;;  This was an invalid start tag
	  (error "XML: Invalid attribute list")
	  ))))
   (t ;; This is not a tag.

(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 '())
	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)))
      (goto-char (match-end 0))

      ;; Do we have a string between quotes (or double-quotes),
      ;;  or a simple word ?
      (unless (looking-at "\"\\([^\"]+\\)\"")

      ;; Each attribute must be unique within a given element
      (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)))))
      (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
    ))

;;*******************************************************************
;;**
;;**  The DTD (document type declaration)
;;**  The following functions know how to skip or parse the DTD of

    (error (error "XML: No end to the DTD"))))

(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)))
    (goto-char (match-end 0))

    (skip-chars-forward " \t\n")

    ;;  External DTDs => don't know how to handle them yet

       ((looking-at
	 "[\t \n]*<!ELEMENT[ \t\n]+\\([a-zA-Z0-9.%;]+\\)[ \t\n]+\\([^>]+\\)>")

	(setq element (intern (match-string-no-properties 1))
	      type    (match-string-no-properties 2))
	(set 'end-pos (match-end 0))
	
	;;  Translation of rule [46] of XML specifications
	(cond
	 ((string-match "^EMPTY[ \t\n]*$" type)     ;; empty declaration
	  (set 'type 'empty))
	 ((string-match "^ANY[ \t\n]*$" type)       ;; any type of contents
	  (set 'type 'any))
	 ((string-match "^(\\(.*\\))[ \t\n]*$" type) ;; children ([47])
	  (set 'type (xml-parse-elem-type (match-string-no-properties 1 type))))
	 ((string-match "^%[^;]+;[ \t\n]*$" type)   ;; substitution
	  nil)
	 (t
	  (error "XML: Invalid element type in the DTD")))

	(if (assoc element dtd)
	    (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)
	)


       (t
	(error "XML: Invalid DTD item"))
       )
      )

    ;;  Skip the end of the DTD
    (search-forward ">" end)
  dtd
  ))


(defun xml-parse-elem-type (string)
  "Convert a STRING for an element type into an elisp structure."

    (if (string-match "(\\([^)]+\\))\\([+*?]?\\)" string)
	(progn
	  (setq elem     (match-string 1 string)
		modifier (match-string 2 string))
	  (if (string-match "|" elem)
	      (set 'elem (append '(choice)
			       (mapcar 'xml-parse-elem-type
				       (split-string elem "|"))))
	    (if (string-match "," elem)
		(set 'elem (append '(seq)
				 (mapcar 'xml-parse-elem-type
					 (split-string elem ","))))
	      )))
      (if (string-match "[ \t\n]*\\([^+*?]+\\)\\([+*?]?\\)" string)
	  (setq elem     (match-string 1 string)
		modifier (match-string 2 string))))

      (if (and (stringp elem)
	       (string= elem "#PCDATA"))
	  (set 'elem 'pcdata))
    
      (cond
       ((string= modifier "+")
	(list '+ elem))
       ((string= modifier "*")
	(list '* elem))
       ((string= modifier "?")
	(list '? elem))
       (t
	elem))))


;;*******************************************************************
;;**
;;**  Substituting special XML sequences

;;*******************************************************************

(defun xml-substitute-special (string)
  "Return STRING, after subsituting special XML sequences."
  (while (string-match "&" string)
    (set 'string (replace-match "&"  t nil string)))
  (while (string-match "<" string)
    (set 'string (replace-match "<"  t nil string)))
  (while (string-match "&gt;" string)
    (set 'string (replace-match ">"  t nil string)))
  (while (string-match "&apos;" string)
    (set 'string (replace-match "'"  t nil string)))
  (while (string-match "&quot;" string)
    (set 'string (replace-match "\"" t nil string)))
  string)

;;*******************************************************************
;;**
;;**  Printing a tree.
;;**  This function is intended mainly for debugging purposes.
;;**
;;*******************************************************************

(defun xml-debug-print (xml)
  (while xml
    (xml-debug-print-internal (car xml) "")
    (set 'xml (cdr xml)))
  )

(defun xml-debug-print-internal (xml &optional 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))
    (while attlist
      (insert " ")
      (insert (symbol-name (caar attlist)) "=\"" (cdar attlist) "\"")
      (set 'attlist (cdr attlist)))
    
    (insert ">")
    
    (set 'tree (xml-node-children tree))

    ;;  output the children
    (while tree
      (cond
       ((listp (car tree))
	(insert "\n")
	(xml-debug-print-internal (car tree) (concat indent-string "  "))
	)
       ((stringp (car tree))
	(insert (car tree))
	)
       (t
	(error "Invalid XML tree")))
      (set 'tree (cdr tree))
     )

    (insert "\n" indent-string
	    "</" (symbol-name (xml-node-name xml)) ">")
    ))

(provide 'xml)

;;; xml.el ends here

42031:54db4085a7df

;;**
;;**  Macros to parse the list
;;**
;;*******************************************************************

(defsubst xml-node-name (node)
  "Return the tag associated with NODE.
The tag is a lower-case symbol."
  (car node))

(defsubst xml-node-attributes (node)
  "Return the list of attributes of NODE.
The list can be nil."
  (nth 1 node))

(defsubst xml-node-children (node)
  "Return the list of children of NODE.
This is a list of nodes, and it can be nil."
  (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 ((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.
An empty string is returned if the attribute was not found."
  (if (xml-node-attributes node)

	(if (search-forward "<" end t)
	    (progn
	      (forward-char -1)
	      (if (null xml)
		  (progn
		    (setq result (xml-parse-tag end parse-dtd))
		    (cond
		     ((null result))
		     ((listp (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

      (buffer-substring-no-properties pos (match-beginning 0))))
   ;;  DTD for the document
   ((looking-at "<!DOCTYPE")
    (let (dtd)
      (if parse-dtd
	  (setq dtd (xml-parse-dtd end))
	(xml-skip-dtd end))
      (skip-chars-forward " \t\n")
      (if dtd
	  (cons dtd (xml-parse-tag end))
	(xml-parse-tag end))))
   ;;  skip comments
   ((looking-at "<!--")
    (search-forward "-->" end)
    nil)
   ;;  end tag
   ((looking-at "</")
    '())
   ;;  opening tag
   ((looking-at "<\\([^/> \t\n]+\\)")
    (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)

      ;; is this an empty element ?
      (if (looking-at "/>")
	  (progn
	    (forward-char 2)
	    (nreverse (cons '("") children)))

	;; is this a valid start tag ?
	(if (eq (char-after) ?>)
	    (progn
	      (forward-char 1)
	      ;;  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 "</")
		  (error (concat
			  "XML: invalid syntax -- invalid end tag (expecting "
			  node-name
			  ") at pos " (number-to-string (point)))))
		 ((= (char-after) ?<)
		  (let ((tag (xml-parse-tag end)))
		    (when tag
		      (push tag children))))
		 (t
		  (setq pos (point))
		  (search-forward "<" end)
		  (forward-char -1)
		  (let ((string (buffer-substring-no-properties pos (point)))
			(pos 0))
		    
		    ;; Clean up the string (no newline characters)
		    ;; 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)
		    ;; 	      (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))
	      (if (> (point) end)
		  (error "XML: End tag for %s not found before end of region"
			 node-name))
	      (nreverse children))

	  ;;  This was an invalid start tag
	  (error "XML: Invalid attribute list")
	  ))))
   (t ;; This is not a tag.

(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 ())
	name)
    (skip-chars-forward " \t\n")
    (while (looking-at "\\([a-zA-Z_:][-a-zA-Z0-9._:]*\\)[ \t\n]*=[ \t\n]*")
      (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 "\"\\([^\"]+\\)\"")

      ;; Each attribute must be unique within a given element
      (if (assoc name attlist)
	  (error "XML: each attribute must be unique within an element"))
      
      (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"))
      )
    (nreverse attlist)))

;;*******************************************************************
;;**
;;**  The DTD (document type declaration)
;;**  The following functions know how to skip or parse the DTD of

    (error (error "XML: No end to the DTD"))))

(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."
  (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")

    ;;  External DTDs => don't know how to handle them yet

       ((looking-at
	 "[\t \n]*<!ELEMENT[ \t\n]+\\([a-zA-Z0-9.%;]+\\)[ \t\n]+\\([^>]+\\)>")

	(setq element (intern (match-string-no-properties 1))
	      type    (match-string-no-properties 2))
	(setq end-pos (match-end 0))
	
	;;  Translation of rule [46] of XML specifications
	(cond
	 ((string-match "^EMPTY[ \t\n]*$" type)     ;; empty declaration
	  (setq type 'empty))
	 ((string-match "^ANY[ \t\n]*$" type)       ;; any type of contents
	  (setq type 'any))
	 ((string-match "^(\\(.*\\))[ \t\n]*$" type) ;; children ([47])
	  (setq type (xml-parse-elem-type (match-string-no-properties 1 type))))
	 ((string-match "^%[^;]+;[ \t\n]*$" type)   ;; substitution
	  nil)
	 (t
	  (error "XML: Invalid element type in the DTD")))

	(if (assoc element dtd)
	    (error "XML: elements declaration must be unique in a DTD (<%s>)"
		   (symbol-name element)))
	
	;;  Store the element in the DTD
	(push (list element type) dtd)
	(goto-char end-pos))


       (t
	(error "XML: Invalid DTD item"))
       )
      )

    ;;  Skip the end of the DTD
    (search-forward ">" end)
    (nreverse dtd)))


(defun xml-parse-elem-type (string)
  "Convert a STRING for an element type into an elisp structure."

    (if (string-match "(\\([^)]+\\))\\([+*?]?\\)" string)
	(progn
	  (setq elem     (match-string 1 string)
		modifier (match-string 2 string))
	  (if (string-match "|" elem)
	      (setq elem (cons 'choice
			       (mapcar 'xml-parse-elem-type
				       (split-string elem "|"))))
	    (if (string-match "," elem)
		(setq elem (cons 'seq
				 (mapcar 'xml-parse-elem-type
					 (split-string elem ","))))
	      )))
      (if (string-match "[ \t\n]*\\([^+*?]+\\)\\([+*?]?\\)" string)
	  (setq elem     (match-string 1 string)
		modifier (match-string 2 string))))

    (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))))


;;*******************************************************************
;;**
;;**  Substituting special XML sequences

;;*******************************************************************

(defun xml-substitute-special (string)
  "Return STRING, after subsituting special XML sequences."
  (while (string-match "&" string)
    (setq string (replace-match "&"  t nil string)))
  (while (string-match "<" string)
    (setq string (replace-match "<"  t nil string)))
  (while (string-match "&gt;" string)
    (setq string (replace-match ">"  t nil string)))
  (while (string-match "&apos;" string)
    (setq string (replace-match "'"  t nil string)))
  (while (string-match "&quot;" string)
    (setq string (replace-match "\"" t nil string)))
  string)

;;*******************************************************************
;;**
;;**  Printing a tree.
;;**  This function is intended mainly for debugging purposes.
;;**
;;*******************************************************************

(defun xml-debug-print (xml)
  (dolist (node xml)
    (xml-debug-print-internal node "")))

(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)
    (insert indent-string "<" (symbol-name (xml-node-name tree)))
    
    ;;  output the attribute list
    (setq attlist (xml-node-attributes tree))
    (while attlist
      (insert " ")
      (insert (symbol-name (caar attlist)) "=\"" (cdar attlist) "\"")
      (setq attlist (cdr attlist)))
    
    (insert ">")
    
    (setq tree (xml-node-children tree))

    ;;  output the children
    (dolist (node tree)
      (cond
       ((listp node)
	(insert "\n")
	(xml-debug-print-internal node (concat indent-string "  ")))
       ((stringp node) (insert node))
       (t
	(error "Invalid XML tree"))))

    (insert "\n" indent-string
	    "</" (symbol-name (xml-node-name xml)) ">")))

(provide 'xml)

;;; xml.el ends here