lisp/muse-xml.el

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