202 lines
8.1 KiB
EmacsLisp
202 lines
8.1 KiB
EmacsLisp
|
;;; 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
|