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