lisp/nxml/rng-maint.el

   1 ;;; rng-maint.el --- commands for RELAX NG maintainers
   2
   3 ;; Copyright (C) 2003 Free Software Foundation, Inc.
   4
   5 ;; Author: James Clark
   6 ;; Keywords: XML, RelaxNG
   7
   8 ;; This program is free software; you can redistribute it and/or
   9 ;; modify it under the terms of the GNU General Public License as
  10 ;; published by the Free Software Foundation; either version 2 of
  11 ;; the License, or (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be
  14 ;; useful, but WITHOUT ANY WARRANTY; without even the implied
  15 ;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
  16 ;; PURPOSE.  See the GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public
  19 ;; License along with this program; if not, write to the Free
  20 ;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
  21 ;; MA 02111-1307 USA
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (require 'xmltok)
  28 (require 'nxml-mode)
  29 (require 'texnfo-upd)
  30
  31 (defvar rng-dir (file-name-directory load-file-name))
  32
  33 (defconst rng-autoload-modules
  34   '(xmltok
  35     nxml-mode
  36     nxml-uchnm
  37     nxml-glyph
  38     rng-cmpct
  39     rng-maint
  40     rng-valid
  41     rng-xsd
  42     rng-nxml))
  43
  44 ;;;###autoload
  45 (defun rng-update-autoloads ()
  46   "Update the autoloads in rng-auto.el."
  47   (interactive)
  48   (let* ((generated-autoload-file (expand-file-name "rng-auto.el"
  49                                                     rng-dir)))
  50     (mapcar (lambda (x)
  51               (update-file-autoloads
  52                (expand-file-name (concat (symbol-name x) ".el") rng-dir)))
  53             rng-autoload-modules)))
  54
  55
  56 (defconst rng-compile-modules
  57   '(xmltok
  58     nxml-util
  59     nxml-enc
  60     nxml-glyph
  61     nxml-rap
  62     nxml-outln
  63     nxml-mode
  64     nxml-uchnm
  65     nxml-ns
  66     nxml-parse
  67     nxml-maint
  68     xsd-regexp
  69     rng-util
  70     rng-dt
  71     rng-xsd
  72     rng-uri
  73     rng-pttrn
  74     rng-cmpct
  75     rng-match
  76     rng-parse
  77     rng-loc
  78     rng-valid
  79     rng-nxml
  80     rng-maint))
  81
  82 ;;;###autoload
  83 (defun rng-byte-compile-load ()
  84   "Byte-compile and load all of the RELAX NG library in an appropriate order."
  85   (interactive)
  86   (mapcar (lambda (x)
  87             (byte-compile-file (expand-file-name (concat (symbol-name x) ".el")
  88                                                  rng-dir)
  89                                t))
  90           rng-compile-modules))
  91
  92
  93 ;;; Conversion from XML to texinfo.
  94 ;; This is all a hack and is just enough to make the conversion work.
  95 ;; It's not intended for public use.
  96
  97 (defvar rng-manual-base "nxml-mode")
  98 (defvar rng-manual-xml (concat rng-manual-base ".xml"))
  99 (defvar rng-manual-texi (concat rng-manual-base ".texi"))
 100 (defvar rng-manual-info (concat rng-manual-base ".info"))
 101
 102 ;;;###autoload
 103 (defun rng-format-manual ()
 104   "Create manual.texi from manual.xml."
 105   (interactive)
 106   (let ((xml-buf (find-file-noselect (expand-file-name rng-manual-xml
 107                                                        rng-dir)))
 108         (texi-buf (find-file-noselect (expand-file-name rng-manual-texi
 109                                                         rng-dir))))
 110     (save-excursion
 111       (set-buffer texi-buf)
 112       (erase-buffer)
 113       (let ((standard-output texi-buf))
 114         (princ (format "\\input texinfo @c -*- texinfo -*-\n\
 115 @c %%**start of header\n\
 116 @setfilename %s\n\
 117 @settitle \n\
 118 @c %%**end of header\n" rng-manual-info))
 119         (set-buffer xml-buf)
 120         (goto-char (point-min))
 121         (xmltok-save
 122           (xmltok-forward-prolog)
 123           (rng-process-tokens))
 124         (princ "\n@bye\n"))
 125       (set-buffer texi-buf)
 126       (rng-manual-fixup)
 127       (texinfo-insert-node-lines (point-min) (point-max) t)
 128       (texinfo-all-menus-update)
 129       (save-buffer))))
 130
 131 (defun rng-manual-fixup ()
 132   (goto-char (point-min))
 133   (search-forward "@top ")
 134   (let ((pos (point)))
 135     (search-forward "\n")
 136     (let ((title (buffer-substring-no-properties pos (1- (point)))))
 137       (goto-char (point-min))
 138       (search-forward "@settitle ")
 139       (insert title)
 140       (search-forward "@node")
 141       (goto-char (match-beginning 0))
 142       (insert "@dircategory Emacs\n"
 143               "@direntry\n* "
 144               title
 145               ": ("
 146               rng-manual-info
 147               ").\n@end direntry\n\n"))))
 148
 149 (defvar rng-manual-inline-elements '(kbd key samp code var emph uref point))
 150
 151 (defun rng-process-tokens ()
 152   (let ((section-depth 0)
 153         ;; stack of per-element space treatment
 154         ;; t means keep, nil means discard, fill means no blank lines
 155         (keep-space-stack (list nil))
 156         (ignore-following-newline nil)
 157         (want-blank-line nil)
 158         name startp endp data keep-space-for-children)
 159     (while (xmltok-forward)
 160       (cond ((memq xmltok-type '(start-tag empty-element end-tag))
 161              (setq startp (memq xmltok-type '(start-tag empty-element)))
 162              (setq endp (memq xmltok-type '(end-tag empty-element)))
 163              (setq name (intern (if startp
 164                                     (xmltok-start-tag-qname)
 165                                   (xmltok-end-tag-qname))))
 166              (setq keep-space-for-children nil)
 167              (setq ignore-following-newline nil)
 168              (cond ((memq name rng-manual-inline-elements)
 169                     (when startp
 170                       (when want-blank-line
 171                         (rng-manual-output-force-blank-line)
 172                         (when (eq want-blank-line 'noindent)
 173                           (princ "@noindent\n"))
 174                         (setq want-blank-line nil))
 175                       (setq keep-space-for-children t)
 176                       (princ (format "@%s{" name)))
 177                     (when endp (princ "}")))
 178                    ((eq name 'ulist)
 179                     (when startp
 180                       (rng-manual-output-force-blank-line)
 181                       (setq want-blank-line nil)
 182                       (princ "@itemize @bullet\n"))
 183                     (when endp
 184                       (rng-manual-output-force-new-line)
 185                       (setq want-blank-line 'noindent)
 186                       (princ "@end itemize\n")))
 187                    ((eq name 'item)
 188                     (rng-manual-output-force-new-line)
 189                     (setq want-blank-line endp)
 190                     (when startp (princ "@item\n")))
 191                    ((memq name '(example display))
 192                     (when startp
 193                       (setq ignore-following-newline t)
 194                       (rng-manual-output-force-blank-line)
 195                       (setq want-blank-line nil)
 196                       (setq keep-space-for-children t)
 197                       (princ (format "@%s\n" name)))
 198                     (when endp
 199                       (rng-manual-output-force-new-line)
 200                       (setq want-blank-line 'noindent)
 201                       (princ (format "@end %s\n" name))))
 202                    ((eq name 'para)
 203                     (rng-manual-output-force-new-line)
 204                     (when startp
 205                       (when want-blank-line
 206                         (setq want-blank-line t))
 207                       (setq keep-space-for-children 'fill))
 208                     (when endp (setq want-blank-line t)))
 209                    ((eq name 'section)
 210                     (when startp
 211                       (rng-manual-output-force-blank-line)
 212                       (when (eq section-depth 0)
 213                         (princ "@node Top\n"))
 214                       (princ "@")
 215                       (princ (nth section-depth '(top
 216                                                   chapter
 217                                                   section
 218                                                   subsection
 219                                                   subsubsection)))
 220                       (princ " ")
 221                       (setq want-blank-line nil)
 222                       (setq section-depth (1+ section-depth)))
 223                     (when endp
 224                       (rng-manual-output-force-new-line)
 225                       (setq want-blank-line nil)
 226                       (setq section-depth (1- section-depth))))
 227                    ((eq name 'title)
 228                     (when startp
 229                       (setq keep-space-for-children 'fill))
 230                     (when endp
 231                       (setq want-blank-line t)
 232                       (princ "\n"))))
 233              (when startp
 234                (setq keep-space-stack (cons keep-space-for-children
 235                                             keep-space-stack)))
 236              (when endp
 237                (setq keep-space-stack (cdr keep-space-stack))))
 238             ((memq xmltok-type '(data
 239                                  space
 240                                  char-ref
 241                                  entity-ref
 242                                  cdata-section))
 243              (setq data nil)
 244              (cond ((memq xmltok-type '(data space))
 245                     (setq data (buffer-substring-no-properties xmltok-start
 246                                                                (point))))
 247                    ((and (memq xmltok-type '(char-ref entity-ref))
 248                          xmltok-replacement)
 249                     (setq data xmltok-replacement))
 250                    ((eq xmltok-type 'cdata-section)
 251                     (setq data
 252                           (buffer-substring-no-properties (+ xmltok-start 9)
 253                                                           (- (point) 3)))))
 254              (when (and data (car keep-space-stack))
 255                (setq data (replace-regexp-in-string "[@{}]"
 256                                                     "@\\&"
 257                                                     data
 258                                                     t))
 259                (when ignore-following-newline
 260                  (setq data (replace-regexp-in-string "\\`\n" "" data t)))
 261                (setq ignore-following-newline nil)
 262 ;;             (when (eq (car keep-space-stack) 'fill)
 263 ;;               (setq data (replace-regexp-in-string "\n" " " data t)))
 264                (when (eq want-blank-line 'noindent)
 265                  (setq data (replace-regexp-in-string "\\`\n*" "" data t)))
 266                (when (> (length data) 0)
 267                  (when want-blank-line
 268                    (rng-manual-output-force-blank-line)
 269                    (when (eq want-blank-line 'noindent)
 270                      (princ "@noindent\n"))
 271                    (setq want-blank-line nil))
 272                  (princ data))))
 273              ))))
 274
 275 (defun rng-manual-output-force-new-line ()
 276   (save-excursion
 277     (set-buffer standard-output)
 278     (unless (eq (char-before) ?\n)
 279       (insert ?\n))))
 280
 281 (defun rng-manual-output-force-blank-line ()
 282   (save-excursion
 283     (set-buffer standard-output)
 284     (if (eq (char-before) ?\n)
 285         (unless (eq (char-before (1- (point))) ?\n)
 286           (insert ?\n))
 287       (insert "\n\n"))))
 288
 289 ;;; Versioning
 290
 291 ;;;###autoload
 292 (defun rng-write-version ()
 293   (find-file "VERSION")
 294   (erase-buffer)
 295   (insert nxml-version "\n")
 296   (save-buffer))
 297
 298 ;;; Timing
 299
 300 (defun rng-time-to-float (time)
 301   (+ (* (nth 0 time) 65536.0)
 302      (nth 1 time)
 303      (/ (nth 2 time) 1000000.0)))
 304
 305 (defun rng-time-function (function &rest args)
 306   (let* ((start (current-time))
 307          (val (apply function args))
 308          (end (current-time)))
 309     (message "%s ran in %g seconds"
 310              function
 311              (- (rng-time-to-float end)
 312                 (rng-time-to-float start)))
 313     val))
 314
 315 (defun rng-time-tokenize-buffer ()
 316   (interactive)
 317   (rng-time-function 'rng-tokenize-buffer))
 318
 319 (defun rng-tokenize-buffer ()
 320   (save-excursion
 321     (goto-char (point-min))
 322     (xmltok-save
 323       (xmltok-forward-prolog)
 324       (while (xmltok-forward)))))
 325
 326 (defun rng-time-validate-buffer ()
 327   (interactive)
 328   (rng-time-function 'rng-validate-buffer))
 329
 330 (defun rng-validate-buffer ()
 331   (save-restriction
 332     (widen)
 333     (nxml-with-unmodifying-text-property-changes
 334       (rng-clear-cached-state (point-min) (point-max)))
 335     ;; 1+ to clear empty overlays at (point-max)
 336     (rng-clear-overlays (point-min) (1+ (point-max))))
 337   (setq rng-validate-up-to-date-end 1)
 338   (rng-clear-conditional-region)
 339   (setq rng-error-count 0)
 340   (while (rng-do-some-validation
 341           (lambda () t))))
 342
 343 ;;; rng-maint.el ends here