diff options
Diffstat (limited to 'lisp/nxml/rng-maint.el')
| -rw-r--r-- | lisp/nxml/rng-maint.el | 343 |
1 files changed, 343 insertions, 0 deletions
diff --git a/lisp/nxml/rng-maint.el b/lisp/nxml/rng-maint.el new file mode 100644 index 0000000000..ecf1ff1bc9 --- /dev/null +++ b/lisp/nxml/rng-maint.el @@ -0,0 +1,343 @@ +;;; rng-maint.el --- commands for RELAX NG maintainers + +;; 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 'xmltok) +(require 'nxml-mode) +(require 'texnfo-upd) + +(defvar rng-dir (file-name-directory load-file-name)) + +(defconst rng-autoload-modules + '(xmltok + nxml-mode + nxml-uchnm + nxml-glyph + rng-cmpct + rng-maint + rng-valid + rng-xsd + rng-nxml)) + +;;;###autoload +(defun rng-update-autoloads () + "Update the autoloads in rng-auto.el." + (interactive) + (let* ((generated-autoload-file (expand-file-name "rng-auto.el" + rng-dir))) + (mapcar (lambda (x) + (update-file-autoloads + (expand-file-name (concat (symbol-name x) ".el") rng-dir))) + rng-autoload-modules))) + + +(defconst rng-compile-modules + '(xmltok + nxml-util + nxml-enc + nxml-glyph + nxml-rap + nxml-outln + nxml-mode + nxml-uchnm + nxml-ns + nxml-parse + nxml-maint + xsd-regexp + rng-util + rng-dt + rng-xsd + rng-uri + rng-pttrn + rng-cmpct + rng-match + rng-parse + rng-loc + rng-valid + rng-nxml + rng-maint)) + +;;;###autoload +(defun rng-byte-compile-load () + "Byte-compile and load all of the RELAX NG library in an appropriate order." + (interactive) + (mapcar (lambda (x) + (byte-compile-file (expand-file-name (concat (symbol-name x) ".el") + rng-dir) + t)) + rng-compile-modules)) + + +;;; Conversion from XML to texinfo. +;; This is all a hack and is just enough to make the conversion work. +;; It's not intended for public use. + +(defvar rng-manual-base "nxml-mode") +(defvar rng-manual-xml (concat rng-manual-base ".xml")) +(defvar rng-manual-texi (concat rng-manual-base ".texi")) +(defvar rng-manual-info (concat rng-manual-base ".info")) + +;;;###autoload +(defun rng-format-manual () + "Create manual.texi from manual.xml." + (interactive) + (let ((xml-buf (find-file-noselect (expand-file-name rng-manual-xml + rng-dir))) + (texi-buf (find-file-noselect (expand-file-name rng-manual-texi + rng-dir)))) + (save-excursion + (set-buffer texi-buf) + (erase-buffer) + (let ((standard-output texi-buf)) + (princ (format "\\input texinfo @c -*- texinfo -*-\n\ +@c %%**start of header\n\ +@setfilename %s\n\ +@settitle \n\ +@c %%**end of header\n" rng-manual-info)) + (set-buffer xml-buf) + (goto-char (point-min)) + (xmltok-save + (xmltok-forward-prolog) + (rng-process-tokens)) + (princ "\n@bye\n")) + (set-buffer texi-buf) + (rng-manual-fixup) + (texinfo-insert-node-lines (point-min) (point-max) t) + (texinfo-all-menus-update) + (save-buffer)))) + +(defun rng-manual-fixup () + (goto-char (point-min)) + (search-forward "@top ") + (let ((pos (point))) + (search-forward "\n") + (let ((title (buffer-substring-no-properties pos (1- (point))))) + (goto-char (point-min)) + (search-forward "@settitle ") + (insert title) + (search-forward "@node") + (goto-char (match-beginning 0)) + (insert "@dircategory Emacs\n" + "@direntry\n* " + title + ": (" + rng-manual-info + ").\n@end direntry\n\n")))) + +(defvar rng-manual-inline-elements '(kbd key samp code var emph uref point)) + +(defun rng-process-tokens () + (let ((section-depth 0) + ;; stack of per-element space treatment + ;; t means keep, nil means discard, fill means no blank lines + (keep-space-stack (list nil)) + (ignore-following-newline nil) + (want-blank-line nil) + name startp endp data keep-space-for-children) + (while (xmltok-forward) + (cond ((memq xmltok-type '(start-tag empty-element end-tag)) + (setq startp (memq xmltok-type '(start-tag empty-element))) + (setq endp (memq xmltok-type '(end-tag empty-element))) + (setq name (intern (if startp + (xmltok-start-tag-qname) + (xmltok-end-tag-qname)))) + (setq keep-space-for-children nil) + (setq ignore-following-newline nil) + (cond ((memq name rng-manual-inline-elements) + (when startp + (when want-blank-line + (rng-manual-output-force-blank-line) + (when (eq want-blank-line 'noindent) + (princ "@noindent\n")) + (setq want-blank-line nil)) + (setq keep-space-for-children t) + (princ (format "@%s{" name))) + (when endp (princ "}"))) + ((eq name 'ulist) + (when startp + (rng-manual-output-force-blank-line) + (setq want-blank-line nil) + (princ "@itemize @bullet\n")) + (when endp + (rng-manual-output-force-new-line) + (setq want-blank-line 'noindent) + (princ "@end itemize\n"))) + ((eq name 'item) + (rng-manual-output-force-new-line) + (setq want-blank-line endp) + (when startp (princ "@item\n"))) + ((memq name '(example display)) + (when startp + (setq ignore-following-newline t) + (rng-manual-output-force-blank-line) + (setq want-blank-line nil) + (setq keep-space-for-children t) + (princ (format "@%s\n" name))) + (when endp + (rng-manual-output-force-new-line) + (setq want-blank-line 'noindent) + (princ (format "@end %s\n" name)))) + ((eq name 'para) + (rng-manual-output-force-new-line) + (when startp + (when want-blank-line + (setq want-blank-line t)) + (setq keep-space-for-children 'fill)) + (when endp (setq want-blank-line t))) + ((eq name 'section) + (when startp + (rng-manual-output-force-blank-line) + (when (eq section-depth 0) + (princ "@node Top\n")) + (princ "@") + (princ (nth section-depth '(top + chapter + section + subsection + subsubsection))) + (princ " ") + (setq want-blank-line nil) + (setq section-depth (1+ section-depth))) + (when endp + (rng-manual-output-force-new-line) + (setq want-blank-line nil) + (setq section-depth (1- section-depth)))) + ((eq name 'title) + (when startp + (setq keep-space-for-children 'fill)) + (when endp + (setq want-blank-line t) + (princ "\n")))) + (when startp + (setq keep-space-stack (cons keep-space-for-children + keep-space-stack))) + (when endp + (setq keep-space-stack (cdr keep-space-stack)))) + ((memq xmltok-type '(data + space + char-ref + entity-ref + cdata-section)) + (setq data nil) + (cond ((memq xmltok-type '(data space)) + (setq data (buffer-substring-no-properties xmltok-start + (point)))) + ((and (memq xmltok-type '(char-ref entity-ref)) + xmltok-replacement) + (setq data xmltok-replacement)) + ((eq xmltok-type 'cdata-section) + (setq data + (buffer-substring-no-properties (+ xmltok-start 9) + (- (point) 3))))) + (when (and data (car keep-space-stack)) + (setq data (replace-regexp-in-string "[@{}]" + "@\\&" + data + t)) + (when ignore-following-newline + (setq data (replace-regexp-in-string "\\`\n" "" data t))) + (setq ignore-following-newline nil) +;; (when (eq (car keep-space-stack) 'fill) +;; (setq data (replace-regexp-in-string "\n" " " data t))) + (when (eq want-blank-line 'noindent) + (setq data (replace-regexp-in-string "\\`\n*" "" data t))) + (when (> (length data) 0) + (when want-blank-line + (rng-manual-output-force-blank-line) + (when (eq want-blank-line 'noindent) + (princ "@noindent\n")) + (setq want-blank-line nil)) + (princ data)))) + )))) + +(defun rng-manual-output-force-new-line () + (save-excursion + (set-buffer standard-output) + (unless (eq (char-before) ?\n) + (insert ?\n)))) + +(defun rng-manual-output-force-blank-line () + (save-excursion + (set-buffer standard-output) + (if (eq (char-before) ?\n) + (unless (eq (char-before (1- (point))) ?\n) + (insert ?\n)) + (insert "\n\n")))) + +;;; Versioning + +;;;###autoload +(defun rng-write-version () + (find-file "VERSION") + (erase-buffer) + (insert nxml-version "\n") + (save-buffer)) + +;;; Timing + +(defun rng-time-to-float (time) + (+ (* (nth 0 time) 65536.0) + (nth 1 time) + (/ (nth 2 time) 1000000.0))) + +(defun rng-time-function (function &rest args) + (let* ((start (current-time)) + (val (apply function args)) + (end (current-time))) + (message "%s ran in %g seconds" + function + (- (rng-time-to-float end) + (rng-time-to-float start))) + val)) + +(defun rng-time-tokenize-buffer () + (interactive) + (rng-time-function 'rng-tokenize-buffer)) + +(defun rng-tokenize-buffer () + (save-excursion + (goto-char (point-min)) + (xmltok-save + (xmltok-forward-prolog) + (while (xmltok-forward))))) + +(defun rng-time-validate-buffer () + (interactive) + (rng-time-function 'rng-validate-buffer)) + +(defun rng-validate-buffer () + (save-restriction + (widen) + (nxml-with-unmodifying-text-property-changes + (rng-clear-cached-state (point-min) (point-max))) + ;; 1+ to clear empty overlays at (point-max) + (rng-clear-overlays (point-min) (1+ (point-max)))) + (setq rng-validate-up-to-date-end 1) + (rng-clear-conditional-region) + (setq rng-error-count 0) + (while (rng-do-some-validation + (lambda () t)))) + +;;; rng-maint.el ends here |