[Emacs-diffs] Changes to lisp/nxml/rng-loc.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-loc.el
===================================================================
RCS file: lisp/nxml/rng-loc.el
diff -N lisp/nxml/rng-loc.el
--- /dev/null   1 Jan 1970 00:00:00 -0000
+++ lisp/nxml/rng-loc.el        23 Nov 2007 06:57:51 -0000      1.1
@@ -0,0 +1,548 @@
+;;; rng-loc.el --- locate the schema to use for validation
+
+;; 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:
+
+;;; Code:
+
+(require 'nxml-util)
+(require 'nxml-parse)
+(require 'rng-parse)
+(require 'rng-uri)
+(require 'rng-util)
+(require 'xmltok)
+
+(defvar rng-current-schema-file-name nil
+  "Filename of schema being used for current buffer.
+Nil if using a vacuous schema.")
+(make-variable-buffer-local 'rng-current-schema-file-name)
+
+(defvar rng-schema-locating-files-default nil
+  "Default value for variable `rng-schema-locating-files'.")
+
+(defvar rng-schema-locating-file-schema-file nil
+  "File containing schema for schema locating files.")
+
+(defvar rng-schema-locating-file-schema nil
+  "Schema for schema locating files or nil if not yet loaded.")
+
+(defcustom rng-schema-locating-files rng-schema-locating-files-default
+  "*List of schema locating files."
+  :type '(repeat file)
+  :group 'relax-ng)
+
+(defvar rng-schema-loader-alist nil
+  "Alist of schema extensions vs schema loader functions.")
+
+(defvar rng-cached-document-element nil)
+
+(defvar rng-document-type-history nil)
+
+(defun rng-set-document-type (type-id)
+  (interactive (list (rng-read-type-id)))
+  (condition-case err
+      (when (not (string= type-id ""))
+       (let ((schema-file (rng-locate-schema-file type-id)))
+         (unless schema-file
+           (error "Could not locate schema for type id `%s'" type-id))
+         (rng-set-schema-file-1 schema-file))
+       (rng-save-schema-location-1 t type-id)
+       (rng-what-schema))
+    (nxml-file-parse-error
+     (nxml-display-file-parse-error err))))
+
+(defun rng-read-type-id ()
+  (condition-case err
+      (let ((type-ids (rng-possible-type-ids))
+           (completion-ignore-case nil))
+       (completing-read "Document type id: "
+                        (mapcar (lambda (x) (cons x nil))
+                                type-ids)
+                        nil
+                        t
+                        nil
+                        'rng-document-type-history))
+    (nxml-file-parse-error
+     (nxml-display-file-parse-error err))))
+
+(defun rng-set-schema-file (filename)
+  "Set the schema for the current buffer to the schema in FILENAME.
+FILENAME must be the name of a file containing a schema.
+The extension of FILENAME is used to determine what kind of schema it
+is.  The variable `rng-schema-loader-alist' maps from schema
+extensions to schema loader functions. The function
+`rng-c-load-schema' is the loader for RELAX NG compact syntax.  The
+association is between the buffer and the schema: the association is
+lost when the buffer is killed."
+  (interactive "fSchema file: ")
+  (condition-case err
+      (progn
+       (rng-set-schema-file-1 filename)
+       (rng-save-schema-location-1 t))
+    (nxml-file-parse-error
+     (nxml-display-file-parse-error err))))
+
+(defun rng-set-vacuous-schema ()
+  "Set the schema for the current buffer to allow any well-formed XML."
+  (interactive)
+  (rng-set-schema-file-1 nil)
+  (rng-what-schema))
+
+(defun rng-set-schema-file-1 (filename)
+  (setq filename (and filename (expand-file-name filename)))
+  (setq rng-current-schema
+       (if filename
+           (rng-load-schema filename)
+         rng-any-element))
+  (setq rng-current-schema-file-name filename)
+  (run-hooks 'rng-schema-change-hook))
+  
+(defun rng-load-schema (filename)
+  (let* ((extension (file-name-extension filename))
+        (loader (cdr (assoc extension rng-schema-loader-alist))))
+    (or loader
+       (if extension
+           (error "No schema loader available for file extension `%s'"
+                  extension)
+         (error "No schema loader available for null file extension")))
+    (funcall loader filename)))
+
+(defun rng-what-schema ()
+  "Display a message saying what schema `rng-validate-mode' is using."
+  (interactive)
+  (if rng-current-schema-file-name
+      (message "Using schema %s" 
+              (abbreviate-file-name rng-current-schema-file-name))
+    (message "Using vacuous schema")))
+
+(defun rng-auto-set-schema (&optional no-display-error)
+  "Set the schema for this buffer based on the buffer's contents and 
file-name."
+  (interactive)
+  (condition-case err
+      (progn
+       (rng-set-schema-file-1 (rng-locate-schema-file))
+       (rng-what-schema))
+    (nxml-file-parse-error
+     (if no-display-error
+        (error "%s at position %s in %s"
+               (nth 3 err)
+               (nth 2 err)
+               (abbreviate-file-name (nth 1 err)))
+       (nxml-display-file-parse-error err)))))
+
+(defun rng-locate-schema-file (&optional type-id)
+  "Return the file-name of the schema to use for the current buffer.
+Return nil if no schema could be located.
+If TYPE-ID is non-nil, then locate the schema for this TYPE-ID."
+  (let* ((rng-cached-document-element nil)
+        (schema
+         (if type-id
+             (cons type-id nil)
+           (rng-locate-schema-file-using rng-schema-locating-files)))
+        files type-ids)
+    (while (consp schema)
+      (setq files rng-schema-locating-files)
+      (setq type-id (car schema))
+      (setq schema nil)
+      (when (member type-id type-ids)
+       (error "Type-id loop for type-id `%s'" type-id))
+      (setq type-ids (cons type-id type-ids))
+      (while (and files (not schema))
+       (setq schema
+             (rng-locate-schema-file-from-type-id type-id
+                                                  (car files)))
+       (setq files (cdr files))))
+    (and schema
+        (rng-uri-file-name schema))))
+
+(defun rng-possible-type-ids ()
+  "Return a list of the known type IDs."
+  (let ((files rng-schema-locating-files)
+       type-ids)
+    (while files
+      (setq type-ids (rng-possible-type-ids-using (car files) type-ids))
+      (setq files (cdr files)))
+    (rng-uniquify-equal (sort type-ids 'string<))))
+
+(defun rng-locate-schema-file-using (files)
+  "Locate a schema using the schema locating files FILES.
+FILES is a list of file-names.
+Return either a URI, a list (TYPE-ID) where TYPE-ID is a string
+or nil."
+  (let (rules
+       ;; List of types that override normal order-based
+       ;; priority, most important first
+       preferred-types
+       ;; Best result found so far; same form as return value.
+       best-so-far)
+    (while (and (progn
+                 (while (and (not rules) files)
+                   (setq rules (rng-get-parsed-schema-locating-file
+                                (car files)))
+                   (setq files (cdr files)))
+                 rules)
+               (or (not best-so-far) preferred-types))
+      (let* ((rule (car rules))
+            (rule-type (car rule))
+            (rule-matcher (get rule-type 'rng-rule-matcher)))
+       (setq rules (cdr rules))
+       (cond (rule-matcher
+              (when (and (or (not best-so-far)
+                             (memq rule-type preferred-types)))
+                         (setq best-so-far
+                               (funcall rule-matcher (cdr rule)))
+                         preferred-types)
+                (setq preferred-types
+                      (nbutlast preferred-types
+                                (length (memq rule-type preferred-types)))))
+             ((eq rule-type 'applyFollowingRules)
+              (when (not best-so-far)
+                (let ((prefer (cdr (assq 'ruleType (cdr rule)))))
+                  (when (and prefer
+                             (not (memq (setq prefer (intern prefer))
+                                        preferred-types)))
+                    (setq preferred-types
+                          (nconc preferred-types (list prefer)))))))
+             ((eq rule-type 'include)
+              (let ((uri (cdr (assq 'rules (cdr rule)))))
+                (when uri
+                  (setq rules
+                        (append (rng-get-parsed-schema-locating-file
+                                 (rng-uri-file-name uri))
+                                rules))))))))
+    best-so-far))
+
+(put 'documentElement 'rng-rule-matcher 'rng-match-document-element-rule)
+(put 'namespace 'rng-rule-matcher 'rng-match-namespace-rule)
+(put 'uri 'rng-rule-matcher 'rng-match-uri-rule)
+(put 'transformURI 'rng-rule-matcher 'rng-match-transform-uri-rule)
+(put 'default 'rng-rule-matcher 'rng-match-default-rule)
+
+(defun rng-match-document-element-rule (props)
+  (let ((document-element (rng-document-element))
+       (prefix (cdr (assq 'prefix props)))
+       (local-name (cdr (assq 'localName props))))
+    (and (or (not prefix)
+            (if (= (length prefix) 0)
+                (not (nth 1 document-element))
+              (string= prefix (nth 1 document-element))))
+        (or (not local-name)
+            (string= local-name
+                     (nth 2 document-element)))
+        (rng-match-default-rule props))))
+
+(defun rng-match-namespace-rule (props)
+  (let ((document-element (rng-document-element))
+       (ns (cdr (assq 'ns props))))
+    (and document-element
+        ns
+        (eq (nth 0 document-element)
+            (if (string= ns "")
+                nil
+              (nxml-make-namespace ns)))
+        (rng-match-default-rule props))))
+
+(defun rng-document-element ()
+  "Return a list (NS PREFIX LOCAL-NAME).
+NS is t if the document has a non-nil, but not otherwise known namespace."
+  (or rng-cached-document-element
+      (setq rng-cached-document-element
+           (save-excursion
+             (save-restriction
+               (widen)
+               (goto-char (point-min))
+               (let (xmltok-dtd)
+                 (xmltok-save
+                  (xmltok-forward-prolog)
+                  (xmltok-forward)
+                  (when (memq xmltok-type '(start-tag
+                                            partial-start-tag
+                                            empty-element
+                                            partial-empty-element))
+                    (list (rng-get-start-tag-namespace)
+                          (xmltok-start-tag-prefix)
+                          (xmltok-start-tag-local-name))))))))))
+
+(defun rng-get-start-tag-namespace ()
+  (let ((prefix (xmltok-start-tag-prefix))
+       namespace att value)
+    (while xmltok-namespace-attributes
+      (setq att (car xmltok-namespace-attributes))
+      (setq xmltok-namespace-attributes (cdr xmltok-namespace-attributes))
+      (when (if prefix
+               (and (xmltok-attribute-prefix att)
+                    (string= (xmltok-attribute-local-name att)
+                             prefix))
+             (not (xmltok-attribute-prefix att)))
+       (setq value (xmltok-attribute-value att))
+       (setq namespace (if value (nxml-make-namespace value) t))))
+    (if (and prefix (not namespace))
+       t
+      namespace)))
+
+(defun rng-match-transform-uri-rule (props)
+  (let ((from-pattern (cdr (assq 'fromPattern props)))
+       (to-pattern (cdr (assq 'toPattern props)))
+       (file-name (buffer-file-name)))
+    (and file-name
+        (setq file-name (expand-file-name file-name))
+        (rng-file-name-matches-uri-pattern-p file-name from-pattern)
+        (condition-case ()
+            (let ((new-file-name
+                   (replace-match
+                    (save-match-data
+                      (rng-uri-pattern-file-name-replace-match to-pattern))
+                    t
+                    nil
+                    file-name)))
+              (and (file-name-absolute-p new-file-name)
+                   (file-exists-p new-file-name)
+                   (rng-file-name-uri new-file-name)))
+            (rng-uri-error nil)))))
+
+(defun rng-match-uri-rule (props)
+  (let ((resource (cdr (assq 'resource props)))
+       (pattern (cdr (assq 'pattern props)))
+       (file-name (buffer-file-name)))
+    (and file-name
+        (setq file-name (expand-file-name file-name))
+        (cond (resource
+               (condition-case ()
+                   (eq (compare-strings (rng-uri-file-name resource)
+                                        0
+                                        nil
+                                        (expand-file-name file-name)
+                                        0
+                                        nil
+                                        nxml-file-name-ignore-case)
+                       t)
+                 (rng-uri-error nil)))
+              (pattern
+               (rng-file-name-matches-uri-pattern-p file-name
+                                                    pattern)))
+        (rng-match-default-rule props))))
+
+(defun rng-file-name-matches-uri-pattern-p (file-name pattern)
+  (condition-case ()
+      (and (let ((case-fold-search nxml-file-name-ignore-case))
+            (string-match (rng-uri-pattern-file-name-regexp pattern)
+                          file-name))
+          t)
+    (rng-uri-error nil)))
+
+(defun rng-match-default-rule (props)
+  (or (cdr (assq 'uri props))
+      (let ((type-id (cdr (assq 'typeId props))))
+       (and type-id
+            (cons (rng-collapse-space type-id) nil)))))
+
+(defun rng-possible-type-ids-using (file type-ids)
+  (let ((rules (rng-get-parsed-schema-locating-file file))
+       rule)
+    (while rules
+      (setq rule (car rules))
+      (setq rules (cdr rules))
+      (cond ((eq (car rule) 'typeId)
+            (let ((id (cdr (assq 'id (cdr rule)))))
+              (when id
+                (setq type-ids
+                      (cons (rng-collapse-space id)
+                            type-ids)))))
+           ((eq (car rule) 'include)
+            (let ((uri (cdr (assq 'rules (cdr rule)))))
+              (when uri
+                (setq type-ids
+                      (rng-possible-type-ids-using
+                       (rng-get-parsed-schema-locating-file
+                        (rng-uri-file-name uri))
+                       type-ids)))))))
+    type-ids))
+
+(defun rng-locate-schema-file-from-type-id (type-id file)
+  "Locate the schema for type id TYPE-ID using schema locating file FILE.
+Return either a URI, a list (TYPE-ID) where TYPE-ID is a string
+or nil."
+  (let ((rules (rng-get-parsed-schema-locating-file file))
+       schema rule)
+    (while (and rules (not schema))
+      (setq rule (car rules))
+      (setq rules (cdr rules))
+      (cond ((and (eq (car rule) 'typeId)
+                 (let ((id (assq 'id (cdr rule))))
+                   (and id
+                        (string= (rng-collapse-space (cdr id)) type-id))))
+            (setq schema (rng-match-default-rule (cdr rule))))
+           ((eq (car rule) 'include)
+            (let ((uri (cdr (assq 'rules (cdr rule)))))
+              (when uri
+                (setq schema
+                      (rng-locate-schema-file-from-type-id
+                       type-id
+                       (rng-uri-file-name uri))))))))
+    schema))
+
+(defvar rng-schema-locating-file-alist nil)
+
+(defun rng-get-parsed-schema-locating-file (file)
+  "Return a list of rules for the schema locating file FILE."
+  (setq file (expand-file-name file))
+  (let ((cached (assoc file rng-schema-locating-file-alist))
+       (mtime (nth 5 (file-attributes file)))
+       parsed)
+    (cond ((not mtime)
+          (when cached
+            (setq rng-schema-locating-file-alist
+                  (delq cached rng-schema-locating-file-alist)))
+          nil)
+         ((and cached (equal (nth 1 cached) mtime))
+          (nth 2 cached))
+         (t
+          (setq parsed (rng-parse-schema-locating-file file))
+          (if cached
+              (setcdr cached (list mtime parsed))
+            (setq rng-schema-locating-file-alist
+                  (cons (list file mtime parsed)
+                        rng-schema-locating-file-alist)))
+          parsed))))
+  
+(defconst rng-locate-namespace-uri
+  (nxml-make-namespace "http://thaiopensource.com/ns/locating-rules/1.0";))
+
+(defun rng-parse-schema-locating-file (file)
+  "Return list of rules.
+Each rule has the form (TYPE (ATTR . VAL) ...), where
+TYPE is a symbol for the element name, ATTR is a symbol for the attribute
+and VAL is a string for the value.
+Attribute values representing URIs are made absolute and xml:base
+attributes are removed."
+  (when (and (not rng-schema-locating-file-schema)
+            rng-schema-locating-file-schema-file)
+    (setq rng-schema-locating-file-schema
+         (rng-load-schema rng-schema-locating-file-schema-file)))
+  (let* ((element
+         (if rng-schema-locating-file-schema
+             (rng-parse-validate-file rng-schema-locating-file-schema
+                                      file)
+           (nxml-parse-file file)))
+        (children (cddr element))
+        (base-uri (rng-file-name-uri file))
+        child name rules atts att props prop-name prop-value)
+    (when (equal (car element)
+                (cons rng-locate-namespace-uri "locatingRules"))
+      (while children
+       (setq child (car children))
+       (setq children (cdr children))
+       (when (consp child)
+         (setq name (car child))
+         (when (eq (car name) rng-locate-namespace-uri)
+           (setq atts (cadr child))
+           (setq props nil)
+           (while atts
+             (setq att (car atts))
+             (when (stringp (car att))
+               (setq prop-name (intern (car att)))
+               (setq prop-value (cdr att))
+               (when (memq prop-name '(uri rules resource))
+                 (setq prop-value
+                       (rng-uri-resolve prop-value base-uri)))
+               (setq props (cons (cons prop-name prop-value)
+                                 props)))
+             (setq atts (cdr atts)))
+           (setq rules
+                 (cons (cons (intern (cdr name)) (nreverse props))
+                       rules))))))
+    (nreverse rules)))
+
+(defun rng-save-schema-location ()
+  "Save the association between the buffer's file and the current schema.
+This ensures that the schema that is currently being used will be used
+if the file is edited in a future session.  The association will be
+saved to the first writable file in `rng-schema-locating-files'."
+  (interactive)
+  (rng-save-schema-location-1 nil))
+
+(defun rng-save-schema-location-1 (prompt &optional type-id)
+  (unless (or rng-current-schema-file-name type-id)
+    (error "Buffer is using a vacuous schema"))
+  (let ((files rng-schema-locating-files)
+       (document-file-name (buffer-file-name))
+       (schema-file-name rng-current-schema-file-name)
+       file)
+    (while (and files (not file))
+      (if (file-writable-p (car files))
+         (setq file (expand-file-name (car files)))
+       (setq files (cdr files))))
+    (cond ((not file)
+          (if prompt
+              nil
+            (error "No writable schema locating file configured")))
+         ((not document-file-name)
+          (if prompt
+              nil
+            (error "Buffer does not have a filename")))
+         ((and prompt
+               (not (y-or-n-p (format "Save %s to %s "
+                                      (if type-id
+                                          "type identifier"
+                                        "schema location")
+                                      file)))))
+         (t
+          (save-excursion
+            (set-buffer (find-file-noselect file))
+            (let ((modified (buffer-modified-p)))
+              (if (> (buffer-size) 0)
+                  (let (xmltok-dtd)
+                    (goto-char (point-min))
+                    (xmltok-save
+                      (xmltok-forward-prolog)
+                      (xmltok-forward)
+                      (unless (eq xmltok-type 'start-tag)
+                        (error "Locating file `%s' invalid" file))))
+                (insert "<?xml version=\"1.0\"?>\n"
+                        "<locatingRules xmlns=\""
+                        (nxml-namespace-name rng-locate-namespace-uri)
+                        "\">")
+                (let ((pos (point)))
+                  (insert "\n</locatingRules>\n")
+                  (goto-char pos)))
+              (insert "\n")
+              (insert (let ((locating-file-uri (rng-file-name-uri file)))
+                        (format "<uri resource=\"%s\" %s=\"%s\"/>"
+                                (rng-escape-string
+                                 (rng-relative-uri
+                                  (rng-file-name-uri document-file-name)
+                                  locating-file-uri))
+                                (if type-id "typeId" "uri")
+                                (rng-escape-string
+                                 (or type-id
+                                     (rng-relative-uri
+                                      (rng-file-name-uri schema-file-name)
+                                      locating-file-uri))))))
+              (indent-according-to-mode)
+              (when (or (not modified)
+                        (y-or-n-p (format "Save file %s "
+                                          (buffer-file-name))))
+                (save-buffer))))))))
+
+(provide 'rng-loc)
+
+;;; rng-loc.el ends here