diff options
Diffstat (limited to 'emacs.d/elisp/muse/muse-xml-common.el')
| -rw-r--r-- | emacs.d/elisp/muse/muse-xml-common.el | 201 |
1 files changed, 201 insertions, 0 deletions
diff --git a/emacs.d/elisp/muse/muse-xml-common.el b/emacs.d/elisp/muse/muse-xml-common.el new file mode 100644 index 0000000..75869ca --- /dev/null +++ b/emacs.d/elisp/muse/muse-xml-common.el @@ -0,0 +1,201 @@ +;;; muse-xml-common.el --- common routines for XML-like publishing styles + +;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; This file is part of Emacs Muse. It is not part of GNU Emacs. + +;; Emacs Muse is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published +;; by the Free Software Foundation; either version 3, or (at your +;; option) any later version. + +;; Emacs Muse is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with Emacs Muse; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Contributors: + +;;; Code: + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Muse XML Publishing - Common Elements +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(require 'muse-publish) +(require 'muse-regexps) + +(defcustom muse-xml-encoding-map + '((iso-8859-1 . "iso-8859-1") + (iso-2022-jp . "iso-2022-jp") + (utf-8 . "utf-8") + (japanese-iso-8bit . "euc-jp") + (chinese-big5 . "big5") + (mule-utf-8 . "utf-8") + (chinese-iso-8bit . "gb2312") + (chinese-gbk . "gbk")) + "An alist mapping Emacs coding systems to appropriate XML charsets. +Use the base name of the coding system (i.e. without the -unix)." + :type '(alist :key-type coding-system :value-type string) + :group 'muse-xml) + +(defun muse-xml-transform-content-type (content-type default) + "Using `muse-xml-encoding-map', try and resolve an Emacs coding +system to an associated XML coding system. +If no match is found, the DEFAULT charset is used instead." + (let ((match (and (fboundp 'coding-system-base) + (assoc (coding-system-base content-type) + muse-xml-encoding-map)))) + (if match + (cdr match) + default))) + +(defcustom muse-xml-markup-specials + '((?\" . """) + (?\< . "<") + (?\> . ">") + (?\& . "&")) + "A table of characters which must be represented specially." + :type '(alist :key-type character :value-type string) + :group 'muse-xml) + +(defcustom muse-xml-markup-specials-url-extra + '((?\" . """) + (?\< . "<") + (?\> . ">") + (?\& . "&") + (?\ . "%20") + (?\n . "%0D%0A")) + "A table of characters which must be represented specially. +These are extra characters that are escaped within URLs." + :type '(alist :key-type character :value-type string) + :group 'muse-xml) + +(defun muse-xml-decide-specials (context) + "Determine the specials to escape, depending on CONTEXT." + (cond ((memq context '(email url image)) + 'muse-xml-escape-url) + ((eq context 'url-extra) + muse-xml-markup-specials-url-extra) + (t muse-xml-markup-specials))) + +(defun muse-xml-escape-url (str) + "Convert to character entities any non-alphanumeric characters +outside a few punctuation symbols, that risk being misinterpreted +if not escaped." + (when str + (setq str (muse-publish-escape-specials-in-string str 'url-extra)) + (let (pos code len ch) + (save-match-data + (while (setq pos (string-match (concat "[^-" + muse-regexp-alnum + "/:._=@\\?~#%\"\\+<>()&;]") + str pos)) + (setq ch (aref str pos) + code (concat "&#" (int-to-string + (cond ((fboundp 'char-to-ucs) + (char-to-ucs ch)) + ((fboundp 'char-to-int) + (char-to-int ch)) + (t ch))) + ";") + len (length code) + str (concat (substring str 0 pos) + code + (when (< pos (length str)) + (substring str (1+ pos) nil))) + pos (+ len pos))) + str)))) + +(defun muse-xml-markup-anchor () + (unless (get-text-property (match-end 1) 'muse-link) + (let ((text (muse-markup-text 'anchor (match-string 2)))) + (save-match-data + (skip-chars-forward (concat muse-regexp-blank "\n")) + (when (looking-at (concat "<\\([^" muse-regexp-blank "/>\n]+\\)>")) + (goto-char (match-end 0))) + (muse-insert-markup text))) + (match-string 1))) + +(defun muse-xml-sort-table (table) + "Sort the given table structure so that it validates properly." + ;; Note that the decision matrix must have a nil diagonal, or else + ;; elements with the same type will be reversed with respect to each + ;; other. + (let ((decisions '((nil nil nil) ; body < header, body < footer + (t nil t) ; header stays where it is + (t nil nil)))) ; footer < header + (sort table #'(lambda (l r) + (and (integerp (car l)) (integerp (car r)) + (nth (1- (car r)) + (nth (1- (car l)) decisions))))))) + +(defun muse-xml-markup-table (&optional attributes) + "Publish the matched region into a table. +If a string ATTRIBUTES is given, pass it to the markup string begin-table." + (let* ((table-info (muse-publish-table-fields (match-beginning 0) + (match-end 0))) + (row-len (car table-info)) + (supports-group (not (string= (muse-markup-text 'begin-table-group + row-len) + ""))) + (field-list (muse-xml-sort-table (cdr table-info))) + last-part) + (when table-info + (let ((beg (point))) + (muse-publish-ensure-block beg)) + (muse-insert-markup (muse-markup-text 'begin-table (or attributes ""))) + (muse-insert-markup (muse-markup-text 'begin-table-group row-len)) + (dolist (fields field-list) + (let* ((type (car fields)) + (part (cond ((eq type 'hline) nil) + ((= type 1) "tbody") + ((= type 2) "thead") + ((= type 3) "tfoot"))) + (col (cond ((eq type 'hline) nil) + ((= type 1) "td") + ((= type 2) "th") + ((= type 3) "td")))) + (setq fields (cdr fields)) + (unless (and part last-part (string= part last-part)) + (when last-part + (muse-insert-markup " </" last-part ">\n") + (when (eq type 'hline) + ;; horizontal separators are represented by closing + ;; the current table group and opening a new one + (muse-insert-markup (muse-markup-text 'end-table-group)) + (muse-insert-markup (muse-markup-text 'begin-table-group + row-len)))) + (when part + (muse-insert-markup " <" part ">\n")) + (setq last-part part)) + (unless (eq type 'hline) + (muse-insert-markup (muse-markup-text 'begin-table-row)) + (dolist (field fields) + (muse-insert-markup (muse-markup-text 'begin-table-entry col)) + (insert field) + (muse-insert-markup (muse-markup-text 'end-table-entry col))) + (muse-insert-markup (muse-markup-text 'end-table-row))))) + (when last-part + (muse-insert-markup " </" last-part ">\n")) + (muse-insert-markup (muse-markup-text 'end-table-group)) + (muse-insert-markup (muse-markup-text 'end-table)) + (insert ?\n)))) + +(defun muse-xml-prepare-buffer () + (set (make-local-variable 'muse-publish-url-transforms) + (cons 'muse-xml-escape-string muse-publish-url-transforms))) + +(provide 'muse-xml-common) + +;;; muse-xml-common.el ends here |