Initial commit
This commit is contained in:
John Doty
commit
a491ef2093
813 changed files with 345031 additions and 0 deletions
548
site-lisp/nxml-mode-20041004/rng-loc.el
Normal file
548
site-lisp/nxml-mode-20041004/rng-loc.el
Normal file
|
|
@ -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
|
||||
Loading…
Add table
Add a link
Reference in a new issue