lisp/muse-xml-common.el

   1 ;;; muse-xml-common.el --- common routines for XML-like publishing styles
   2
   3 ;; Copyright (C) 2005, 2006, 2007, 2008, 2009  Free Software Foundation, Inc.
   4
   5 ;; This file is part of Emacs Muse.  It is not part of GNU Emacs.
   6
   7 ;; Emacs Muse is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published
   9 ;; by the Free Software Foundation; either version 3, or (at your
  10 ;; option) any later version.
  11
  12 ;; Emacs Muse is distributed in the hope that it will be useful, but
  13 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 ;; General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with Emacs Muse; see the file COPYING.  If not, write to the
  19 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  20 ;; Boston, MA 02110-1301, USA.
  21
  22 ;;; Commentary:
  23
  24 ;;; Contributors:
  25
  26 ;;; Code:
  27
  28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29 ;;
  30 ;; Muse XML Publishing - Common Elements
  31 ;;
  32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33
  34 (require 'muse-publish)
  35 (require 'muse-regexps)
  36
  37 (defcustom muse-xml-encoding-map
  38   '((iso-8859-1         . "iso-8859-1")
  39     (iso-2022-jp        . "iso-2022-jp")
  40     (utf-8              . "utf-8")
  41     (japanese-iso-8bit  . "euc-jp")
  42     (chinese-big5       . "big5")
  43     (mule-utf-8         . "utf-8")
  44     (chinese-iso-8bit   . "gb2312")
  45     (chinese-gbk        . "gbk"))
  46   "An alist mapping Emacs coding systems to appropriate XML charsets.
  47 Use the base name of the coding system (i.e. without the -unix)."
  48   :type '(alist :key-type coding-system :value-type string)
  49   :group 'muse-xml)
  50
  51 (defun muse-xml-transform-content-type (content-type default)
  52   "Using `muse-xml-encoding-map', try and resolve an Emacs coding
  53 system to an associated XML coding system.
  54 If no match is found, the DEFAULT charset is used instead."
  55   (let ((match (and (fboundp 'coding-system-base)
  56                     (assoc (coding-system-base content-type)
  57                            muse-xml-encoding-map))))
  58     (if match
  59         (cdr match)
  60       default)))
  61
  62 (defcustom muse-xml-markup-specials
  63   '((?\" . "&quot;")
  64     (?\< . "&lt;")
  65     (?\> . "&gt;")
  66     (?\& . "&amp;"))
  67   "A table of characters which must be represented specially."
  68   :type '(alist :key-type character :value-type string)
  69   :group 'muse-xml)
  70
  71 (defcustom muse-xml-markup-specials-url-extra
  72   '((?\" . "&quot;")
  73     (?\< . "&lt;")
  74     (?\> . "&gt;")
  75     (?\& . "&amp;")
  76     (?\  . "%20")
  77     (?\n . "%0D%0A"))
  78   "A table of characters which must be represented specially.
  79 These are extra characters that are escaped within URLs."
  80   :type '(alist :key-type character :value-type string)
  81   :group 'muse-xml)
  82
  83 (defun muse-xml-decide-specials (context)
  84   "Determine the specials to escape, depending on CONTEXT."
  85   (cond ((memq context '(email url image))
  86          'muse-xml-escape-url)
  87         ((eq context 'url-extra)
  88          muse-xml-markup-specials-url-extra)
  89         (t muse-xml-markup-specials)))
  90
  91 (defun muse-xml-escape-url (str)
  92   "Convert to character entities any non-alphanumeric characters
  93 outside a few punctuation symbols, that risk being misinterpreted
  94 if not escaped."
  95   (when str
  96     (setq str (muse-publish-escape-specials-in-string str 'url-extra))
  97     (let (pos code len ch)
  98       (save-match-data
  99         (while (setq pos (string-match (concat "[^-"
 100                                                muse-regexp-alnum
 101                                                "/:._=@\\?~#%\"\\+<>()&;]")
 102                                        str pos))
 103           (setq ch (aref str pos)
 104                 code (concat "&#" (int-to-string
 105                                    (cond ((fboundp 'char-to-ucs)
 106                                           (char-to-ucs ch))
 107                                          ((fboundp 'char-to-int)
 108                                           (char-to-int ch))
 109                                          (t ch)))
 110                              ";")
 111                 len (length code)
 112                 str (concat (substring str 0 pos)
 113                             code
 114                             (when (< pos (length str))
 115                               (substring str (1+ pos) nil)))
 116                 pos (+ len pos)))
 117         str))))
 118
 119 (defun muse-xml-markup-anchor ()
 120   (unless (get-text-property (match-end 1) 'muse-link)
 121     (let ((text (muse-markup-text 'anchor (match-string 2))))
 122       (save-match-data
 123         (skip-chars-forward (concat muse-regexp-blank "\n"))
 124         (when (looking-at (concat "<\\([^" muse-regexp-blank "/>\n]+\\)>"))
 125           (goto-char (match-end 0)))
 126         (muse-insert-markup text)))
 127     (match-string 1)))
 128
 129 (defun muse-xml-sort-table (table)
 130   "Sort the given table structure so that it validates properly."
 131   ;; Note that the decision matrix must have a nil diagonal, or else
 132   ;; elements with the same type will be reversed with respect to each
 133   ;; other.
 134   (let ((decisions '((nil nil nil)      ; body < header, body < footer
 135                      (t   nil t)        ; header stays where it is
 136                      (t   nil nil))))   ; footer < header
 137     (sort table #'(lambda (l r)
 138                     (and (integerp (car l)) (integerp (car r))
 139                          (nth (1- (car r))
 140                               (nth (1- (car l)) decisions)))))))
 141
 142 (defun muse-xml-markup-table (&optional attributes)
 143   "Publish the matched region into a table.
 144 If a string ATTRIBUTES is given, pass it to the markup string begin-table."
 145   (let* ((table-info (muse-publish-table-fields (match-beginning 0)
 146                                                 (match-end 0)))
 147          (row-len (car table-info))
 148          (supports-group (not (string= (muse-markup-text 'begin-table-group
 149                                                          row-len)
 150                                        "")))
 151          (field-list (muse-xml-sort-table (cdr table-info)))
 152          last-part)
 153     (when table-info
 154       (let ((beg (point)))
 155         (muse-publish-ensure-block beg))
 156       (muse-insert-markup (muse-markup-text 'begin-table (or attributes "")))
 157       (muse-insert-markup (muse-markup-text 'begin-table-group row-len))
 158       (dolist (fields field-list)
 159         (let* ((type (car fields))
 160                (part (cond ((eq type 'hline) nil)
 161                            ((= type 1) "tbody")
 162                            ((= type 2) "thead")
 163                            ((= type 3) "tfoot")))
 164                (col (cond ((eq type 'hline) nil)
 165                           ((= type 1) "td")
 166                           ((= type 2) "th")
 167                           ((= type 3) "td"))))
 168           (setq fields (cdr fields))
 169           (unless (and part last-part (string= part last-part))
 170             (when last-part
 171               (muse-insert-markup "  </" last-part ">\n")
 172               (when (eq type 'hline)
 173                 ;; horizontal separators are represented by closing
 174                 ;; the current table group and opening a new one
 175                 (muse-insert-markup (muse-markup-text 'end-table-group))
 176                 (muse-insert-markup (muse-markup-text 'begin-table-group
 177                                                       row-len))))
 178             (when part
 179               (muse-insert-markup "  <" part ">\n"))
 180             (setq last-part part))
 181           (unless (eq type 'hline)
 182             (muse-insert-markup (muse-markup-text 'begin-table-row))
 183             (dolist (field fields)
 184               (muse-insert-markup (muse-markup-text 'begin-table-entry  col))
 185               (insert field)
 186               (muse-insert-markup (muse-markup-text 'end-table-entry  col)))
 187             (muse-insert-markup (muse-markup-text 'end-table-row)))))
 188       (when last-part
 189         (muse-insert-markup "  </" last-part ">\n"))
 190       (muse-insert-markup (muse-markup-text 'end-table-group))
 191       (muse-insert-markup (muse-markup-text 'end-table))
 192       (insert ?\n))))
 193
 194 (defun muse-xml-prepare-buffer ()
 195   (set (make-local-variable 'muse-publish-url-transforms)
 196        (cons 'muse-xml-escape-string muse-publish-url-transforms)))
 197
 198 (provide 'muse-xml-common)
 199
 200 ;;; muse-xml-common.el ends here