lisp/muse-xml-common.el

   1 ;;; muse-xml-common.el --- common routines for XML-like publishing styles
   2
   3 ;; Copyright (C) 2005  Free Software Foundation, Inc.
   4
   5 ;; This file is not part of GNU Emacs.
   6
   7 ;; This is free software; you can redistribute it and/or modify it under
   8 ;; the terms of the GNU General Public License as published by the Free
   9 ;; Software Foundation; either version 2, or (at your option) any later
  10 ;; version.
  11 ;;
  12 ;; This is distributed in the hope that it will be useful, but WITHOUT
  13 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 ;; for more details.
  16 ;;
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with GNU Emacs; 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-publish)
  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))
  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) 'noemphasis)
 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                     (nth (1- (car r))
 139                          (nth (1- (car l)) decisions))))))
 140
 141 (defun muse-xml-markup-table (&optional attributes)
 142   (let* ((table-info (muse-publish-table-fields (match-beginning 0)
 143                                                 (match-end 0)))
 144          (row-len (car table-info))
 145          (field-list (muse-xml-sort-table (cdr table-info)))
 146          last-part)
 147     (muse-insert-markup (muse-markup-text 'begin-table attributes))
 148     (muse-insert-markup (muse-markup-text 'begin-table-group row-len))
 149     (dolist (fields field-list)
 150       (let* ((type (car fields))
 151              (part (cond ((= type 1) "tbody")
 152                          ((= type 2) "thead")
 153                          ((= type 3) "tfoot")))
 154              (col (cond ((= type 1) "td")
 155                         ((= type 2) "th")
 156                         ((= type 3) "td"))))
 157         (setq fields (cdr fields))
 158         (unless (and last-part (string= part last-part))
 159           (when last-part
 160             (muse-insert-markup "  </" last-part ">\n"))
 161           (muse-insert-markup "  <" part ">\n")
 162           (setq last-part part))
 163         (muse-insert-markup (muse-markup-text 'begin-table-row))
 164         (dolist (field fields)
 165           (muse-insert-markup (muse-markup-text 'begin-table-entry  col))
 166           (insert field)
 167           (muse-insert-markup (muse-markup-text 'end-table-entry  col)))
 168         (muse-insert-markup (muse-markup-text 'end-table-row))))
 169     (when last-part
 170       (muse-insert-markup "  </" last-part ">\n"))
 171     (muse-insert-markup (muse-markup-text 'end-table-group))
 172     (muse-insert-markup (muse-markup-text 'end-table))))
 173
 174 (defun muse-xml-prepare-buffer ()
 175   (set (make-local-variable 'muse-publish-url-transforms)
 176        (cons 'muse-xml-escape-string muse-publish-url-transforms)))
 177
 178 (provide 'muse-xml-common)
 179
 180 ;;; muse-xml-common.el ends here