[Emacs-diffs] Changes to lisp/nxml/rng-maint.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-maint.el
===================================================================
RCS file: lisp/nxml/rng-maint.el
diff -N lisp/nxml/rng-maint.el
--- /dev/null   1 Jan 1970 00:00:00 -0000
+++ lisp/nxml/rng-maint.el      23 Nov 2007 06:57:51 -0000      1.1
@@ -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\
address@hidden %%**start of header\n\
address@hidden %s\n\
address@hidden \n\
address@hidden %%**end of header\n" rng-manual-info))
+       (set-buffer xml-buf)
+       (goto-char (point-min))
+       (xmltok-save
+         (xmltok-forward-prolog)
+         (rng-process-tokens))
+       (princ "address@hidden"))
+      (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
+             ")address@hidden 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 "address@hidden"
+                                                   "@\\&"
+                                                   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