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.
48Use 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
54system to an associated XML coding system.
55If 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  '((?\" . """)
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.
80These 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
94outside a few punctuation symbols, that risk being misinterpreted
95if 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.
145If 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
202