[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] Changes to emacs/lisp/xml.el
|
From: |
Stefan Monnier |
|
Subject: |
[Emacs-diffs] Changes to emacs/lisp/xml.el |
|
Date: |
Fri, 14 Dec 2001 17:12:30 -0500 |
Index: emacs/lisp/xml.el
diff -c emacs/lisp/xml.el:1.8 emacs/lisp/xml.el:1.9
*** emacs/lisp/xml.el:1.8 Thu Oct 18 16:22:53 2001
--- emacs/lisp/xml.el Fri Dec 14 17:12:30 2001
***************
*** 73,104 ****
;;**
;;*******************************************************************
! (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.
--- 73,102 ----
;;**
;;*******************************************************************
! (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.
***************
*** 155,164 ****
(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))))
--- 153,163 ----
(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))))
***************
*** 197,203 ****
((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
--- 196,202 ----
((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
***************
*** 206,241 ****
;; 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 "</")
--- 205,235 ----
;; 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 "</")
***************
*** 244,252 ****
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)))
--- 238,248 ----
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)))
***************
*** 256,273 ****
;; 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")
--- 252,272 ----
;; 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")
***************
*** 280,290 ****
"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),
--- 279,289 ----
"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),
***************
*** 297,311 ****
(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
! ))
;;*******************************************************************
;;**
--- 296,308 ----
(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)))
;;*******************************************************************
;;**
***************
*** 335,349 ****
(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")
--- 332,346 ----
(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")
***************
*** 367,382 ****
(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
--- 364,379 ----
(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
***************
*** 388,396 ****
(symbol-name element)))
;; Store the element in the DTD
! (set 'dtd (append dtd (list (list element type))))
! (goto-char end-pos)
! )
(t
--- 385,392 ----
(symbol-name element)))
;; Store the element in the DTD
! (push (list element type) dtd)
! (goto-char end-pos))
(t
***************
*** 400,407 ****
;; Skip the end of the DTD
(search-forward ">" end)
! dtd
! ))
(defun xml-parse-elem-type (string)
--- 396,402 ----
;; Skip the end of the DTD
(search-forward ">" end)
! (nreverse dtd)))
(defun xml-parse-elem-type (string)
***************
*** 413,423 ****
(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 ","))))
)))
--- 408,418 ----
(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 ","))))
)))
***************
*** 425,443 ****
(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))))
;;*******************************************************************
--- 420,437 ----
(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))))
;;*******************************************************************
***************
*** 449,463 ****
(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 ">" string)
! (set 'string (replace-match ">" t nil string)))
(while (string-match "'" string)
! (set 'string (replace-match "'" t nil string)))
(while (string-match """ string)
! (set 'string (replace-match "\"" t nil string)))
string)
;;*******************************************************************
--- 443,457 ----
(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 ">" string)
! (setq string (replace-match ">" t nil string)))
(while (string-match "'" string)
! (setq string (replace-match "'" t nil string)))
(while (string-match """ string)
! (setq string (replace-match "\"" t nil string)))
string)
;;*******************************************************************
***************
*** 468,517 ****
;;*******************************************************************
(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)
--- 462,500 ----
;;*******************************************************************
(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)
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] Changes to emacs/lisp/xml.el,
Stefan Monnier <=