code.delx.au - gnu-emacs/blob - lisp/nxml/nxml-maint.el

   1 ;;; nxml-maint.el --- commands for maintainers of nxml-*.el
   2
   3 ;; Copyright (C) 2003, 2007, 2008 Free Software Foundation, Inc.
   4
   5 ;; Author: James Clark
   6 ;; Keywords: XML
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 3, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 ;;; Generating files with Unicode char names.
  30
  31 (require 'nxml-uchnm)
  32
  33 (defun nxml-create-unicode-char-name-sets (file)
  34   "Generate files containing char names from Unicode standard."
  35   (interactive "fUnicodeData file: ")
  36   (mapc (lambda (block)
  37           (let ((nameset (nxml-unicode-block-char-name-set (nth 0 block))))
  38             (save-excursion
  39               (find-file (concat (get nameset 'nxml-char-name-set-file)
  40                                  ".el"))
  41               (erase-buffer)
  42               (insert "(nxml-define-char-name-set '")
  43               (prin1 nameset (current-buffer))
  44               (insert "\n  '())\n")
  45               (goto-char (- (point) 3)))))
  46         nxml-unicode-blocks)
  47   (save-excursion
  48     (find-file file)
  49     (goto-char (point-min))
  50     (let ((blocks nxml-unicode-blocks)
  51           code name)
  52       (while (re-search-forward "^\\([0-9A-F]+\\);\\([^<;][^;]*\\);"
  53                                 nil
  54                                 t)
  55         (setq code (string-to-number (match-string 1) 16))
  56         (setq name (match-string 2))
  57         (while (and blocks
  58                     (> code (nth 2 (car blocks))))
  59           (setq blocks (cdr blocks)))
  60         (when (and (<= (nth 1 (car blocks)) code)
  61                    (<= code (nth 2 (car blocks))))
  62           (save-excursion
  63             (find-file (concat (get (nxml-unicode-block-char-name-set
  64                                      (nth 0 (car blocks)))
  65                                     'nxml-char-name-set-file)
  66                                ".el"))
  67             (insert "(")
  68             (prin1 name (current-buffer))
  69             (insert (format " #x%04X)\n    " code))))))))
  70
  71 ;;; Parsing target repertoire files from ucs-fonts.
  72 ;; This is for converting the TARGET? files in
  73 ;; http://www.cl.cam.ac.uk/~mgk25/download/ucs-fonts.tar.gz
  74 ;; into a glyph set.
  75
  76 (defun nxml-insert-target-repertoire-glyph-set (file var)
  77   (interactive "fTarget file: \nSVariable name: ")
  78   (let (lst head)
  79     (save-excursion
  80       (set-buffer (find-file-noselect file))
  81       (goto-char (point-min))
  82       (while (re-search-forward "^ *\\([a-FA-F0-9]\\{2\\}\\)[ \t]+" nil t)
  83         (let ((row (match-string 1))
  84               (eol (save-excursion (end-of-line) (point))))
  85           (while (re-search-forward "\\([a-FA-F0-9]\\{2\\}\\)-\\([a-FA-F0-9]\\{2\\}\\)\\|\\([a-FA-F0-9]\\{2\\}\\)" eol t)
  86             (setq lst
  87                   (cons (if (match-beginning 3)
  88                             (concat "#x" row (match-string 3))
  89                         (concat "(#x" row (match-string 1)
  90                                 " . #x" row (match-string 2) ")"))
  91                         lst))))))
  92     (setq lst (nreverse lst))
  93     (insert (format "(defconst %s\n  [" var))
  94     (while lst
  95       (setq head (car lst))
  96       (setq lst (cdr lst))
  97       (insert head)
  98       (when (= (length head) 6)
  99         (while (and lst (= (length (car lst)) 6))
 100           (insert " ")
 101           (insert (car lst))
 102           (setq lst (cdr lst))))
 103       (when lst (insert "\n   ")))
 104     (insert "])\n")))
 105
 106 (provide 'nxml-maint)
 107
 108 ;; arch-tag: 2cff6b55-12af-47db-90da-a91f782f435a
 109 ;;; nxml-maint.el ends here