lisp/muse-xml.el

   1 ;;; muse-xml.el --- publish XML files
   2
   3 ;; Copyright (C) 2005  Free Software Foundation, Inc.
   4
   5 ;; This file is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 2, or (at your option)
   8 ;; any later version.
   9
  10 ;; This file is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  17 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  18 ;; Boston, MA 02110-1301, USA.
  19
  20 ;;; Commentary:
  21
  22 ;; James Clarke's nxml-mode can be used for editing and validating
  23 ;; Muse-generated XML files.  If you are in nxml-mode use the command
  24 ;; C-c C-s C-f to point to the schema in `contrib/muse.rnc', which
  25 ;; comes with Muse.  Say yes if you are asked if you want to copy the
  26 ;; file to your location.  C-c C-s C-a can then be used to reload the
  27 ;; schema if you make changes to the file.
  28
  29 ;;; Contributors:
  30
  31 ;; Peter K. Lee (saint AT corenova DOT com) made the initial
  32 ;; implementation of planner-publish.el, which was heavily borrowed
  33 ;; from.
  34 ;;
  35 ;; Brad Collins (brad AT chenla DOT org) provided a Compact RelaxNG
  36 ;; schema.
  37 ;;
  38 ;; Michael Olson (mwolson AT gnu DOT org) assembled everything into a
  39 ;; usable form.
  40
  41 ;;; Code:
  42
  43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44 ;;
  45 ;; Muse XML Publishing
  46 ;;
  47 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  48
  49 (require 'muse-publish)
  50 (require 'muse-regexps)
  51
  52 (defgroup muse-xml nil
  53   "Options controlling the behavior of Muse XML publishing.
  54 See `muse-xml' for more information."
  55   :group 'muse-publish)
  56
  57 (defcustom muse-xml-extension ".xml"
  58   "Default file extension for publishing XML files."
  59   :type 'string
  60   :group 'muse-xml)
  61
  62 (defcustom muse-xml-header
  63   "<?xml version=\"1.0\" encoding=\"<lisp>
  64   (muse-xml-encoding)</lisp>\"?>
  65 <MUSE>
  66   <pageinfo>
  67     <title><lisp>(muse-publishing-directive \"title\")</lisp></title>
  68     <author><lisp>(muse-publishing-directive \"author\")</lisp></author>
  69     <maintainer><lisp>(muse-style-element :maintainer)</lisp></maintainer>
  70     <pubdate><lisp>(muse-publishing-directive \"date\")</lisp></pubdate>
  71   </pageinfo>
  72   <!-- Page published by Emacs Muse begins here -->\n"
  73   "Header used for publishing XML files.
  74 This may be text or a filename."
  75   :type 'string
  76   :group 'muse-xml)
  77
  78 (defcustom muse-xml-footer "
  79   <!-- Page published by Emacs Muse ends here -->
  80 </MUSE>\n"
  81   "Footer used for publishing Xml XML files.
  82 This may be text or a filename."
  83   :type 'string
  84   :group 'muse-xml)
  85
  86 (defcustom muse-xml-markup-regexps
  87   `(;; Join together the parts of a table
  88     (10000 ,(concat "  </t\\(body\\|head\\|foot\\)>\\s-*</table>"
  89                     "\\([" muse-regexp-blank "]*\n\\)\\{0,2\\}"
  90                     "[" muse-regexp-blank "]*"
  91                     "<table[^>]*>\\s-*<t\\1>\n")
  92            0 "")
  93     (10100 ,(concat "</table>"
  94                     "\\([" muse-regexp-blank "]*\n\\)\\{0,2\\}"
  95                     "[" muse-regexp-blank "]*"
  96                     "<table[^>]*>\n")
  97            0 "")
  98
  99     ;; Join together the parts of a list
 100     (10200 ,(concat "</list>"
 101                     "\\([" muse-regexp-blank "]*\n\\)\\{0,2\\}"
 102                     "[" muse-regexp-blank "]*"
 103                     "<list[^>]*>\\s-*")
 104            0 "")
 105
 106     ;; Beginning of doc, end of doc, or plain paragraph separator
 107     (10300 ,(concat "\\(\n</\\(blockquote\\|format\\)>\\)?"
 108                     "\\(\\(\n\\(["
 109                     muse-regexp-blank
 110                     "]*\n\\)+\\)\\|\\`\\s-*\\|\\s-*\\'\\)"
 111                     "\\(<\\(blockquote\\|format type=\"center\"\\)>\n\\)?")
 112            0 muse-xml-markup-paragraph))
 113   "List of markup rules for publishing a Muse page to XML.
 114 For more on the structure of this list, see `muse-publish-markup-regexps'."
 115   :type '(repeat (choice
 116                   (list :tag "Markup rule"
 117                         integer
 118                         (choice regexp symbol)
 119                         integer
 120                         (choice string function symbol))
 121                   function))
 122   :group 'muse-xml)
 123
 124 (defcustom muse-xml-markup-functions
 125   '((anchor . muse-xml-markup-anchor)
 126     (table . muse-xml-markup-table))
 127   "An alist of style types to custom functions for that kind of text.
 128 For more on the structure of this list, see
 129 `muse-publish-markup-functions'."
 130   :type '(alist :key-type symbol :value-type function)
 131   :group 'muse-xml)
 132
 133 (defcustom muse-xml-markup-strings
 134   '((image-with-desc . "<image href=\"%s\">%s</image>")
 135     (image-link      . "<image href=\"%s\"></image>")
 136     (url-with-image  . "<link type=\"image\" href=\"%s\">%s</link>")
 137     (url-link        . "<link type=\"url\" href=\"%s\">%s</link>")
 138     (email-addr      . "<link type=\"email\" href=\"%s\">%s</link>")
 139     (emdash          . " -- ")
 140     (comment-begin   . "<!-- ")
 141     (comment-end     . " -->")
 142     (rule            . "<hr />")
 143     (fn-sep          . "<hr />\n")
 144     (no-break-space  . "&nbsp;")
 145     (enddots         . "....")
 146     (dots            . "...")
 147     (section         . "<section level=\"1\"><title>")
 148     (section-end     . "</title>")
 149     (subsection      . "<section level=\"2\"><title>")
 150     (subsection-end  . "</title>")
 151     (subsubsection   . "<section level=\"3\"><title>")
 152     (subsubsection-end . "</title>")
 153     (section-other   . "<section level=\"%s\"><title>")
 154     (section-other-end . "</title>")
 155     (section-close   . "</section>")
 156     (footnote        . "<footnote>")
 157     (footnote-end    . "</footnote>")
 158     (begin-underline . "<format type=\"underline\">")
 159     (end-underline   . "</format>")
 160     (begin-literal   . "<code>")
 161     (end-literal     . "</code>")
 162     (begin-emph      . "<format type=\"emphasis\" level=\"1\">")
 163     (end-emph        . "</format>")
 164     (begin-more-emph . "<format type=\"emphasis\" level=\"2\">")
 165     (end-more-emph   . "</format>")
 166     (begin-most-emph . "<format type=\"emphasis\" level=\"3\">")
 167     (end-most-emph   . "</format>")
 168     (begin-verse     . "<verse>\n")
 169     (begin-verse-line . "<line>")
 170     (end-verse-line  . "</line>")
 171     (empty-verse-line . "<line />")
 172     (begin-last-stanza-line . "<line>")
 173     (end-last-stanza-line . "</line>")
 174     (end-verse       . "</verse>")
 175     (begin-example   . "<example>")
 176     (end-example     . "</example>")
 177     (begin-center    . "<p><format type=\"center\">\n")
 178     (end-center      . "\n</format></p>")
 179     (begin-quote     . "<blockquote>\n")
 180     (end-quote       . "\n</blockquote>")
 181     (begin-uli       . "<list type=\"unordered\">\n<item>")
 182     (end-uli         . "</item>\n</list>")
 183     (begin-oli       . "<list type=\"ordered\">\n<item>")
 184     (end-oli         . "</item>\n</list>")
 185     (begin-ddt       . "<list type=\"definition\">\n<item><term>")
 186     (start-dde       . "</term>\n<definition>")
 187     (end-ddt         . "</definition>\n</item>\n</list>"))
 188   "Strings used for marking up text.
 189 These cover the most basic kinds of markup, the handling of which
 190 differs little between the various styles."
 191   :type '(alist :key-type symbol :value-type string)
 192   :group 'muse-xml)
 193
 194 (defcustom muse-xml-markup-specials
 195   '((?\" . "&quot;")
 196     (?\< . "&lt;")
 197     (?\> . "&gt;")
 198     (?\& . "&amp;"))
 199   "A table of characters which must be represented specially."
 200   :type '(alist :key-type character :value-type string)
 201   :group 'muse-xml)
 202
 203 (defcustom muse-xml-encoding-default 'utf-8
 204   "The default Emacs buffer encoding to use in published files.
 205 This will be used if no special characters are found."
 206   :type 'symbol
 207   :group 'muse-xml)
 208
 209 (defcustom muse-xml-charset-default "utf-8"
 210   "The default Xml XML charset to use if no translation is
 211 found in `muse-xml-encoding-map'."
 212   :type 'string
 213   :group 'muse-xml)
 214
 215 (defcustom muse-xml-encoding-map
 216   '((iso-8859-1         . "iso-8859-1")
 217     (iso-2022-jp        . "iso-2022-jp")
 218     (utf-8              . "utf-8")
 219     (japanese-iso-8bit  . "euc-jp")
 220     (chinese-big5       . "big5")
 221     (mule-utf-8         . "utf-8")
 222     (chinese-iso-8bit   . "gb2312")
 223     (chinese-gbk        . "gbk"))
 224   "An alist mapping emacs coding systems to appropriate Xml charsets.
 225 Use the base name of the coding system (i.e. without the -unix)."
 226   :type '(alist :key-type coding-system :value-type string)
 227   :group 'muse-xml)
 228
 229 (defun muse-xml-transform-content-type (content-type)
 230   "Using `muse-xml-encoding-map', try and resolve an emacs
 231 coding system to an associated XML coding system. If no
 232 match is found, `muse-xml-charset-default' is used instead."
 233   (let ((match (and (fboundp 'coding-system-base)
 234                     (assoc (coding-system-base content-type)
 235                            muse-xml-encoding-map))))
 236     (if match
 237         (cdr match)
 238       muse-xml-charset-default)))
 239
 240 (defun muse-xml-encoding ()
 241   (muse-xml-transform-content-type
 242    (or (and (boundp 'buffer-file-coding-system)
 243             buffer-file-coding-system)
 244        muse-xml-encoding-default)))
 245
 246 (defun muse-xml-markup-paragraph ()
 247   (let ((end (copy-marker (match-end 0) t)))
 248     (goto-char (match-beginning 0))
 249     (when (save-excursion
 250             (save-match-data
 251               (and (re-search-backward "<\\(/?\\)p[ >]"
 252                                        nil t)
 253                    (not (string-equal (match-string 1) "/")))))
 254       (insert "</p>"))
 255     (goto-char end))
 256   (cond
 257    ((eobp)
 258     (unless (bolp)
 259       (insert "\n")))
 260    ((eq (char-after) ?\<)
 261     (when (looking-at (concat "<\\(format\\|code\\|link\\|image"
 262                               "\\|anchor\\|footnote\\)[ >]"))
 263       (insert "<p>")))
 264    (t
 265     (insert "<p>"))))
 266
 267 (defun muse-xml-insert-anchor (anchor)
 268   "Insert an anchor, either around the word at point, or within a tag."
 269   (unless (get-text-property (match-end 1) 'noemphasis)
 270     (skip-chars-forward muse-regexp-space)
 271     (when (looking-at "<\\([^ />]+\\)>")
 272       (goto-char (match-end 0)))
 273     (insert "<anchor id=\"" anchor "\" />\n")))
 274
 275 (defun muse-xml-markup-anchor ()
 276   (save-match-data
 277     (muse-xml-insert-anchor (match-string 2)))
 278   (match-string 1))
 279
 280 (defun muse-xml-markup-table ()
 281   (let* ((str (prog1
 282                   (match-string 1)
 283                 (delete-region (match-beginning 0) (match-end 0))))
 284          (fields (split-string str "\\s-*|+\\s-*"))
 285          (type (and (string-match "\\s-*\\(|+\\)\\s-*" str)
 286                     (length (match-string 1 str))))
 287          (part (cond ((= type 1) "tbody")
 288                      ((= type 2) "thead")
 289                      ((= type 3) "tfoot")))
 290          (col (cond ((= type 1) "td")
 291                     ((= type 2) "th")
 292                     ((= type 3) "td"))))
 293     (insert "<table>\n"
 294             "  <" part ">\n"
 295             "    <tr>\n")
 296     (dolist (field fields)
 297       (insert "      <" col ">" field "</" col ">\n"))
 298     (insert "    </tr>\n"
 299             "  </" part ">\n"
 300             "</table>\n")))
 301
 302 (defun muse-xml-fixup-tables ()
 303   "Sort table parts."
 304   (goto-char (point-min))
 305   (let (last)
 306     (while (re-search-forward "^<table[^>]*>$" nil t)
 307       (unless (get-text-property (point) 'read-only)
 308         (forward-line 1)
 309         (save-restriction
 310           (let ((beg (point)))
 311             (narrow-to-region beg (and (re-search-forward "^</table>"
 312                                                           nil t)
 313                                        (match-beginning 0))))
 314           (goto-char (point-min))
 315           (let ((inhibit-read-only t))
 316             (sort-subr nil
 317                        (function
 318                         (lambda ()
 319                           (if (re-search-forward
 320                                "^\\s-*<t\\(head\\|body\\|foot\\)>$" nil t)
 321                               (goto-char (match-beginning 0))
 322                             (goto-char (point-max)))))
 323                        (function
 324                         (lambda ()
 325                           (if (re-search-forward
 326                                "^\\s-*</t\\(head\\|body\\|foot\\)>$" nil t)
 327                               (goto-char (match-end 0))
 328                             (goto-char (point-max)))))
 329                        (function
 330                         (lambda ()
 331                           (looking-at "\\s-*<t\\(head\\|body\\|foot\\)>")
 332                           (cond ((string= (match-string 1) "head") 1)
 333                                 ((string= (match-string 1) "foot") 2)
 334                                 (t 3)))))))))))
 335
 336 (defun muse-xml-finalize-buffer ()
 337   (when (boundp 'buffer-file-coding-system)
 338     (when (memq buffer-file-coding-system '(no-conversion undecided-unix))
 339       ;; make it agree with the default charset
 340       (setq buffer-file-coding-system muse-xml-encoding-default))))
 341
 342 ;; Register the Muse XML Publisher
 343
 344 (unless (assoc "xml" muse-publishing-styles)
 345   (muse-define-style "xml"
 346                      :suffix     'muse-xml-extension
 347                      :regexps    'muse-xml-markup-regexps
 348                      :functions  'muse-xml-markup-functions
 349                      :strings    'muse-xml-markup-strings
 350                      :specials   'muse-xml-markup-specials
 351                      :before-end 'muse-xml-fixup-tables
 352                      :after      'muse-xml-finalize-buffer
 353                      :header     'muse-xml-header
 354                      :footer     'muse-xml-footer
 355                      :browser    'find-file))
 356
 357 (provide 'muse-xml)
 358
 359 ;;; muse-xml.el ends here