/[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.23.2.2 by miles, Mon Jun 28 07:28:48 2004 UTC revision 1.23.2.3 by miles, Sun Jul 11 22:07:46 2004 UTC
# Line 84  Line 84 
84  ;;**  ;;**
85  ;;*******************************************************************  ;;*******************************************************************
86    
87    (defvar xml-entity-alist
88      '(("lt"   . "<")
89        ("gt"   . ">")
90        ("apos" . "'")
91        ("quot" . "\"")
92        ("amp"  . "&"))
93      "The defined entities.  Entities are added to this when the DTD is parsed.")
94    
95    (defvar xml-sub-parser nil
96      "Dynamically set this to a non-nil value if you want to parse an XML fragment.")
97    
98    (defvar xml-validating-parser nil
99      "Set to non-nil to get validity checking.")
100    
101  (defsubst xml-node-name (node)  (defsubst xml-node-name (node)
102    "Return the tag associated with NODE.    "Return the tag associated with NODE.
103  Without namespace-aware parsing, the tag is a symbol.  Without namespace-aware parsing, the tag is a symbol.
# Line 164  If PARSE-NS is non-nil, then QNAMES are Line 178  If PARSE-NS is non-nil, then QNAMES are
178          (kill-buffer (current-buffer)))          (kill-buffer (current-buffer)))
179        xml)))        xml)))
180    
181    
182    (let* ((start-chars (concat ":[:alpha:]_"))
183           (name-chars  (concat "-[:digit:]." start-chars))
184    ;;[3]           S          ::=          (#x20 | #x9 | #xD | #xA)+
185           (whitespace  "[ \t\n\r]"))
186    ;;[4] NameStartChar ::= ":" | [A-Z] | "_" | [a-z] | [#xC0-#xD6]
187    ;;                      | [#xD8-#xF6] | [#xF8-#x2FF] | [#x370-#x37D] | [#x37F-#x1FFF]
188    ;;                      | [#x200C-#x200D] | [#x2070-#x218F] | [#x2C00-#x2FEF] | [#x3001-#xD7FF]
189    ;;                      | [#xF900-#xFDCF] | [#xFDF0-#xFFFD] | [#x10000-#xEFFFF]
190      (defvar xml-name-start-char-re (concat "[" start-chars "]"))
191    ;;[4a] NameChar ::= NameStartChar | "-" | "." | [0-9] | #xB7 | [#x0300-#x036F] | [#x203F-#x2040]
192      (defvar xml-name-char-re       (concat "[" name-chars  "]"))
193    ;;[5] Name     ::= NameStartChar (NameChar)*
194      (defvar xml-name-re            (concat xml-name-start-char-re xml-name-char-re "*"))
195    ;;[6] Names    ::= Name (#x20 Name)*
196      (defvar xml-names-re           (concat xml-name-re "\\(?: " xml-name-re "\\)*"))
197    ;;[7] Nmtoken ::= (NameChar)+
198      (defvar xml-nmtoken-re         (concat xml-name-char-re "+"))
199    ;;[8] Nmtokens ::= Nmtoken (#x20 Nmtoken)*
200      (defvar xml-nmtokens-re        (concat xml-nmtoken-re "\\(?: " xml-name-re "\\)*"))
201    ;;[66] CharRef ::= '&#' [0-9]+ ';' | '&#x' [0-9a-fA-F]+ ';'
202      (defvar xml-char-ref-re        "\\(?:&#[0-9]+;\\|&#x[0-9a-fA-F]+;\\)")
203    ;;[68] EntityRef   ::= '&' Name ';'
204      (defvar xml-entity-ref         (concat "&" xml-name-re ";"))
205    ;;[69] PEReference ::= '%' Name ';'
206      (defvar xml-pe-reference-re    (concat "%" xml-name-re ";"))
207    ;;[67] Reference   ::= EntityRef | CharRef
208      (defvar xml-reference-re       (concat "\\(?:" xml-entity-ref "\\|" xml-char-ref-re "\\)"))
209    ;;[9] EntityValue ::= '"' ([^%&"] | PEReference | Reference)* '"'
210    ;;                 |  "'" ([^%&'] | PEReference | Reference)* "'"
211      (defvar xml-entity-value-re    (concat "\\(?:\"\\(?:[^%&\"]\\|" xml-pe-reference-re
212                                             "\\|" xml-reference-re "\\)*\"\\|'\\(?:[^%&']\\|"
213                                             xml-pe-reference-re "\\|" xml-reference-re "\\)*'\\)")))
214    ;;[75] ExternalID ::= 'SYSTEM' S SystemLiteral
215    ;;                 | 'PUBLIC' S PubidLiteral S SystemLiteral
216    ;;[76] NDataDecl ::=    S 'NDATA' S
217    ;;[73] EntityDef  ::= EntityValue| (ExternalID NDataDecl?)
218    ;;[71] GEDecl     ::= '<!ENTITY' S Name S EntityDef S? '>'
219    ;;[74] PEDef      ::= EntityValue | ExternalID
220    ;;[72] PEDecl     ::= '<!ENTITY' S '%' S Name S PEDef S? '>'
221    ;;[70] EntityDecl ::= GEDecl | PEDecl
222    
223  ;; Note that this is setup so that we can do whitespace-skipping with  ;; Note that this is setup so that we can do whitespace-skipping with
224  ;; `(skip-syntax-forward " ")', inter alia.  Previously this was slow  ;; `(skip-syntax-forward " ")', inter alia.  Previously this was slow
225  ;; compared with `re-search-forward', but that has been fixed.  Also  ;; compared with `re-search-forward', but that has been fixed.  Also
# Line 229  If PARSE-NS is non-nil, then QNAMES are Line 285  If PARSE-NS is non-nil, then QNAMES are
285                  (progn                  (progn
286                    (forward-char -1)                    (forward-char -1)
287                    (setq result (xml-parse-tag parse-dtd parse-ns))                    (setq result (xml-parse-tag parse-dtd parse-ns))
288                    (if (and xml result)                    (if (and xml result (not xml-sub-parser))
289                        ;;  translation of rule [1] of XML specifications                        ;;  translation of rule [1] of XML specifications
290                        (error "XML files can have only one toplevel tag")                        (error "XML: (Not Well-Formed) Only one root tag allowed")
291                      (cond                      (cond
292                       ((null result))                       ((null result))
293                       ((and (listp (car result))                       ((and (listp (car result))
# Line 265  specify that the name shouldn't be given Line 321  specify that the name shouldn't be given
321               ;; matching cons in xml-ns.  In which case we               ;; matching cons in xml-ns.  In which case we
322               (ns (or (cdr (assoc (if special "xmlns" prefix)               (ns (or (cdr (assoc (if special "xmlns" prefix)
323                                   xml-ns))                                   xml-ns))
324                       :)))                       "")))
325          (cons ns (if special "" lname)))          (cons ns (if special "" lname)))
326      (intern name)))      (intern name)))
327    
328    (defun xml-parse-fragment (&optional parse-dtd parse-ns)
329      "Parse xml-like fragments."
330      (let ((xml-sub-parser t)
331            children)
332        (while (not (eobp))
333          (let ((bit (xml-parse-tag
334                      parse-dtd parse-ns)))
335            (if children
336                (setq children (append (list bit) children))
337              (if (stringp bit)
338                  (setq children (list bit))
339                (setq children bit)))))
340        (reverse children)))
341    
342  (defun xml-parse-tag (&optional parse-dtd parse-ns)  (defun xml-parse-tag (&optional parse-dtd parse-ns)
343    "Parse the tag at point.    "Parse the tag at point.
344  If PARSE-DTD is non-nil, the DTD of the document, if any, is parsed and  If PARSE-DTD is non-nil, the DTD of the document, if any, is parsed and
# Line 278  Returns one of: Line 348  Returns one of:
348   - a list : the matching node   - a list : the matching node
349   - nil    : the point is not looking at a tag.   - nil    : the point is not looking at a tag.
350   - a pair : the first element is the DTD, the second is the node."   - a pair : the first element is the DTD, the second is the node."
351    (let ((xml-ns (if (consp parse-ns)    (let ((xml-validating-parser (or parse-dtd xml-validating-parser))
352            (xml-ns (if (consp parse-ns)
353                      parse-ns                      parse-ns
354                    (if parse-ns                    (if parse-ns
355                        (list                        (list
356                         ;; Default for empty prefix is no namespace                         ;; Default for empty prefix is no namespace
357                         (cons ""      :)                         (cons ""      "")
358                         ;; "xml" namespace                         ;; "xml" namespace
359                         (cons "xml"   :http://www.w3.org/XML/1998/namespace)                         (cons "xml"   "http://www.w3.org/XML/1998/namespace")
360                         ;; We need to seed the xmlns namespace                         ;; We need to seed the xmlns namespace
361                         (cons "xmlns" :http://www.w3.org/2000/xmlns/))))))                         (cons "xmlns" "http://www.w3.org/2000/xmlns/"))))))
362      (cond      (cond
363       ;; Processing instructions (like the <?xml version="1.0"?> tag at the       ;; Processing instructions (like the <?xml version="1.0"?> tag at the
364       ;; beginning of a document).       ;; beginning of a document).
# Line 299  Returns one of: Line 370  Returns one of:
370       ((looking-at "<!\\[CDATA\\[")       ((looking-at "<!\\[CDATA\\[")
371        (let ((pos (match-end 0)))        (let ((pos (match-end 0)))
372          (unless (search-forward "]]>" nil t)          (unless (search-forward "]]>" nil t)
373            (error "CDATA section does not end anywhere in the document"))            (error "XML: (Not Well Formed) CDATA section does not end anywhere in the document"))
374          (buffer-substring pos (match-beginning 0))))          (buffer-substring pos (match-beginning 0))))
375       ;;  DTD for the document       ;;  DTD for the document
376       ((looking-at "<!DOCTYPE")       ((looking-at "<!DOCTYPE")
377        (let (dtd)        (let ((dtd (xml-parse-dtd parse-ns)))
378          (if parse-dtd          (skip-syntax-forward " ")
379              (setq dtd (xml-parse-dtd))          (if xml-validating-parser
380            (xml-skip-dtd))              (cons dtd (xml-parse-tag nil xml-ns))
381        (skip-syntax-forward " ")            (xml-parse-tag nil xml-ns))))
       (if dtd  
           (cons dtd (xml-parse-tag nil xml-ns))  
         (xml-parse-tag nil xml-ns))))  
382       ;;  skip comments       ;;  skip comments
383       ((looking-at "<!--")       ((looking-at "<!--")
384        (search-forward "-->")        (search-forward "-->")
# Line 332  Returns one of: Line 400  Returns one of:
400          (when (consp xml-ns)          (when (consp xml-ns)
401            (dolist (attr attrs)            (dolist (attr attrs)
402              (when (and (consp (car attr))              (when (and (consp (car attr))
403                         (eq :http://www.w3.org/2000/xmlns/                         (equal "http://www.w3.org/2000/xmlns/"
404                             (caar attr)))                                (caar attr)))
405                (push (cons (cdar attr) (intern (concat ":" (cdr attr))))                (push (cons (cdar attr) (cdr attr))
406                      xml-ns))))                      xml-ns))))
407    
408          (setq children (list attrs (xml-maybe-do-ns node-name "" xml-ns)))          (setq children (list attrs (xml-maybe-do-ns node-name "" xml-ns)))
409    
410          ;; is this an empty element ?          ;; is this an empty element ?
411          (if (looking-at "/>")          (if (looking-at "/>")
         (progn  
           (forward-char 2)  
           (nreverse children))  
   
         ;; is this a valid start tag ?  
         (if (eq (char-after) ?>)  
412              (progn              (progn
413                (forward-char 1)                (forward-char 2)
               ;;  Now check that we have the right end-tag. Note that this  
               ;;  one might contain spaces after the tag name  
               (let ((end (concat "</" node-name "\\s-*>")))  
                 (while (not (looking-at end))  
                   (cond  
                    ((looking-at "</")  
                     (error "XML: Invalid end tag (expecting %s) at pos %d"  
                            node-name (point)))  
                    ((= (char-after) ?<)  
                     (let ((tag (xml-parse-tag nil xml-ns)))  
                       (when tag  
                         (push tag children))))  
                    (t  
                     (setq pos (point))  
                     (search-forward "<")  
                     (forward-char -1)  
                     (let ((string (buffer-substring pos (point)))  
                           (pos 0))  
   
                       ;; Clean up the string.  As per XML  
                       ;; specifications, the XML processor should  
                       ;; always pass the whole string to the  
                       ;; application.  But \r's should be replaced:  
                       ;; http://www.w3.org/TR/2000/REC-xml-20001006#sec-line-ends  
                       (while (string-match "\r\n?" string pos)  
                         (setq string (replace-match "\n" 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))  
414                (nreverse children))                (nreverse children))
415            ;;  This was an invalid start tag  
416            (error "XML: Invalid attribute list")))))            ;; is this a valid start tag ?
417       (t ;; This is not a tag.            (if (eq (char-after) ?>)
418        (error "XML: Invalid character")))))                (progn
419                    (forward-char 1)
420                    ;;  Now check that we have the right end-tag. Note that this
421                    ;;  one might contain spaces after the tag name
422                    (let ((end (concat "</" node-name "\\s-*>")))
423                      (while (not (looking-at end))
424                        (cond
425                         ((looking-at "</")
426                          (error "XML: (Not Well-Formed) Invalid end tag (expecting %s) at pos %d"
427                                 node-name (point)))
428                         ((= (char-after) ?<)
429                          (let ((tag (xml-parse-tag nil xml-ns)))
430                            (when tag
431                              (push tag children))))
432                         (t
433                          (let ((expansion (xml-parse-string)))
434                            (setq children
435                                  (if (stringp expansion)
436                                      (if (stringp (car children))
437                                          ;; The two strings were separated by a comment.
438                                          (setq children (append (concat (car children) expansion)
439                                                                 (cdr children)))
440                                        (setq children (append (list expansion) children)))
441                                    (setq children (append expansion children))))))))
442    
443                      (goto-char (match-end 0))
444                      (nreverse children)))
445                ;;  This was an invalid start tag (Expected ">", but didn't see it.)
446                (error "XML: (Well-Formed) Couldn't parse tag: %s"
447                       (buffer-substring (- (point) 10) (+ (point) 1)))))))
448         (t ;; (Not one of PI, CDATA, Comment, End tag, or Start tag)
449          (unless xml-sub-parser            ; Usually, we error out.
450            (error "XML: (Well-Formed) Invalid character"))
451    
452          ;; However, if we're parsing incrementally, then we need to deal
453          ;; with stray CDATA.
454          (xml-parse-string)))))
455    
456    (defun xml-parse-string ()
457      "Parse the next whatever.  Could be a string, or an element."
458        (let* ((pos (point))
459               (string (progn (if (search-forward "<" nil t)
460                                  (forward-char -1)
461                                (goto-char (point-max)))
462                              (buffer-substring pos (point)))))
463          ;; Clean up the string.  As per XML specifications, the XML
464          ;; processor should always pass the whole string to the
465          ;; application.  But \r's should be replaced:
466          ;; http://www.w3.org/TR/2000/REC-xml-20001006#sec-line-ends
467          (setq pos 0)
468          (while (string-match "\r\n?" string pos)
469            (setq string (replace-match "\n" t t string))
470            (setq pos (1+ (match-beginning 0))))
471    
472          (xml-substitute-special string)))
473    
474  (defun xml-parse-attlist (&optional xml-ns)  (defun xml-parse-attlist (&optional xml-ns)
475    "Return the attribute-list after point.    "Return the attribute-list after point.
# Line 412  Leave point at the first non-blank chara Line 491  Leave point at the first non-blank chara
491            (setq end-pos (match-end 0))            (setq end-pos (match-end 0))
492          (if (looking-at "'\\([^']*\\)'")          (if (looking-at "'\\([^']*\\)'")
493              (setq end-pos (match-end 0))              (setq end-pos (match-end 0))
494            (error "XML: Attribute values must be given between quotes")))            (error "XML: (Not Well-Formed) Attribute values must be given between quotes")))
495    
496        ;; Each attribute must be unique within a given element        ;; Each attribute must be unique within a given element
497        (if (assoc name attlist)        (if (assoc name attlist)
498            (error "XML: each attribute must be unique within an element"))            (error "XML: (Not Well-Formed) Each attribute must be unique within an element"))
499    
500        ;; Multiple whitespace characters should be replaced with a single one        ;; Multiple whitespace characters should be replaced with a single one
501        ;; in the attributes        ;; in the attributes
502        (let ((string (match-string 1))        (let ((string (match-string 1))
503              (pos 0))              (pos 0))
504          (replace-regexp-in-string "\\s-\\{2,\\}" " " string)          (replace-regexp-in-string "\\s-\\{2,\\}" " " string)
505          (push (cons name (xml-substitute-special string)) attlist))          (let ((expansion (xml-substitute-special string)))
506              (unless (stringp expansion)
507                ; We say this is the constraint.  It is acctually that
508                ; external entities nor "<" can be in an attribute value.
509                (error "XML: (Not Well-Formed) Entities in attributes cannot expand into elements"))
510              (push (cons name expansion) attlist)))
511    
512        (goto-char end-pos)        (goto-char end-pos)
513        (skip-syntax-forward " "))        (skip-syntax-forward " "))
# Line 442  Leave point at the first non-blank chara Line 526  Leave point at the first non-blank chara
526  (defun xml-skip-dtd ()  (defun xml-skip-dtd ()
527    "Skip the DTD at point.    "Skip the DTD at point.
528  This follows the rule [28] in the XML specifications."  This follows the rule [28] in the XML specifications."
529    (forward-char (length "<!DOCTYPE"))    (let ((xml-validating-parser nil))
530    (if (looking-at "\\s-*>")      (xml-parse-dtd)))
       (error "XML: invalid DTD (excepting name of the document)"))  
   (condition-case nil  
       (progn  
         (forward-sexp)  
         (skip-syntax-forward " ")  
         (if (looking-at "\\[")  
             (re-search-forward "]\\s-*>")  
           (search-forward ">")))  
     (error (error "XML: No end to the DTD"))))  
531    
532  (defun xml-parse-dtd ()  (defun xml-parse-dtd (&optional parse-ns)
533    "Parse the DTD at point."    "Parse the DTD at point."
534    (forward-char (eval-when-compile (length "<!DOCTYPE")))    (forward-char (eval-when-compile (length "<!DOCTYPE")))
535    (skip-syntax-forward " ")    (skip-syntax-forward " ")
536    (if (looking-at ">")    (if (and (looking-at ">")
537        (error "XML: invalid DTD (excepting name of the document)"))             xml-validating-parser)
538          (error "XML: (Validity) Invalid DTD (expecting name of the document)"))
539    
540    ;;  Get the name of the document    ;;  Get the name of the document
541    (looking-at xml-name-regexp)    (looking-at xml-name-regexp)
# Line 477  This follows the rule [28] in the XML sp Line 553  This follows the rule [28] in the XML sp
553                         (re-search-forward                         (re-search-forward
554                          "\\='\\([[:space:][:alnum:]-()+,./:=?;!*#@$_%]*\\)'"                          "\\='\\([[:space:][:alnum:]-()+,./:=?;!*#@$_%]*\\)'"
555                          nil t))                          nil t))
556               (error "XML: missing public id"))               (error "XML: Missing Public ID"))
557             (let ((pubid (match-string 1)))             (let ((pubid (match-string 1)))
558                 (skip-syntax-forward " ")
559               (unless (or (re-search-forward "\\='\\([^']*\\)'" nil t)               (unless (or (re-search-forward "\\='\\([^']*\\)'" nil t)
560                           (re-search-forward "\\=\"\\([^\"]*\\)\"" nil t))                           (re-search-forward "\\=\"\\([^\"]*\\)\"" nil t))
561                 (error "XML: missing system id"))                 (error "XML: Missing System ID"))
562               (push (list pubid (match-string 1) 'public) dtd)))               (push (list pubid (match-string 1) 'public) dtd)))
563            ((looking-at "SYSTEM\\s-+")            ((looking-at "SYSTEM\\s-+")
564             (goto-char (match-end 0))             (goto-char (match-end 0))
565             (unless (or (re-search-forward "\\='\\([^']*\\)'" nil t)             (unless (or (re-search-forward "\\='\\([^']*\\)'" nil t)
566                         (re-search-forward "\\=\"\\([^\"]*\\)\"" nil t))                         (re-search-forward "\\=\"\\([^\"]*\\)\"" nil t))
567               (error "XML: missing system id"))               (error "XML: Missing System ID"))
568             (push (list (match-string 1) 'system) dtd)))             (push (list (match-string 1) 'system) dtd)))
569      (skip-syntax-forward " ")      (skip-syntax-forward " ")
570      (if (eq ?> (char-after))      (if (eq ?> (char-after))
571          (forward-char)          (forward-char)
       (skip-syntax-forward " ")  
572        (if (not (eq (char-after) ?\[))        (if (not (eq (char-after) ?\[))
573            (error "XML: bad DTD")            (error "XML: Bad DTD")
574          (forward-char)          (forward-char)
575          ;;  Parse the rest of the DTD          ;;  Parse the rest of the DTD
576          ;;  Fixme: Deal with ENTITY, ATTLIST, NOTATION, PIs.          ;;  Fixme: Deal with ATTLIST, NOTATION, PIs.
577          (while (not (looking-at "\\s-*\\]"))          (while (not (looking-at "\\s-*\\]"))
578            (skip-syntax-forward " ")            (skip-syntax-forward " ")
579            (cond            (cond
# Line 521  This follows the rule [28] in the XML sp Line 597  This follows the rule [28] in the XML sp
597               ((string-match "^%[^;]+;[ \t\n\r]*$" type) ;; substitution               ((string-match "^%[^;]+;[ \t\n\r]*$" type) ;; substitution
598                nil)                nil)
599               (t               (t
600                (error "XML: Invalid element type in the DTD")))                (if xml-validating-parser
601                      error "XML: (Validity) Invalid element type in the DTD")))
602    
603              ;;  rule [45]: the element declaration must be unique              ;;  rule [45]: the element declaration must be unique
604              (if (assoc element dtd)              (if (and (assoc element dtd)
605                  (error "XML: element declarations must be unique in a DTD (<%s>)"                       xml-validating-parser)
606                    (error "XML: (Validity) Element declarations must be unique in a DTD (<%s>)"
607                         element))                         element))
608    
609              ;;  Store the element in the DTD              ;;  Store the element in the DTD
# Line 533  This follows the rule [28] in the XML sp Line 611  This follows the rule [28] in the XML sp
611              (goto-char end-pos))              (goto-char end-pos))
612             ((looking-at "<!--")             ((looking-at "<!--")
613              (search-forward "-->"))              (search-forward "-->"))
614               ((looking-at (concat "<!ENTITY[ \t\n\r]*\\(" xml-name-re
615                                    "\\)[ \t\n\r]*\\(" xml-entity-value-re
616                                    "\\)[ \t\n\r]*>"))
617                (let ((name  (buffer-substring (nth 2 (match-data))
618                                               (nth 3 (match-data))))
619                      (value (buffer-substring (+ (nth 4 (match-data)) 1)
620                                               (- (nth 5 (match-data)) 1))))
621                  (goto-char (nth 1 (match-data)))
622                  (setq xml-entity-alist
623                        (append xml-entity-alist
624                                (list (cons name
625                                            (with-temp-buffer
626                                              (insert value)
627                                              (goto-char (point-min))
628                                              (xml-parse-fragment
629                                               xml-validating-parser
630                                               parse-ns))))))))
631               ((or (looking-at (concat "<!ENTITY[ \t\n\r]+\\(" xml-name-re
632                                        "\\)[ \t\n\r]+SYSTEM[ \t\n\r]+"
633                                        "\\(\"[^\"]*\"\\|'[^']*'\\)[ \t\n\r]*>"))
634                    (looking-at (concat "<!ENTITY[ \t\n\r]+\\(" xml-name-re
635                                        "\\)[ \t\n\r]+PUBLIC[ \t\n\r]+"
636                                        "\"[- \r\na-zA-Z0-9'()+,./:=?;!*#@$_%]*\""
637                                        "\\|'[- \r\na-zA-Z0-9()+,./:=?;!*#@$_%]*'"
638                                        "[ \t\n\r]+\\(\"[^\"]*\"\\|'[^']*'\\)"
639                                        "[ \t\n\r]*>")))
640                (let ((name  (buffer-substring (nth 2 (match-data))
641                                               (nth 3 (match-data))))
642                      (file  (buffer-substring (+ (nth 4 (match-data)) 1)
643                                               (- (nth 5 (match-data)) 1))))
644                  (goto-char (nth 1 (match-data)))
645                  (setq xml-entity-alist
646                        (append xml-entity-alist
647                                (list (cons name (with-temp-buffer
648                                                   (insert-file-contents file)
649                                                   (goto-char (point-min))
650                                                   (xml-parse-fragment
651                                                    xml-validating-parser
652                                                    parse-ns))))))))
653             (t             (t
654              (error "XML: Invalid DTD item")))              (error "XML: (Validity) Invalid DTD item")))))
655          (if (looking-at "\\s-*]>")
656            ;;  Skip the end of the DTD            (goto-char (nth 1 (match-data)))))
           (search-forward ">"))))  
657      (nreverse dtd)))      (nreverse dtd)))
658    
659  (defun xml-parse-elem-type (string)  (defun xml-parse-elem-type (string)
# Line 580  This follows the rule [28] in the XML sp Line 695  This follows the rule [28] in the XML sp
695  ;;**  ;;**
696  ;;*******************************************************************  ;;*******************************************************************
697    
 (eval-when-compile  
   (defvar str))                ; dynamic from replace-regexp-in-string  
   
 ;; Fixme:  Take declared entities from the DTD when they're available.  
 (defun xml-substitute-entity (match)  
   "Subroutine of `xml-substitute-special'."  
   (save-match-data  
     (let ((match1 (match-string 1 str)))  
       (cond ((string= match1 "lt") "<")  
             ((string= match1 "gt") ">")  
             ((string= match1 "apos") "'")  
             ((string= match1 "quot") "\"")  
             ((string= match1 "amp") "&")  
             ((and (string-match "#\\([0-9]+\\)" match1)  
                   (let ((c (decode-char  
                             'ucs  
                             (string-to-number (match-string 1 match1)))))  
                     (if c (string c))))) ; else unrepresentable  
             ((and (string-match "#x\\([[:xdigit:]]+\\)" match1)  
                   (let ((c (decode-char  
                             'ucs  
                             (string-to-number (match-string 1 match1) 16))))  
                     (if c (string c)))))  
             ;; Default to asis.  Arguably, unrepresentable code points  
             ;; might be best replaced with U+FFFD.  
             (t match)))))  
   
698  (defun xml-substitute-special (string)  (defun xml-substitute-special (string)
699    "Return STRING, after subsituting entity references."    "Return STRING, after subsituting entity references."
700    ;; This originally made repeated passes through the string from the    ;; This originally made repeated passes through the string from the
701    ;; beginning, which isn't correct, since then either "&amp;amp;" or    ;; beginning, which isn't correct, since then either "&amp;amp;" or
702    ;; "&#38;amp;" won't DTRT.    ;; "&#38;amp;" won't DTRT.
   (replace-regexp-in-string "&\\([^;]+\\);"  
                             #'xml-substitute-entity string t t))  
703    
704      (let ((point 0)
705            children end-point)
706        (while (string-match "&\\([^;]+\\);" string point)
707          (setq end-point (match-end 0))
708          (let* ((this-part (match-string 1 string))
709                 (prev-part (substring string point (match-beginning 0)))
710                 (entity (assoc this-part xml-entity-alist))
711                 (expansion
712                  (cond ((string-match "#\\([0-9]+\\)" this-part)
713                         (let ((c (decode-char
714                                   'ucs
715                                   (string-to-number (match-string 1 this-part)))))
716                           (if c (string c))))
717                        ((string-match "#x\\([[:xdigit:]]+\\)" this-part)
718                         (let ((c (decode-char
719                                   'ucs
720                                   (string-to-number (match-string 1 this-part) 16))))
721                           (if c (string c))))
722                        (entity
723                         (cdr entity))
724                        (t
725                         (if xml-validating-parser
726                             (error "XML: (Validity) Undefined entity `%s'"
727                                    (match-string 1 this-part)))))))
728    
729            (cond ((null children)
730                   (if (stringp expansion)
731                       (setq children (concat prev-part expansion))
732                     (if (stringp (car (last expansion)))
733                         (progn
734                                (setq children
735                                      (list (concat prev-part (car expansion))
736                                            (cdr expansion))))
737                       (setq children (append expansion prev-part)))))
738                  ((stringp children)
739                   (if (stringp expansion)
740                       (setq children (concat children prev-part expansion))
741                     (setq children (list expansion (concat prev-part children)))))
742                  ((and (stringp expansion)
743                        (stringp (car children)))
744                   (setcar children (concat prev-part expansion (car children))))
745                  ((stringp expansion)
746                   (setq children (append (concat prev-part expansion)
747                                          children)))
748                  ((stringp (car children))
749                   (setcar children (concat (car children) prev-part))
750                   (setq children (append expansion children)))
751                  (t
752                   (setq children (list expansion
753                                        prev-part
754                                        children))))
755            (setq point end-point)))
756        (cond ((stringp children)
757               (concat children (substring string point)))
758              ((stringp (car (last children)))
759               (concat (car children) (substring string point)))
760              ((null children)
761               string)
762              (t
763               (nreverse children)))))
764  ;;*******************************************************************  ;;*******************************************************************
765  ;;**  ;;**
766  ;;**  Printing a tree.  ;;**  Printing a tree.

Legend:
Removed from v.1.23.2.2  
changed lines
  Added in v.1.23.2.3

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