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