Function: xml-parse-dtd

xml-parse-dtd is a byte-compiled function defined in xml.el.gz.

Signature

(xml-parse-dtd &optional PARSE-NS)

Documentation

Parse the DTD at point.

Source Code

;; Defined in /usr/src/emacs/lisp/xml.el.gz
(defun xml-parse-dtd (&optional _parse-ns)
  "Parse the DTD at point."
  (forward-char (eval-when-compile (length "<!DOCTYPE")))
  (skip-syntax-forward " ")
  (if (and (looking-at-p ">")
	   xml-validating-parser)
      (error "XML: (Validity) Invalid DTD (expecting name of the document)"))

  ;;  Get the name of the document
  (looking-at xml-name-re)
  (let ((dtd (list (match-string-no-properties 0) 'dtd))
	(xml-parameter-entity-alist xml-parameter-entity-alist)
	next-parameter-entity)
    (goto-char (match-end 0))
    (skip-syntax-forward " ")

    ;; External subset (XML [75])
    (cond ((looking-at "PUBLIC\\s-+")
	   (goto-char (match-end 0))
	   (unless (or (re-search-forward
			"\\=\"\\([[:space:][:alnum:]'()+,./:=?;!*#@$_%-]*\\)\""
			nil t)
		       (re-search-forward
			"\\='\\([[:space:][:alnum:]()+,./:=?;!*#@$_%-]*\\)'"
			nil t))
	     (error "XML: Missing Public ID"))
	   (let ((pubid (match-string-no-properties 1)))
	     (skip-syntax-forward " ")
	     (unless (or (re-search-forward "\\='\\([^']*\\)'" nil t)
			 (re-search-forward "\\=\"\\([^\"]*\\)\"" nil t))
	       (error "XML: Missing System ID"))
	     (push (list pubid (match-string-no-properties 1) 'public) dtd)))
	  ((looking-at "SYSTEM\\s-+")
	   (goto-char (match-end 0))
	   (unless (or (re-search-forward "\\='\\([^']*\\)'" nil t)
		       (re-search-forward "\\=\"\\([^\"]*\\)\"" nil t))
	     (error "XML: Missing System ID"))
	   (push (list (match-string-no-properties 1) 'system) dtd)))
    (skip-syntax-forward " ")

    (if (eq (char-after) ?>)

	;; No internal subset
	(forward-char)

      ;; Internal subset (XML [28b])
      (unless (eq (char-after) ?\[)
	(error "XML: Bad DTD"))
      (forward-char)

      ;; [2.8]: "markup declarations may be made up in whole or in
      ;; part of the replacement text of parameter entities."

      ;; Since parameter entities are valid only within the DTD, we
      ;; first search for the position of the next possible parameter
      ;; entity.  Then, search for the next DTD element; if it ends
      ;; before the next parameter entity, expand the parameter entity
      ;; and try again.
      (setq next-parameter-entity
	    (save-excursion
	      (if (re-search-forward xml-pe-reference-re nil t)
		  (match-beginning 0))))

      ;; Parse the rest of the DTD
      ;; Fixme: Deal with NOTATION, PIs.
      (while (not (looking-at-p "\\s-*\\]"))
	(skip-syntax-forward " ")
	(cond
	 ((eobp)
	  (error "XML: (Well-Formed) End of document while reading DTD"))
	 ;; Element declaration [45]:
	 ((and (looking-at (eval-when-compile
			     (concat "<!ELEMENT\\s-+\\(" xml-name-re
				     "\\)\\s-+\\([^>]+\\)>")))
	       (or (null next-parameter-entity)
		   (<= (match-end 0) next-parameter-entity)))
	  (let ((element (match-string-no-properties 1))
		(type    (match-string-no-properties 2))
		(end-pos (match-end 0)))
	    ;; Translation of rule [46] of XML specifications
	    (cond
	     ((string-match-p "\\`EMPTY\\s-*\\'" type)  ; empty declaration
	      (setq type 'empty))
	     ((string-match-p "\\`ANY\\s-*$" type)      ; any type of contents
	      (setq type 'any))
	     ((string-match "\\`(\\(.*\\))\\s-*\\'" type) ; children ([47])
	      (setq type (xml-parse-elem-type
			  (match-string-no-properties 1 type))))
	     ((string-match-p "^%[^;]+;[ \t\n\r]*\\'" type) ; substitution
	      nil)
	     (xml-validating-parser
	      (error "XML: (Validity) Invalid element type in the DTD")))

	    ;; rule [45]: the element declaration must be unique
	    (and (assoc element dtd)
		 xml-validating-parser
		 (error "XML: (Validity) DTD element declarations must be unique (<%s>)"
			element))

	    ;;  Store the element in the DTD
	    (push (list element type) dtd)
	    (goto-char end-pos)))

	 ;; Attribute-list declaration [52] (currently unsupported):
	 ((and (looking-at (eval-when-compile
			     (concat "<!ATTLIST[ \t\n\r]*\\(" xml-name-re
				     "\\)[ \t\n\r]*\\(" xml-att-def-re
				     "\\)*[ \t\n\r]*>")))
	       (or (null next-parameter-entity)
		   (<= (match-end 0) next-parameter-entity)))
	  (goto-char (match-end 0)))

	 ;; Comments (skip to end, ignoring parameter entity):
	 ((looking-at-p "<!--")
	  (search-forward "-->")
	  (and next-parameter-entity
	       (> (point) next-parameter-entity)
	       (setq next-parameter-entity
		     (save-excursion
		       (if (re-search-forward xml-pe-reference-re nil t)
			   (match-beginning 0))))))

	 ;; Internal entity declarations:
	 ((and (looking-at (eval-when-compile
			     (concat "<!ENTITY[ \t\n\r]+\\(%[ \t\n\r]+\\)?\\("
				     xml-name-re "\\)[ \t\n\r]*\\("
				     xml-entity-value-re "\\)[ \t\n\r]*>")))
	       (or (null next-parameter-entity)
		   (<= (match-end 0) next-parameter-entity)))
	  (let* ((name (prog1 (match-string-no-properties 2)
			 (goto-char (match-end 0))))
		 (alist (if (match-string 1)
			    'xml-parameter-entity-alist
			  'xml-entity-alist))
		 ;; Retrieve the deplacement text:
		 (value (xml--entity-replacement-text
			 ;; Entity value, sans quotation marks:
			 (substring (match-string-no-properties 3) 1 -1))))
	    ;; If the same entity is declared more than once, the
	    ;; first declaration is binding.
	    (unless (assoc name (symbol-value alist))
	      (set alist (cons (cons name value) (symbol-value alist))))))

	 ;; External entity declarations (currently unsupported):
	 ((and (or (looking-at (eval-when-compile
				 (concat "<!ENTITY[ \t\n\r]+\\(%[ \t\n\r]+\\)?\\("
					 xml-name-re "\\)[ \t\n\r]+SYSTEM[ \t\n\r]+"
					 "\\(\"[^\"]*\"\\|'[^']*'\\)[ \t\n\r]*>")))
		   (looking-at (eval-when-compile
				 (concat "<!ENTITY[ \t\n\r]+\\(%[ \t\n\r]+\\)?\\("
					 xml-name-re "\\)[ \t\n\r]+PUBLIC[ \t\n\r]+"
					 "\"[- \r\na-zA-Z0-9'()+,./:=?;!*#@$_%]*\""
					 "\\|'[- \r\na-zA-Z0-9()+,./:=?;!*#@$_%]*'"
					 "[ \t\n\r]+\\(\"[^\"]*\"\\|'[^']*'\\)"
					 "[ \t\n\r]*>"))))
	       (or (null next-parameter-entity)
		   (<= (match-end 0) next-parameter-entity)))
	  (goto-char (match-end 0)))

	 ;; If a parameter entity is in the way, expand it.
	 (next-parameter-entity
	  (save-excursion
	    (goto-char next-parameter-entity)
	    (unless (looking-at xml-pe-reference-re)
	      (error "XML: Internal error"))
	    (let* ((entity (match-string 1))
		   (elt    (assoc entity xml-parameter-entity-alist)))
	      (if elt
		  (progn
		    (replace-match (cdr elt) t t)
		    ;; The replacement can itself be a parameter entity.
		    (goto-char next-parameter-entity))
		(goto-char (match-end 0))))
	    (setq next-parameter-entity
		  (if (re-search-forward xml-pe-reference-re nil t)
		      (match-beginning 0)))))

	 ;; Anything else is garbage (ignored if not validating).
	 (xml-validating-parser
	  (error "XML: (Validity) Invalid DTD item"))
	 (t
	  (skip-chars-forward "^]"))))

      (if (looking-at "\\s-*]>")
	  (goto-char (match-end 0))))
    (nreverse dtd)))