Initial commit

site-lisp/nxml-mode-20041004/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