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 (?\< . "<") 66 (?\> . ">") 67 (?\& . "&")) 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 '((?\" . """) 74 (?\< . "<") 75 (?\> . ">") 76 (?\& . "&") 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