/[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.10 by zsh, Tue Mar 5 21:44:01 2002 UTC revision 1.10.2.1 by miles, Fri Apr 4 06:20:12 2003 UTC
# Line 125  If PARSE-DTD is non-nil, the DTD is pars Line 125  If PARSE-DTD is non-nil, the DTD is pars
125            (set-buffer (get-file-buffer file))            (set-buffer (get-file-buffer file))
126            (setq keep (point)))            (setq keep (point)))
127        (find-file file))        (find-file file))
128        
129      (let ((xml (xml-parse-region (point-min)      (let ((xml (xml-parse-region (point-min)
130                                   (point-max)                                   (point-max)
131                                   (current-buffer)                                   (current-buffer)
# Line 184  Returns one of: Line 184  Returns one of:
184     ;; beginning of a document)     ;; beginning of a document)
185     ((looking-at "<\\?")     ((looking-at "<\\?")
186      (search-forward "?>" end)      (search-forward "?>" end)
187      (skip-chars-forward " \t\n")      (goto-char (- (re-search-forward "[^ \t\n\r]") 1))
188      (xml-parse-tag end))      (xml-parse-tag end))
189     ;;  Character data (CDATA) sections, in which no tag should be interpreted     ;;  Character data (CDATA) sections, in which no tag should be interpreted
190     ((looking-at "<!\\[CDATA\\[")     ((looking-at "<!\\[CDATA\\[")
# Line 198  Returns one of: Line 198  Returns one of:
198        (if parse-dtd        (if parse-dtd
199            (setq 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")        (goto-char (- (re-search-forward "[^ \t\n\r]") 1))
202        (if dtd        (if dtd
203            (cons dtd (xml-parse-tag end))            (cons dtd (xml-parse-tag end))
204          (xml-parse-tag end))))          (xml-parse-tag end))))
# Line 210  Returns one of: Line 210  Returns one of:
210     ((looking-at "</")     ((looking-at "</")
211      '())      '())
212     ;;  opening tag     ;;  opening tag
213     ((looking-at "<\\([^/> \t\n]+\\)")     ((looking-at "<\\([^/> \t\n\r]+\\)")
214      (goto-char (match-end 1))      (goto-char (match-end 1))
215      (let* ((case-fold-search nil) ;; XML is case-sensitive.      (let* ((case-fold-search nil) ;; XML is case-sensitive.
216             (node-name (match-string 1))             (node-name (match-string 1))
# Line 219  Returns one of: Line 219  Returns one of:
219             pos)             pos)
220    
221        ;; is this an empty element ?        ;; is this an empty element ?
222        (if (looking-at "/>")        (if (looking-at "/[ \t\n\r]*>")
223            (progn            (progn
224              (forward-char 2)              (forward-char 2)
225              (nreverse (cons '("") children)))              (nreverse (cons '("") children)))
# Line 230  Returns one of: Line 230  Returns one of:
230                (forward-char 1)                (forward-char 1)
231                ;;  Now check that we have the right end-tag. Note that this                ;;  Now check that we have the right end-tag. Note that this
232                ;;  one might contain spaces after the tag name                ;;  one might 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\r]*>")))
234                  (cond                  (cond
235                   ((looking-at "</")                   ((looking-at "</")
236                    (error (concat                    (error (concat
# Line 247  Returns one of: Line 247  Returns one of:
247                    (forward-char -1)                    (forward-char -1)
248                    (let ((string (buffer-substring-no-properties pos (point)))                    (let ((string (buffer-substring-no-properties pos (point)))
249                          (pos 0))                          (pos 0))
250                        
251                      ;; Clean up the string (no newline characters)                      ;; Clean up the string.  As per XML
252                      ;; Not done, since as per XML specifications, the XML processor                      ;; specifications, the XML processor should
253                      ;; should always pass the whole string to the application.                      ;; always pass the whole string to the
254                      ;;      (while (string-match "\\s +" string pos)                      ;; application.  But \r's should be replaced:
255                      ;;        (setq string (replace-match " " t t string))                      ;; http://www.w3.org/TR/2000/REC-xml-20001006#sec-line-ends
256                      ;;        (setq pos (1+ (match-beginning 0))))                      (while (string-match "\r\n?" string pos)
257                          (setq string (replace-match "\n" t t string))
258                          (setq pos (1+ (match-beginning 0))))
259    
260                      (setq string (xml-substitute-special string))                      (setq string (xml-substitute-special string))
261                      (setq children                      (setq children
# Line 280  Returns one of: Line 282  Returns one of:
282  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.
283  Leaves the point on the first non-blank character after the tag."  Leaves the point on the first non-blank character after the tag."
284    (let ((attlist ())    (let ((attlist ())
285          name)          start-pos name)
286      (skip-chars-forward " \t\n")      (goto-char (- (re-search-forward "[^ \t\n\r]") 1))
287      (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\r]*=[ \t\n\r]*")
288        (setq name (intern (match-string 1)))        (setq name (intern (match-string 1)))
289        (goto-char (match-end 0))        (goto-char (match-end 0))
290    
291          ;; See also: http://www.w3.org/TR/2000/REC-xml-20001006#AVNormalize
292    
293        ;; Do we have a string between quotes (or double-quotes),        ;; Do we have a string between quotes (or double-quotes),
294        ;;  or a simple word ?        ;;  or a simple word ?
295        (unless (looking-at "\"\\([^\"]*\\)\"")        (if (looking-at "\"\\([^\"]*\\)\"")
296          (unless (looking-at "'\\([^']*\\)'")            (setq start-pos (match-beginning 0))
297            (if (looking-at "'\\([^']*\\)'")
298                (setq start-pos (match-beginning 0))
299            (error "XML: Attribute values must be given between quotes")))            (error "XML: Attribute values must be given between quotes")))
300    
301        ;; Each attribute must be unique within a given element        ;; Each attribute must be unique within a given element
302        (if (assoc name attlist)        (if (assoc name attlist)
303            (error "XML: each attribute must be unique within an element"))            (error "XML: each attribute must be unique within an element"))
304          
305        (push (cons name (match-string-no-properties 1)) attlist)        ;; Multiple whitespace characters should be replaced with a single one
306        (goto-char (match-end 0))        ;; in the attributes
307        (skip-chars-forward " \t\n")        (let ((string (match-string-no-properties 1))
308                (pos 0))
309            (while (string-match "[ \t\n\r]+" string pos)
310              (setq string (replace-match " " t nil string))
311              (setq pos (1+ (match-beginning 0))))
312            (push (cons name (xml-substitute-special string)) attlist))
313    
314          (goto-char start-pos)
315          (if (looking-at "\"\\([^\"]*\\)\"")
316              (goto-char (match-end 0))
317            (if (looking-at "'\\([^']*\\)'")
318                (goto-char (match-end 0))))
319    
320          (goto-char (- (re-search-forward "[^ \t\n\r]") 1))
321        (if (> (point) end)        (if (> (point) end)
322            (error "XML: end of attribute list not found before end of region"))            (error "XML: end of attribute list not found before end of region")))
       )  
323      (nreverse attlist)))      (nreverse attlist)))
324    
325  ;;*******************************************************************  ;;*******************************************************************
# Line 318  The DTD must end before the position END Line 336  The DTD must end before the position END
336  The point must be just before the starting tag of the DTD.  The point must be just before the starting tag of the DTD.
337  This follows the rule [28] in the XML specifications."  This follows the rule [28] in the XML specifications."
338    (forward-char (length "<!DOCTYPE"))    (forward-char (length "<!DOCTYPE"))
339    (if (looking-at "[ \t\n]*>")    (if (looking-at "[ \t\n\r]*>")
340        (error "XML: invalid DTD (excepting name of the document)"))        (error "XML: invalid DTD (excepting name of the document)"))
341    (condition-case nil    (condition-case nil
342        (progn        (progn
343          (forward-word 1)  ;; name of the document          (forward-word 1)
344          (skip-chars-forward " \t\n")          (goto-char (- (re-search-forward "[ \t\n\r]") 1))
345            (goto-char (- (re-search-forward "[^ \t\n\r]") 1))
346          (if (looking-at "\\[")          (if (looking-at "\\[")
347              (re-search-forward "\\][ \t\n]*>" end)              (re-search-forward "\\][ \t\n\r]*>" end)
348            (search-forward ">" end)))            (search-forward ">" end)))
349      (error (error "XML: No end to the DTD"))))      (error (error "XML: No end to the DTD"))))
350    
# Line 333  This follows the rule [28] in the XML sp Line 352  This follows the rule [28] in the XML sp
352    "Parse the DTD that point is looking at.    "Parse the DTD that point is looking at.
353  The DTD must end before the position END in the current buffer."  The DTD must end before the position END in the current buffer."
354    (forward-char (length "<!DOCTYPE"))    (forward-char (length "<!DOCTYPE"))
355    (skip-chars-forward " \t\n")    (goto-char (- (re-search-forward "[^ \t\n\r]") 1))
356    (if (looking-at ">")    (if (looking-at ">")
357        (error "XML: invalid DTD (excepting name of the document)"))        (error "XML: invalid DTD (excepting name of the document)"))
358      
359    ;;  Get the name of the document    ;;  Get the name of the document
360    (looking-at "\\sw+")    (looking-at "\\sw+")
361    (let ((dtd (list (match-string-no-properties 0) 'dtd))    (let ((dtd (list (match-string-no-properties 0) 'dtd))
362          type element end-pos)          type element end-pos)
363      (goto-char (match-end 0))      (goto-char (match-end 0))
364    
365      (skip-chars-forward " \t\n")      (goto-char (- (re-search-forward "[^ \t\n\r]") 1))
366    
367      ;;  External DTDs => don't know how to handle them yet      ;;  External DTDs => don't know how to handle them yet
368      (if (looking-at "SYSTEM")      (if (looking-at "SYSTEM")
369          (error "XML: Don't know how to handle external DTDs"))          (error "XML: Don't know how to handle external DTDs"))
370        
371      (if (not (= (char-after) ?\[))      (if (not (= (char-after) ?\[))
372          (error "XML: Unknown declaration in the DTD"))          (error "XML: Unknown declaration in the DTD"))
373    
374      ;;  Parse the rest of the DTD      ;;  Parse the rest of the DTD
375      (forward-char 1)      (forward-char 1)
376      (while (and (not (looking-at "[ \t\n]*\\]"))      (while (and (not (looking-at "[ \t\n\r]*\\]"))
377                  (<= (point) end))                  (<= (point) end))
378        (cond        (cond
379    
380         ;;  Translation of rule [45] of XML specifications         ;;  Translation of rule [45] of XML specifications
381         ((looking-at         ((looking-at
382           "[\t \n]*<!ELEMENT[ \t\n]+\\([a-zA-Z0-9.%;]+\\)[ \t\n]+\\([^>]+\\)>")           "[ \t\n\r]*<!ELEMENT[ \t\n\r]+\\([a-zA-Z0-9.%;]+\\)[ \t\n\r]+\\([^>]+\\)>")
383    
384          (setq element (intern (match-string-no-properties 1))          (setq element (intern (match-string-no-properties 1))
385                type    (match-string-no-properties 2))                type    (match-string-no-properties 2))
386          (setq end-pos (match-end 0))          (setq end-pos (match-end 0))
387            
388          ;;  Translation of rule [46] of XML specifications          ;;  Translation of rule [46] of XML specifications
389          (cond          (cond
390           ((string-match "^EMPTY[ \t\n]*$" type)     ;; empty declaration           ((string-match "^EMPTY[ \t\n\r]*$" type)     ;; empty declaration
391            (setq type 'empty))            (setq type 'empty))
392           ((string-match "^ANY[ \t\n]*$" type)       ;; any type of contents           ((string-match "^ANY[ \t\n\r]*$" type)       ;; any type of contents
393            (setq type 'any))            (setq type 'any))
394           ((string-match "^(\\(.*\\))[ \t\n]*$" type) ;; children ([47])           ((string-match "^(\\(.*\\))[ \t\n\r]*$" type) ;; children ([47])
395            (setq type (xml-parse-elem-type (match-string-no-properties 1 type))))            (setq type (xml-parse-elem-type (match-string-no-properties 1 type))))
396           ((string-match "^%[^;]+;[ \t\n]*$" type)   ;; substitution           ((string-match "^%[^;]+;[ \t\n\r]*$" type)   ;; substitution
397            nil)            nil)
398           (t           (t
399            (error "XML: Invalid element type in the DTD")))            (error "XML: Invalid element type in the DTD")))
# Line 383  The DTD must end before the position END Line 402  The DTD must end before the position END
402          (if (assoc element dtd)          (if (assoc element dtd)
403              (error "XML: elements declaration must be unique in a DTD (<%s>)"              (error "XML: elements declaration must be unique in a DTD (<%s>)"
404                     (symbol-name element)))                     (symbol-name element)))
405            
406          ;;  Store the element in the DTD          ;;  Store the element in the DTD
407          (push (list element type) dtd)          (push (list element type) dtd)
408          (goto-char end-pos))          (goto-char end-pos))
# Line 416  The DTD must end before the position END Line 435  The DTD must end before the position END
435                                   (mapcar 'xml-parse-elem-type                                   (mapcar 'xml-parse-elem-type
436                                           (split-string elem ","))))                                           (split-string elem ","))))
437                )))                )))
438        (if (string-match "[ \t\n]*\\([^+*?]+\\)\\([+*?]?\\)" string)        (if (string-match "[ \t\n\r]*\\([^+*?]+\\)\\([+*?]?\\)" string)
439            (setq elem     (match-string 1 string)            (setq elem     (match-string 1 string)
440                  modifier (match-string 2 string))))                  modifier (match-string 2 string))))
441    
442      (if (and (stringp elem) (string= elem "#PCDATA"))      (if (and (stringp elem) (string= elem "#PCDATA"))
443          (setq elem 'pcdata))          (setq elem 'pcdata))
444        
445      (cond      (cond
446       ((string= modifier "+")       ((string= modifier "+")
447        (list '+ elem))        (list '+ elem))
448       ((string= modifier "*")       ((string= modifier "*")
449        (list '* elem))        (list '* elem))
450       ((string= modifier "?")       ((string= modifier "?")
451        (list '? elem))        (list '\? elem))
452       (t       (t
453        elem))))        elem))))
454    
455    ;;*******************************************************************
456    ;;**
457    ;;**  Converting code points to strings
458    ;;**
459    ;;*******************************************************************
460    
461    (defun xml-ucs-to-string (codepoint)
462      "Return a string representation of CODEPOINT.  If it can't be
463    converted, return '?'."
464      (cond ((boundp 'decode-char)
465             (char-to-string (decode-char 'ucs codepoint)))
466            ((and (< codepoint 128)
467                  (> codepoint 31))
468             (char-to-string codepoint))
469            (t "?"))) ; FIXME: There's gotta be a better way to
470                      ; designate an unknown character.
471    
472  ;;*******************************************************************  ;;*******************************************************************
473  ;;**  ;;**
# Line 442  The DTD must end before the position END Line 477  The DTD must end before the position END
477    
478  (defun xml-substitute-special (string)  (defun xml-substitute-special (string)
479    "Return STRING, after subsituting special XML sequences."    "Return STRING, after subsituting special XML sequences."
   (while (string-match "&amp;" string)  
     (setq string (replace-match "&"  t nil string)))  
480    (while (string-match "&lt;" string)    (while (string-match "&lt;" string)
481      (setq string (replace-match "<"  t nil string)))      (setq string (replace-match "<"  t nil string)))
482    (while (string-match "&gt;" string)    (while (string-match "&gt;" string)
# Line 452  The DTD must end before the position END Line 485  The DTD must end before the position END
485      (setq string (replace-match "'"  t nil string)))      (setq string (replace-match "'"  t nil string)))
486    (while (string-match "&quot;" string)    (while (string-match "&quot;" string)
487      (setq string (replace-match "\"" t nil string)))      (setq string (replace-match "\"" t nil string)))
488      (while (string-match "&#\\([0-9]+\\);" string)
489        (setq string (replace-match (xml-ucs-to-string
490                                     (string-to-number
491                                      (match-string-no-properties 1 string)))
492                                    t nil string)))
493      (while (string-match "&#x\\([0-9a-fA-F]+\\);" string)
494        (setq string (replace-match (xml-ucs-to-string
495                                     (string-to-number
496                                      (match-string-no-properties 1 string)
497                                      16))
498                                    t nil string)))
499    
500      ;; This goes last so it doesn't confuse the matches above.
501      (while (string-match "&amp;" string)
502        (setq string (replace-match "&"  t nil string)))
503    string)    string)
504    
505  ;;*******************************************************************  ;;*******************************************************************
# Line 471  The first line indented with INDENT-STRI Line 519  The first line indented with INDENT-STRI
519    (let ((tree xml)    (let ((tree xml)
520          attlist)          attlist)
521      (insert indent-string "<" (symbol-name (xml-node-name tree)))      (insert indent-string "<" (symbol-name (xml-node-name tree)))
522        
523      ;;  output the attribute list      ;;  output the attribute list
524      (setq attlist (xml-node-attributes tree))      (setq attlist (xml-node-attributes tree))
525      (while attlist      (while attlist
526        (insert " ")        (insert " ")
527        (insert (symbol-name (caar attlist)) "=\"" (cdar attlist) "\"")        (insert (symbol-name (caar attlist)) "=\"" (cdar attlist) "\"")
528        (setq attlist (cdr attlist)))        (setq attlist (cdr attlist)))
529        
530      (insert ">")      (insert ">")
531        
532      (setq tree (xml-node-children tree))      (setq tree (xml-node-children tree))
533    
534      ;;  output the children      ;;  output the children

Legend:
Removed from v.1.10  
changed lines
  Added in v.1.10.2.1

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