[Emacs-diffs] Changes to lisp/nxml/rng-parse.el

[Mark A. Hershberger]

CVSROOT:        /sources/emacs
Module name:    emacs
Changes by:     Mark A. Hershberger <hexmode>   07/11/23 06:58:00

Index: lisp/nxml/rng-parse.el
===================================================================
RCS file: lisp/nxml/rng-parse.el
diff -N lisp/nxml/rng-parse.el
--- /dev/null   1 Jan 1970 00:00:00 -0000
+++ lisp/nxml/rng-parse.el      23 Nov 2007 06:57:51 -0000      1.1
@@ -0,0 +1,104 @@
+;;; rng-parse.el --- parse an XML file and validate it against a schema
+
+;; Copyright (C) 2003 Free Software Foundation, Inc.
+
+;; Author: James Clark
+;; Keywords: XML, RelaxNG
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2 of
+;; the License, or (at your option) any later version.
+
+;; This program is distributed in the hope that it will be
+;; useful, but WITHOUT ANY WARRANTY; without even the implied
+;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.  See the GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public
+;; License along with this program; if not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
+;; MA 02111-1307 USA
+
+;;; Commentary:
+
+;; This combines the validation machinery in rng-match.el with the
+;; parser in nxml-parse.el by using the `nxml-validate-function' hook.
+
+;;; Code:
+
+(require 'nxml-parse)
+(require 'rng-match)
+(require 'rng-dt)
+
+(defvar rng-parse-prev-was-start-tag nil)
+
+(defun rng-parse-validate-file (schema file)
+  "Parse and validate the XML document in FILE and return it as a list.
+The returned list has the same form as that returned by
+`nxml-parse-file'.  SCHEMA is a list representing the schema to use
+for validation, such as returned by the function `rng-c-load-schema'.
+If the XML document is invalid with respect to schema, an error will
+be signaled in the same way as when it is not well-formed."
+  (save-excursion
+    (set-buffer (nxml-parse-find-file file))
+    (unwind-protect
+       (let ((nxml-parse-file-name file)
+             (nxml-validate-function 'rng-parse-do-validate)
+             (rng-dt-namespace-context-getter '(nxml-ns-get-context))
+             rng-parse-prev-was-start-tag)
+         ;; We don't simply call nxml-parse-file, because
+         ;; we want to do rng-match-with-schema in the same
+         ;; buffer in which we will call the other rng-match-* functions.
+         (rng-match-with-schema schema
+           (nxml-parse-instance)))
+      (kill-buffer nil))))
+
+(defun rng-parse-do-validate (text start-tag)
+  (cond ((and (let ((tem rng-parse-prev-was-start-tag))
+               (setq rng-parse-prev-was-start-tag (and start-tag t))
+               tem)
+             (not start-tag)
+             (rng-match-text-typed-p))
+        (unless (rng-match-element-value (or text ""))
+          (cons "Invalid data" (and text 'text))))
+       ((and text
+             (not (rng-blank-p text))
+             (not (rng-match-mixed-text)))
+        (cons "Text not allowed" 'text))
+       ((not start-tag)
+        (unless (rng-match-end-tag)
+          (cons "Missing elements" nil)))
+       ((not (rng-match-start-tag-open
+              (rng-parse-to-match-name (car start-tag))))
+        (cons "Element not allowed" nil))
+       (t
+        (let ((atts (cadr start-tag))
+              (i 0)
+              att err)
+          (while (and atts (not err))
+            (setq att (car atts))
+            (when (not (and (consp (car att))
+                            (eq (caar att) nxml-xmlns-namespace-uri)))
+              (setq err
+                    (cond ((not (rng-match-attribute-name
+                                 (rng-parse-to-match-name (car att))))
+                           (cons "Attribute not allowed"
+                                 (cons 'attribute-name i)))
+                          ((not (rng-match-attribute-value (cdr att)))
+                           (cons "Invalid attribute value"
+                                 (cons 'attribute-value i))))))
+            (setq atts (cdr atts))
+            (setq i (1+ i)))
+          (or err
+              (unless (rng-match-start-tag-close)
+                (cons "Missing attributes" 'tag-close)))))))
+
+(defun rng-parse-to-match-name (name)
+  (if (consp name)
+      name
+    (cons nil name)))
+
+(provide 'rng-parse)
+
+;;; rng-parse.el ends here