2194 lines
87 KiB
EmacsLisp
2194 lines
87 KiB
EmacsLisp
;;; muse-publish.el --- base publishing implementation
|
|
|
|
;; Copyright (C) 2004, 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:
|
|
|
|
;; Yann Hodique (yann DOT hodique AT gmail DOT com) fixed an
|
|
;; unnecessary URL description transform in `muse-publish-url'.
|
|
|
|
;; Peter K. Lee (saint AT corenova DOT com) provided the
|
|
;; `muse-style-elements-list' function.
|
|
|
|
;; Jim Ottaway (j DOT ottaway AT lse DOT ac DOT uk) provided a
|
|
;; reference implementation for nested lists, as well as some code for
|
|
;; the "style" element of the <literal> tag.
|
|
|
|
;; Deus Max (deusmax AT gmail DOT com) provided the <php> tag.
|
|
|
|
;;; Code:
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Muse Publishing
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(provide 'muse-publish)
|
|
|
|
(require 'muse)
|
|
(require 'muse-regexps)
|
|
|
|
(defgroup muse-publish nil
|
|
"Options controlling the general behavior of Muse publishing."
|
|
:group 'muse)
|
|
|
|
(defcustom muse-before-publish-hook nil
|
|
"A hook run in the buffer to be published, before it is done."
|
|
:type 'hook
|
|
:group 'muse-publish)
|
|
|
|
(defcustom muse-after-publish-hook nil
|
|
"A hook run in the buffer to be published, after it is done."
|
|
:type 'hook
|
|
:group 'muse-publish)
|
|
|
|
(defcustom muse-publish-url-transforms
|
|
'(muse-resolve-url)
|
|
"A list of functions used to prepare URLs for publication.
|
|
Each is passed the URL. The transformed URL should be returned."
|
|
:type 'hook
|
|
:options '(muse-resolve-url)
|
|
:group 'muse-publish)
|
|
|
|
(defcustom muse-publish-desc-transforms
|
|
'(muse-publish-strip-URL)
|
|
"A list of functions used to prepare URL desciptions for publication.
|
|
Each is passed the description. The modified description should
|
|
be returned."
|
|
:type 'hook
|
|
:options '(muse-publish-strip-URL)
|
|
:group 'muse-publish)
|
|
|
|
(defcustom muse-publish-date-format "%B %e, %Y"
|
|
"Format string for the date, used by `muse-publish-markup-buffer'.
|
|
See `format-time-string' for details on the format options."
|
|
:type 'string
|
|
:group 'muse-publish)
|
|
|
|
(defcustom muse-publish-comments-p nil
|
|
"If nil, remove comments before publishing.
|
|
If non-nil, publish comments using the markup of the current style."
|
|
:type 'boolean
|
|
:group 'muse-publish)
|
|
|
|
(defcustom muse-publish-report-threshhold 100000
|
|
"If a file is this size or larger, report publishing progress."
|
|
:type 'integer
|
|
:group 'muse-publish)
|
|
|
|
(defcustom muse-publish-markup-regexps
|
|
`(;; Remove leading and trailing whitespace from the file
|
|
(1000 "\\(\\`\n+\\|\n+\\'\\)" 0 "")
|
|
|
|
;; Remove trailing whitespace from all lines
|
|
(1100 ,(concat "[" muse-regexp-blank "]+$") 0 "")
|
|
|
|
;; Handle any leading #directives
|
|
(1200 "\\`#\\([a-zA-Z-]+\\)\\s-+\\(.+\\)\n+" 0 directive)
|
|
|
|
;; commented lines
|
|
(1250 ,(concat "^;\\(?:[" muse-regexp-blank "]+\\(.+\\)\\|$\\|'\\)")
|
|
0 comment)
|
|
|
|
;; markup tags
|
|
(1300 muse-tag-regexp 0 tag)
|
|
|
|
;; prevent emphasis characters in explicit links from being marked
|
|
(1400 muse-explicit-link-regexp 0 muse-publish-mark-link)
|
|
|
|
;; emphasized or literal text
|
|
(1600 ,(concat "\\(^\\|[-[" muse-regexp-blank
|
|
"<('`\"\n]\\)\\(=[^=" muse-regexp-blank
|
|
"\n]\\|_[^_" muse-regexp-blank
|
|
"\n]\\|\\*+[^*" muse-regexp-blank
|
|
"\n]\\)")
|
|
2 word)
|
|
|
|
;; headings, outline-mode style
|
|
(1700 "^\\(\\*+\\)\\s-+" 0 heading)
|
|
|
|
;; ellipses
|
|
(1800 "\\.\\.\\.\\." 0 enddots)
|
|
(1850 "\\.\\.\\." 0 dots)
|
|
|
|
;; horizontal rule, or section separator
|
|
(1900 "^----+" 0 rule)
|
|
|
|
;; non-breaking space
|
|
(1950 "~~" 0 no-break-space)
|
|
|
|
;; beginning of footnotes section
|
|
(2000 "^Footnotes:?\\s-*" 0 fn-sep)
|
|
;; footnote definition/reference (def if at beginning of line)
|
|
(2100 "\\[\\([1-9][0-9]*\\)\\]" 0 footnote)
|
|
|
|
;; unnumbered List items begin with a -. numbered list items
|
|
;; begin with number and a period. definition lists have a
|
|
;; leading term separated from the body with ::. centered
|
|
;; paragraphs begin with at least six columns of whitespace; any
|
|
;; other whitespace at the beginning indicates a blockquote. The
|
|
;; reason all of these rules are handled here, is so that
|
|
;; blockquote detection doesn't interfere with indented list
|
|
;; members.
|
|
(2200 ,(format muse-list-item-regexp (concat "[" muse-regexp-blank "]*"))
|
|
0 list)
|
|
|
|
;; support table.el style tables
|
|
(2300 ,(concat "^" muse-table-el-border-regexp "\n"
|
|
"\\(\\(" muse-table-el-line-regexp "\n\\)+"
|
|
"\\(" muse-table-el-border-regexp "\\)"
|
|
"\\(\n\\|\\'\\)\\)+")
|
|
0 table-el)
|
|
|
|
;; simple table markup is supported, nothing fancy. use | to
|
|
;; separate cells, || to separate header cells, and ||| for footer
|
|
;; cells
|
|
(2350 ,(concat "\\(\\([" muse-regexp-blank "]*\n\\)?"
|
|
"\\(\\(?:" muse-table-line-regexp "\\|"
|
|
muse-table-hline-regexp "\\)\\(?:\n\\|\\'\\)\\)\\)+")
|
|
0 table)
|
|
|
|
;; blockquote and centered text
|
|
(2400 ,(concat "^\\([" muse-regexp-blank "]+\\).+") 0 quote)
|
|
|
|
;; the emdash ("--" or "---")
|
|
(2500 ,(concat "\\(^\\|[" muse-regexp-blank "]*\\)---?\\($\\|["
|
|
muse-regexp-blank "]*\\)")
|
|
0 emdash)
|
|
|
|
;; "verse" text is indicated the same way as a quoted e-mail
|
|
;; response: "> text", where text may contain initial whitespace
|
|
;; (see below).
|
|
(2600 ,(concat "^[" muse-regexp-blank "]*> ") 0 verse)
|
|
|
|
;; define anchor points
|
|
(2700 "^\\(\\W*\\)#\\(\\S-+\\)\\s-*" 0 anchor)
|
|
|
|
;; replace links in the buffer (links to other pages)
|
|
(2900 muse-explicit-link-regexp 0 link)
|
|
|
|
;; bare URLs
|
|
(3000 muse-url-regexp 0 url)
|
|
|
|
;; bare email addresses
|
|
(3500
|
|
"\\([^[]\\)[-a-zA-Z0-9._]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+" 0 email)
|
|
)
|
|
"List of markup rules for publishing a page with Muse.
|
|
The rules given in this variable are invoked first, followed by
|
|
whatever rules are specified by the current style.
|
|
|
|
Each member of the list is either a function, or a list of the form:
|
|
|
|
(REGEXP/SYMBOL TEXT-BEGIN-GROUP REPLACEMENT-TEXT/FUNCTION/SYMBOL)
|
|
|
|
REGEXP is a regular expression, or symbol whose value is a regular
|
|
expression, which is searched for using `re-search-forward'.
|
|
TEXT-BEGIN-GROUP is the matching group within that regexp which
|
|
denotes the beginning of the actual text to be marked up.
|
|
REPLACEMENT-TEXT is a string that will be passed to `replace-match'.
|
|
If it is not a string, but a function, it will be called to determine
|
|
what the replacement text should be (it must return a string). If it
|
|
is a symbol, the value of that symbol should be a string.
|
|
|
|
The replacements are done in order, one rule at a time. Writing
|
|
the regular expressions can be a tricky business. Note that case
|
|
is never ignored. `case-fold-search' is always bound to nil
|
|
while processing the markup rules."
|
|
:type '(repeat (choice
|
|
(list :tag "Markup rule"
|
|
integer
|
|
(choice regexp symbol)
|
|
integer
|
|
(choice string function symbol))
|
|
function))
|
|
:group 'muse-publish)
|
|
|
|
(defcustom muse-publish-markup-functions
|
|
'((directive . muse-publish-markup-directive)
|
|
(comment . muse-publish-markup-comment)
|
|
(anchor . muse-publish-markup-anchor)
|
|
(tag . muse-publish-markup-tag)
|
|
(word . muse-publish-markup-word)
|
|
(emdash . muse-publish-markup-emdash)
|
|
(enddots . muse-publish-markup-enddots)
|
|
(dots . muse-publish-markup-dots)
|
|
(rule . muse-publish-markup-rule)
|
|
(no-break-space . muse-publish-markup-no-break-space)
|
|
(heading . muse-publish-markup-heading)
|
|
(footnote . muse-publish-markup-footnote)
|
|
(fn-sep . muse-publish-markup-fn-sep)
|
|
(list . muse-publish-markup-list)
|
|
(quote . muse-publish-markup-quote)
|
|
(verse . muse-publish-markup-verse)
|
|
(table . muse-publish-markup-table)
|
|
(table-el . muse-publish-markup-table-el)
|
|
(email . muse-publish-markup-email)
|
|
(link . muse-publish-markup-link)
|
|
(url . muse-publish-markup-url))
|
|
"An alist of style types to custom functions for that kind of text.
|
|
|
|
Each member of the list is of the form:
|
|
|
|
(SYMBOL FUNCTION)
|
|
|
|
SYMBOL describes the type of text to associate with this rule.
|
|
`muse-publish-markup-regexps' maps regexps to these symbols.
|
|
|
|
FUNCTION is the function to use to mark up this kind of rule if
|
|
no suitable function is found through the :functions tag of the
|
|
current style."
|
|
:type '(alist :key-type symbol :value-type function)
|
|
:group 'muse-publish)
|
|
|
|
(defcustom muse-publish-markup-tags
|
|
'(("contents" nil t nil muse-publish-contents-tag)
|
|
("verse" t nil nil muse-publish-verse-tag)
|
|
("example" t nil nil muse-publish-example-tag)
|
|
("src" t t nil muse-publish-src-tag)
|
|
("code" t nil nil muse-publish-code-tag)
|
|
("quote" t nil t muse-publish-quote-tag)
|
|
("literal" t t nil muse-publish-literal-tag)
|
|
("verbatim" t nil nil muse-publish-verbatim-tag)
|
|
("br" nil nil nil muse-publish-br-tag)
|
|
("lisp" t t nil muse-publish-lisp-tag)
|
|
("class" t t nil muse-publish-class-tag)
|
|
("div" t t nil muse-publish-div-tag)
|
|
("command" t t nil muse-publish-command-tag)
|
|
("perl" t t nil muse-publish-perl-tag)
|
|
("php" t t nil muse-publish-php-tag)
|
|
("python" t t nil muse-publish-python-tag)
|
|
("ruby" t t nil muse-publish-ruby-tag)
|
|
("comment" t nil nil muse-publish-comment-tag)
|
|
("include" nil t nil muse-publish-include-tag)
|
|
("markup" t t nil muse-publish-mark-up-tag)
|
|
("cite" t t nil muse-publish-cite-tag))
|
|
"A list of tag specifications, for specially marking up text.
|
|
XML-style tags are the best way to add custom markup to Muse.
|
|
This is easily accomplished by customizing this list of markup tags.
|
|
|
|
For each entry, the name of the tag is given, whether it expects
|
|
a closing tag, whether it takes an optional set of attributes,
|
|
whether it is nestable, and a function that performs whatever
|
|
action is desired within the delimited region.
|
|
|
|
The tags themselves are deleted during publishing, before the
|
|
function is called. The function is called with three arguments,
|
|
the beginning and end of the region surrounded by the tags. If
|
|
properties are allowed, they are passed as a third argument in
|
|
the form of an alist. The `end' argument to the function is
|
|
always a marker.
|
|
|
|
Point is always at the beginning of the region within the tags, when
|
|
the function is called. Wherever point is when the function finishes
|
|
is where tag markup will resume.
|
|
|
|
These tag rules are processed once at the beginning of markup, and
|
|
once at the end, to catch any tags which may have been inserted
|
|
in-between."
|
|
:type '(repeat (list (string :tag "Markup tag")
|
|
(boolean :tag "Expect closing tag" :value t)
|
|
(boolean :tag "Parse attributes" :value nil)
|
|
(boolean :tag "Nestable" :value nil)
|
|
function))
|
|
:group 'muse-publish)
|
|
|
|
(defcustom muse-publish-markup-header-footer-tags
|
|
'(("lisp" t t nil muse-publish-lisp-tag)
|
|
("markup" t t nil muse-publish-mark-up-tag))
|
|
"Tags used when publishing headers and footers.
|
|
See `muse-publish-markup-tags' for details."
|
|
:type '(repeat (list (string :tag "Markup tag")
|
|
(boolean :tag "Expect closing tag" :value t)
|
|
(boolean :tag "Parse attributes" :value nil)
|
|
(boolean :tag "Nestable" :value nil)
|
|
function))
|
|
:group 'muse-publish)
|
|
|
|
(defcustom muse-publish-markup-specials nil
|
|
"A table of characters which must be represented specially."
|
|
:type '(alist :key-type character :value-type string)
|
|
:group 'muse-publish)
|
|
|
|
(defcustom muse-publish-enable-local-variables nil
|
|
"If non-nil, interpret local variables in a file when publishing."
|
|
:type 'boolean
|
|
:group 'muse-publish)
|
|
|
|
(defcustom muse-publish-enable-dangerous-tags t
|
|
"If non-nil, publish tags like <lisp> and <command> that can
|
|
call external programs or expose sensitive information.
|
|
Otherwise, ignore tags like this.
|
|
|
|
This is useful to set to nil when the file to publish is coming
|
|
from an untrusted source."
|
|
:type 'boolean
|
|
:group 'muse-publish)
|
|
|
|
(defvar muse-publishing-p nil
|
|
"This is set to t while a page is being published.")
|
|
(defvar muse-batch-publishing-p nil
|
|
"This is set to t while a page is being batch published.")
|
|
(defvar muse-inhibit-before-publish-hook nil
|
|
"This is set to t when publishing a file rather than just a buffer.
|
|
It is used by `muse-publish-markup-buffer'.")
|
|
(defvar muse-publishing-styles nil
|
|
"The publishing styles that Muse recognizes.
|
|
This is automatically generated when loading publishing styles.")
|
|
(defvar muse-publishing-current-file nil
|
|
"The file that is currently being published.")
|
|
(defvar muse-publishing-current-output-path nil
|
|
"The path where the current file will be published to.")
|
|
(defvar muse-publishing-current-style nil
|
|
"The style of the file that is currently being published.")
|
|
(defvar muse-publishing-directives nil
|
|
"An alist of publishing directives from the top of a file.")
|
|
(defvar muse-publish-generate-contents nil
|
|
"Non-nil if a table of contents should be generated.
|
|
If non-nil, it is a cons cell specifying (MARKER . DEPTH), to
|
|
tell where the <contents> was seen, and to what depth the
|
|
contents were requested.")
|
|
(defvar muse-publishing-last-position nil
|
|
"Last position of the point when publishing.
|
|
This is used to make sure that publishing doesn't get stalled.")
|
|
|
|
(defvar muse-publish-inhibit-style-hooks nil
|
|
"If non-nil, do not call the :before or :before-end hooks when publishing.")
|
|
|
|
(defvar muse-publish-use-header-footer-tags nil
|
|
"If non-nil, use `muse-publish-markup-header-footer-tags' for looking up
|
|
tags. Otherwise, use `muse-publish-markup-tags'.")
|
|
|
|
(defvar muse-inhibit-style-tags nil
|
|
"If non-nil, do not search for style-specific tags.
|
|
This is used when publishing headers and footers.")
|
|
|
|
;; Functions for handling style information
|
|
|
|
(defsubst muse-style (&optional style)
|
|
"Resolve the given STYLE into a Muse style, if it is a string."
|
|
(if (null style)
|
|
muse-publishing-current-style
|
|
(if (stringp style)
|
|
(assoc style muse-publishing-styles)
|
|
(muse-assert (consp style))
|
|
style)))
|
|
|
|
(defun muse-define-style (name &rest elements)
|
|
(let ((entry (assoc name muse-publishing-styles)))
|
|
(if entry
|
|
(setcdr entry elements)
|
|
(setq muse-publishing-styles
|
|
(cons (append (list name) elements)
|
|
muse-publishing-styles)))))
|
|
|
|
(defun muse-derive-style (new-name base-name &rest elements)
|
|
(apply 'muse-define-style new-name
|
|
(append elements (list :base base-name))))
|
|
|
|
(defsubst muse-get-keyword (keyword list &optional direct)
|
|
(let ((value (cadr (memq keyword list))))
|
|
(if (and (not direct) (symbolp value))
|
|
(symbol-value value)
|
|
value)))
|
|
|
|
(defun muse-style-elements-list (elem &optional style)
|
|
"Return a list all references to ELEM in STYLE, including base styles.
|
|
If STYLE is not specified, use current style."
|
|
(let (base elements)
|
|
(while style
|
|
(setq style (muse-style style))
|
|
(setq elements (append elements
|
|
(muse-get-keyword elem style)))
|
|
(setq style (muse-get-keyword :base style)))
|
|
elements))
|
|
|
|
(defun muse-style-element (elem &optional style direct)
|
|
"Search for ELEM in STYLE, including base styles.
|
|
If STYLE is not specified, use current style."
|
|
(setq style (muse-style style))
|
|
(let ((value (muse-get-keyword elem style direct)))
|
|
(if value
|
|
value
|
|
(let ((base (muse-get-keyword :base style)))
|
|
(if base
|
|
(muse-style-element elem base direct))))))
|
|
|
|
(defun muse-style-derived-p-1 (base style)
|
|
"Internal function used by `muse-style-derived-p'."
|
|
(if (and (stringp style)
|
|
(string= style base))
|
|
t
|
|
(setq style (muse-style style))
|
|
(let ((value (muse-get-keyword :base style)))
|
|
(when value
|
|
(muse-style-derived-p base value)))))
|
|
|
|
(defun muse-style-derived-p (base &optional style)
|
|
"Return non-nil if STYLE is equal to or derived from BASE,
|
|
non-nil otherwise.
|
|
|
|
BASE should be a string."
|
|
(unless style
|
|
(setq style (muse-style)))
|
|
(when (and (consp style)
|
|
(stringp (car style)))
|
|
(setq style (car style)))
|
|
(muse-style-derived-p-1 base style))
|
|
|
|
(defun muse-find-markup-element (keyword ident style)
|
|
(let ((def (assq ident (muse-style-element keyword style))))
|
|
(if def
|
|
(cdr def)
|
|
(let ((base (muse-style-element :base style)))
|
|
(if base
|
|
(muse-find-markup-element keyword ident base))))))
|
|
|
|
(defun muse-markup-text (ident &rest args)
|
|
"Insert ARGS into the text markup associated with IDENT.
|
|
If the markup text has sections like %N%, this will be replaced
|
|
with the N-1th argument in ARGS. After that, `format' is applied
|
|
to the text with ARGS as parameters."
|
|
(let ((text (muse-find-markup-element :strings ident (muse-style))))
|
|
(if (and text args)
|
|
(progn
|
|
(let (start repl-text)
|
|
(while (setq start (string-match "%\\([1-9][0-9]*\\)%" text start))
|
|
;; escape '%' in the argument text, since we will be
|
|
;; using format on it
|
|
(setq repl-text (muse-replace-regexp-in-string
|
|
"%" "%%"
|
|
(nth (1- (string-to-number
|
|
(match-string 1 text))) args)
|
|
t t)
|
|
start (+ start (length repl-text))
|
|
text (replace-match repl-text t t text))))
|
|
(apply 'format text args))
|
|
(or text ""))))
|
|
|
|
(defun muse-insert-markup (&rest args)
|
|
(let ((beg (point)))
|
|
(apply 'insert args)
|
|
(muse-publish-mark-read-only beg (point))))
|
|
|
|
(defun muse-find-markup-tag (keyword tagname style)
|
|
(let ((def (assoc tagname (muse-style-element keyword style))))
|
|
(or def
|
|
(let ((base (muse-style-element :base style)))
|
|
(if base
|
|
(muse-find-markup-tag keyword tagname base))))))
|
|
|
|
(defun muse-markup-tag-info (tagname &rest args)
|
|
(let ((tag-info (and (not muse-inhibit-style-tags)
|
|
(muse-find-markup-tag :tags tagname (muse-style)))))
|
|
(or tag-info
|
|
(assoc tagname
|
|
(if muse-publish-use-header-footer-tags
|
|
muse-publish-markup-header-footer-tags
|
|
muse-publish-markup-tags)))))
|
|
|
|
(defsubst muse-markup-function (category)
|
|
(let ((func (muse-find-markup-element :functions category (muse-style))))
|
|
(or func
|
|
(cdr (assq category muse-publish-markup-functions)))))
|
|
|
|
;; Publishing routines
|
|
|
|
(defun muse-publish-markup (name rules)
|
|
(let* ((case-fold-search nil)
|
|
(inhibit-read-only t)
|
|
(limit (* (length rules) (point-max)))
|
|
(verbose (and muse-publish-report-threshhold
|
|
(> (point-max) muse-publish-report-threshhold)))
|
|
(base 0))
|
|
(while rules
|
|
(goto-char (point-min))
|
|
(let ((regexp (nth 1 (car rules)))
|
|
(group (nth 2 (car rules)))
|
|
(repl (nth 3 (car rules)))
|
|
pos)
|
|
(setq muse-publishing-last-position nil)
|
|
(if (symbolp regexp)
|
|
(setq regexp (symbol-value regexp)))
|
|
(if (and verbose (not muse-batch-publishing-p))
|
|
(message "Publishing %s...%d%%" name
|
|
(* (/ (float (+ (point) base)) limit) 100)))
|
|
(while (and regexp (progn
|
|
(when (and (get-text-property (point) 'read-only)
|
|
(> (point) (point-min)))
|
|
(goto-char (or (next-single-property-change
|
|
(point) 'read-only)
|
|
(point-max))))
|
|
(setq pos (re-search-forward regexp nil t))))
|
|
(if (and verbose (not muse-batch-publishing-p))
|
|
(message "Publishing %s...%d%%" name
|
|
(* (/ (float (+ (point) base)) limit) 100)))
|
|
(unless (and (> (- (match-end 0) (match-beginning 0)) 0)
|
|
(match-beginning group)
|
|
(get-text-property (match-beginning group) 'read-only))
|
|
(let* (func
|
|
(text (cond
|
|
((and (symbolp repl)
|
|
(setq func (muse-markup-function repl)))
|
|
(funcall func))
|
|
((functionp repl)
|
|
(funcall repl))
|
|
((symbolp repl)
|
|
(symbol-value repl))
|
|
(t repl))))
|
|
(if (stringp text)
|
|
(replace-match text t))))
|
|
(if (and muse-publishing-last-position
|
|
(= pos muse-publishing-last-position))
|
|
(if (eobp)
|
|
(setq regexp nil)
|
|
(forward-char 1)))
|
|
(setq muse-publishing-last-position pos)))
|
|
(setq rules (cdr rules)
|
|
base (+ base (point-max))))
|
|
(if (and verbose (not muse-batch-publishing-p))
|
|
(message "Publishing %s...done" name))))
|
|
|
|
(defun muse-insert-file-or-string (file-or-string &optional title)
|
|
(let ((beg (point)) end)
|
|
(if (and (not (string-equal file-or-string ""))
|
|
(not (string-match "\n" file-or-string))
|
|
(file-readable-p file-or-string))
|
|
(setq end (+ beg
|
|
(cadr (muse-insert-file-contents file-or-string))))
|
|
(insert file-or-string)
|
|
(setq end (point)))
|
|
(save-restriction
|
|
(narrow-to-region beg end)
|
|
(remove-text-properties (point-min) (point-max)
|
|
'(read-only nil rear-nonsticky nil))
|
|
(goto-char (point-min))
|
|
(let ((muse-inhibit-style-tags t)
|
|
(muse-publish-use-header-footer-tags t))
|
|
(muse-publish-markup (or title "")
|
|
'((100 muse-tag-regexp 0
|
|
muse-publish-markup-tag)))))))
|
|
|
|
(defun muse-style-run-hooks (keyword style &rest args)
|
|
(catch 'handled
|
|
(let ((cache nil))
|
|
(while (and style
|
|
(setq style (muse-style style)))
|
|
(let ((func (muse-style-element keyword style t)))
|
|
(when (and func
|
|
(not (member func cache)))
|
|
(setq cache (cons func cache))
|
|
(when (apply func args)
|
|
(throw 'handled t))))
|
|
(setq style (muse-style-element :base style))))))
|
|
|
|
(defun muse-publish-markup-region (beg end &optional title style)
|
|
"Apply the given STYLE's markup rules to the given region.
|
|
TITLE is used when indicating the publishing progress; it may be nil.
|
|
|
|
The point is guaranteed to be at END if the routine terminates
|
|
normally."
|
|
(unless title (setq title ""))
|
|
(unless style
|
|
(or (setq style muse-publishing-current-style)
|
|
(error "Cannot find any publishing styles to use")))
|
|
(save-restriction
|
|
(narrow-to-region beg end)
|
|
(let ((muse-publish-generate-contents nil))
|
|
(unless muse-publish-inhibit-style-hooks
|
|
(muse-style-run-hooks :before style))
|
|
(muse-publish-markup
|
|
title
|
|
(sort (copy-alist (append muse-publish-markup-regexps
|
|
(muse-style-elements-list :regexps style)))
|
|
(function
|
|
(lambda (l r)
|
|
(< (car l) (car r))))))
|
|
(unless muse-publish-inhibit-style-hooks
|
|
(muse-style-run-hooks :before-end style))
|
|
(muse-publish-escape-specials (point-min) (point-max) nil 'document))
|
|
(goto-char (point-max))))
|
|
|
|
(defun muse-publish-markup-buffer (title style)
|
|
"Apply the given STYLE's markup rules to the current buffer."
|
|
(setq style (muse-style style))
|
|
(let ((style-header (muse-style-element :header style))
|
|
(style-footer (muse-style-element :footer style))
|
|
(muse-publishing-current-style style)
|
|
(muse-publishing-directives
|
|
(list (cons "title" title)
|
|
(cons "author" (user-full-name))
|
|
(cons "date" (format-time-string
|
|
muse-publish-date-format
|
|
(if muse-publishing-current-file
|
|
(nth 5 (file-attributes
|
|
muse-publishing-current-file))
|
|
(current-time))))))
|
|
(muse-publishing-p t)
|
|
(inhibit-read-only t))
|
|
(run-hooks 'muse-update-values-hook)
|
|
(unless muse-inhibit-before-publish-hook
|
|
(run-hooks 'muse-before-publish-hook))
|
|
(muse-publish-markup-region (point-min) (point-max) title style)
|
|
(goto-char (point-min))
|
|
(when style-header
|
|
(muse-insert-file-or-string style-header title))
|
|
(goto-char (point-max))
|
|
(when style-footer
|
|
(muse-insert-file-or-string style-footer title))
|
|
(muse-style-run-hooks :after style)
|
|
(run-hooks 'muse-after-publish-hook)))
|
|
|
|
(defun muse-publish-markup-string (string &optional style)
|
|
"Markup STRING using the given STYLE's markup rules."
|
|
(setq style (muse-style style))
|
|
(muse-with-temp-buffer
|
|
(insert string)
|
|
(let ((muse-publishing-current-style style)
|
|
(muse-publishing-p t))
|
|
(muse-publish-markup "*string*" (muse-style-element :rules style)))
|
|
(buffer-string)))
|
|
|
|
;; Commands for publishing files
|
|
|
|
(defun muse-publish-get-style (&optional styles)
|
|
(unless styles (setq styles muse-publishing-styles))
|
|
(if (= 1 (length styles))
|
|
(car styles)
|
|
(when (catch 'different
|
|
(let ((first (car (car styles))))
|
|
(dolist (style (cdr styles))
|
|
(unless (equal first (car style))
|
|
(throw 'different t)))))
|
|
(setq styles (muse-collect-alist
|
|
styles
|
|
(funcall muse-completing-read-function
|
|
"Publish with style: " styles nil t))))
|
|
(if (or (= 1 (length styles))
|
|
(not (muse-get-keyword :path (car styles))))
|
|
(car styles)
|
|
(setq styles (mapcar (lambda (style)
|
|
(cons (muse-get-keyword :path style)
|
|
style))
|
|
styles))
|
|
(cdr (assoc (funcall muse-completing-read-function
|
|
"Publish to directory: " styles nil t)
|
|
styles)))))
|
|
|
|
(defsubst muse-publish-get-output-dir (style)
|
|
(let ((default-directory (or (muse-style-element :path style)
|
|
default-directory)))
|
|
(muse-read-directory-name "Publish to directory: " nil default-directory)))
|
|
|
|
(defsubst muse-publish-get-info ()
|
|
(let ((style (muse-publish-get-style)))
|
|
(list style (muse-publish-get-output-dir style)
|
|
current-prefix-arg)))
|
|
|
|
(defsubst muse-publish-output-name (&optional file style)
|
|
(setq style (muse-style style))
|
|
(concat (muse-style-element :prefix style)
|
|
(muse-page-name file)
|
|
(muse-style-element :suffix style)))
|
|
|
|
(defsubst muse-publish-output-file (file &optional output-dir style)
|
|
(setq style (muse-style style))
|
|
(if output-dir
|
|
(expand-file-name (muse-publish-output-name file style) output-dir)
|
|
(concat (file-name-directory file)
|
|
(muse-publish-output-name file style))))
|
|
|
|
(defsubst muse-publish-link-name (&optional file style)
|
|
"Take FILE and add :prefix and either :link-suffix or :suffix from STYLE.
|
|
We assume that FILE is a Muse file.
|
|
|
|
We call `muse-page-name' on FILE to remove the directory part of
|
|
FILE and any extensions that are in `muse-ignored-extensions'."
|
|
(setq style (muse-style style))
|
|
(concat (muse-style-element :prefix style)
|
|
(muse-page-name file)
|
|
(or (muse-style-element :link-suffix style)
|
|
(muse-style-element :suffix style))))
|
|
|
|
(defsubst muse-publish-link-file (file &optional style)
|
|
"Turn FILE into a URL.
|
|
|
|
If FILE exists on the system as-is, return it without
|
|
modification. In the case of wanting to link to Muse files when
|
|
`muse-file-extension' is nil, you should load muse-project.el.
|
|
|
|
Otherwise, assume that it is a Muse file and call
|
|
`muse-publish-link-name' to add :prefix, :link-suffix, :suffix,
|
|
and removing ignored file extensions, but preserving the
|
|
directory part of FILE."
|
|
(setq style (muse-style style))
|
|
(if (file-exists-p file)
|
|
file
|
|
(concat (file-name-directory file)
|
|
(muse-publish-link-name file style))))
|
|
|
|
(defsubst muse-publish-link-page (page)
|
|
"Turn PAGE into a URL.
|
|
|
|
This is called by `muse-publish-classify-url' to figure out what
|
|
a link to another file or Muse page should look like.
|
|
|
|
If muse-project.el is loaded, call `muse-project-link-page' for this.
|
|
Otherwise, call `muse-publish-link-file'."
|
|
(if (fboundp 'muse-project-link-page)
|
|
(muse-project-link-page page)
|
|
(muse-publish-link-file page)))
|
|
|
|
(defmacro muse-publish-ensure-block (beg &optional end)
|
|
"Ensure that block-level markup at BEG is published with at least one
|
|
preceding blank line. BEG must be an unquoted symbol that contains a
|
|
position or marker. BEG is modified to be the new position.
|
|
The point is left at the new value of BEG.
|
|
|
|
Additionally, make sure that BEG is placed on a blank line.
|
|
|
|
If END is given, make sure that it is placed on a blank line. In
|
|
order to achieve this, END must be an unquoted symbol that
|
|
contains a marker. This is the case with Muse tag functions."
|
|
`(progn
|
|
(goto-char ,beg)
|
|
(cond ((not (bolp)) (insert "\n\n"))
|
|
((eq (point) (point-min)) nil)
|
|
((prog2 (backward-char) (bolp) (forward-char)) nil)
|
|
(t (insert "\n")))
|
|
(unless (and (bolp) (eolp))
|
|
(insert "\n")
|
|
(backward-char))
|
|
(setq ,beg (point))
|
|
(when (markerp ,end)
|
|
(goto-char ,end)
|
|
(unless (and (bolp) (eolp))
|
|
(insert-before-markers "\n")))
|
|
(goto-char ,beg)))
|
|
|
|
;;;###autoload
|
|
(defun muse-publish-region (beg end &optional title style)
|
|
"Apply the given STYLE's markup rules to the given region.
|
|
The result is placed in a new buffer that includes TITLE in its name."
|
|
(interactive "r")
|
|
(when (interactive-p)
|
|
(unless title (setq title (read-string "Title: ")))
|
|
(unless style (setq style (muse-publish-get-style))))
|
|
(let ((text (buffer-substring beg end))
|
|
(buf (generate-new-buffer (concat "*Muse: " title "*"))))
|
|
(with-current-buffer buf
|
|
(insert text)
|
|
(muse-publish-markup-buffer title style)
|
|
(goto-char (point-min))
|
|
(let ((inhibit-read-only t))
|
|
(remove-text-properties (point-min) (point-max)
|
|
'(rear-nonsticky nil read-only nil))))
|
|
(pop-to-buffer buf)))
|
|
|
|
;;;###autoload
|
|
(defun muse-publish-file (file style &optional output-dir force)
|
|
"Publish the given FILE in a particular STYLE to OUTPUT-DIR.
|
|
If the argument FORCE is nil, each file is only published if it is
|
|
newer than the published version. If the argument FORCE is non-nil,
|
|
the file is published no matter what."
|
|
(interactive (cons (read-file-name "Publish file: ")
|
|
(muse-publish-get-info)))
|
|
(let ((style-name style))
|
|
(setq style (muse-style style))
|
|
(unless style
|
|
(error "There is no style '%s' defined" style-name)))
|
|
(let* ((output-path (muse-publish-output-file file output-dir style))
|
|
(output-suffix (muse-style-element :osuffix style))
|
|
(muse-publishing-current-file file)
|
|
(muse-publishing-current-output-path output-path)
|
|
(target (if output-suffix
|
|
(concat (muse-path-sans-extension output-path)
|
|
output-suffix)
|
|
output-path))
|
|
(threshhold (nth 7 (file-attributes file))))
|
|
(if (not threshhold)
|
|
(message "Please save %s before publishing" file)
|
|
(when (or force (file-newer-than-file-p file target))
|
|
(if (and muse-publish-report-threshhold
|
|
(> threshhold
|
|
muse-publish-report-threshhold))
|
|
(message "Publishing %s ..." file))
|
|
(muse-with-temp-buffer
|
|
(muse-insert-file-contents file)
|
|
(run-hooks 'muse-before-publish-hook)
|
|
(when muse-publish-enable-local-variables
|
|
(hack-local-variables))
|
|
(let ((muse-inhibit-before-publish-hook t))
|
|
(muse-publish-markup-buffer (muse-page-name file) style))
|
|
(when (muse-write-file output-path)
|
|
(muse-style-run-hooks :final style file output-path target)))
|
|
t))))
|
|
|
|
;;;###autoload
|
|
(defun muse-publish-this-file (style output-dir &optional force)
|
|
"Publish the currently-visited file.
|
|
Prompt for both the STYLE and OUTPUT-DIR if they are not
|
|
supplied."
|
|
(interactive (muse-publish-get-info))
|
|
(setq style (muse-style style))
|
|
(if buffer-file-name
|
|
(let ((muse-current-output-style (list :base (car style)
|
|
:path output-dir)))
|
|
(unless (muse-publish-file buffer-file-name style output-dir force)
|
|
(message (concat "The published version is up-to-date; use"
|
|
" C-u C-c C-T to force an update."))))
|
|
(message "This buffer is not associated with any file")))
|
|
|
|
(defun muse-batch-publish-files ()
|
|
"Publish Muse files in batch mode."
|
|
(let ((muse-batch-publishing-p t)
|
|
(font-lock-verbose nil)
|
|
muse-current-output-style
|
|
style output-dir)
|
|
;; don't activate VC when publishing files
|
|
(setq vc-handled-backends nil)
|
|
(setq style (car command-line-args-left)
|
|
command-line-args-left (cdr command-line-args-left)
|
|
output-dir (car command-line-args-left)
|
|
output-dir
|
|
(if (string-match "\\`--output-dir=" output-dir)
|
|
(prog1
|
|
(substring output-dir (match-end 0))
|
|
(setq command-line-args-left (cdr command-line-args-left))))
|
|
muse-current-output-style (list :base style :path output-dir))
|
|
(setq auto-mode-alist
|
|
(delete (cons (concat "\\." muse-file-extension "\\'")
|
|
'muse-mode-choose-mode)
|
|
auto-mode-alist))
|
|
(dolist (file command-line-args-left)
|
|
(muse-publish-file file style output-dir t))))
|
|
|
|
;; Default publishing rules
|
|
|
|
(defun muse-publish-section-close (depth)
|
|
"Seach forward for the closing tag of given DEPTH."
|
|
(let (not-end)
|
|
(save-excursion
|
|
(while (and (setq not-end (re-search-forward
|
|
(concat "^\\*\\{1," (number-to-string depth)
|
|
"\\}\\s-+")
|
|
nil t))
|
|
(get-text-property (match-beginning 0) 'read-only)))
|
|
(if not-end
|
|
(forward-line 0)
|
|
(goto-char (point-max)))
|
|
(cond ((not (eq (char-before) ?\n))
|
|
(insert "\n\n"))
|
|
((not (eq (char-before (1- (point))) ?\n))
|
|
(insert "\n")))
|
|
(muse-insert-markup (muse-markup-text 'section-close depth))
|
|
(insert "\n"))))
|
|
|
|
(defun muse-publish-markup-directive (&optional name value)
|
|
(unless name (setq name (match-string 1)))
|
|
(unless value (setq value (match-string 2)))
|
|
(let ((elem (assoc name muse-publishing-directives)))
|
|
(if elem
|
|
(setcdr elem value)
|
|
(setq muse-publishing-directives
|
|
(cons (cons name value)
|
|
muse-publishing-directives))))
|
|
;; Make sure we don't ever try to move the point forward (past the
|
|
;; beginning of buffer) while we're still searching for directives.
|
|
(setq muse-publishing-last-position nil)
|
|
(delete-region (match-beginning 0) (match-end 0)))
|
|
|
|
(defsubst muse-publishing-directive (name)
|
|
(cdr (assoc name muse-publishing-directives)))
|
|
|
|
(defmacro muse-publish-get-and-delete-attr (attr attrs)
|
|
"Delete attribute ATTR from ATTRS only once, destructively.
|
|
|
|
This function returns the matching attribute value, if found."
|
|
(let ((last (make-symbol "last"))
|
|
(found (make-symbol "found"))
|
|
(vals (make-symbol "vals")))
|
|
`(let ((,vals ,attrs))
|
|
(if (string= (caar ,vals) ,attr)
|
|
(prog1 (cdar ,vals)
|
|
(setq ,attrs (cdr ,vals)))
|
|
(let ((,last ,vals)
|
|
(,found nil))
|
|
(while ,vals
|
|
(setq ,vals (cdr ,vals))
|
|
(when (string= (caar ,vals) ,attr)
|
|
(setq ,found (cdar ,vals))
|
|
(setcdr ,last (cdr ,vals))
|
|
(setq ,vals nil))
|
|
(setq ,last ,vals))
|
|
,found)))))
|
|
|
|
(defun muse-publish-markup-anchor ()
|
|
(unless (get-text-property (match-end 1) 'muse-link)
|
|
(let ((text (muse-markup-text 'anchor (match-string 2))))
|
|
(unless (string= text "")
|
|
(save-match-data
|
|
(skip-chars-forward (concat muse-regexp-blank "\n"))
|
|
(muse-insert-markup text)))
|
|
(match-string 1))))
|
|
|
|
(defun muse-publish-markup-comment ()
|
|
(if (null muse-publish-comments-p)
|
|
""
|
|
(goto-char (match-end 0))
|
|
(muse-insert-markup (muse-markup-text 'comment-end))
|
|
(if (match-beginning 1)
|
|
(progn
|
|
(muse-publish-mark-read-only (match-beginning 1) (match-end 1))
|
|
(delete-region (match-beginning 0) (match-beginning 1)))
|
|
(delete-region (match-beginning 0) (match-end 0)))
|
|
(goto-char (match-beginning 0))
|
|
(muse-insert-markup (muse-markup-text 'comment-begin))))
|
|
|
|
(defun muse-publish-markup-tag ()
|
|
(let ((tag-info (muse-markup-tag-info (match-string 1))))
|
|
(when (and tag-info
|
|
(not (get-text-property (match-beginning 0) 'read-only))
|
|
(nth 4 tag-info)
|
|
(or muse-publish-enable-dangerous-tags
|
|
(not (get (nth 4 tag-info) 'muse-dangerous-tag))))
|
|
(let ((closed-tag (match-string 3))
|
|
(start (match-beginning 0))
|
|
(beg (point))
|
|
end attrs)
|
|
(when (nth 2 tag-info)
|
|
(let ((attrstr (match-string 2)))
|
|
(while (and attrstr
|
|
(string-match (concat "\\([^"
|
|
muse-regexp-blank
|
|
"=\n]+\\)\\(=\"\\"
|
|
"([^\"]+\\)\"\\)?")
|
|
attrstr))
|
|
(let ((attr (cons (downcase
|
|
(muse-match-string-no-properties 1 attrstr))
|
|
(muse-match-string-no-properties 3 attrstr))))
|
|
(setq attrstr (replace-match "" t t attrstr))
|
|
(if attrs
|
|
(nconc attrs (list attr))
|
|
(setq attrs (list attr)))))))
|
|
(if (and (cadr tag-info) (not closed-tag))
|
|
(if (muse-goto-tag-end (car tag-info) (nth 3 tag-info))
|
|
(delete-region (match-beginning 0) (point))
|
|
(setq tag-info nil)))
|
|
(when tag-info
|
|
(setq end (point-marker))
|
|
(delete-region start beg)
|
|
(goto-char start)
|
|
(let ((args (list start end)))
|
|
(if (nth 2 tag-info)
|
|
(nconc args (list attrs)))
|
|
(let ((muse-inhibit-style-tags nil))
|
|
;; remove the inhibition
|
|
(apply (nth 4 tag-info) args)))
|
|
(set-marker end nil)))))
|
|
nil)
|
|
|
|
(defun muse-publish-escape-specials (beg end &optional ignore-read-only context)
|
|
"Escape specials from BEG to END using style-specific :specials.
|
|
If IGNORE-READ-ONLY is non-nil, ignore the read-only property.
|
|
CONTEXT is used to figure out what kind of specials to escape.
|
|
|
|
The following contexts exist in Muse.
|
|
'underline _underlined text_
|
|
'literal =monospaced text= or <code> region (monospaced, escaped)
|
|
'emphasis *emphasized text*
|
|
'email email@example.com
|
|
'url http://example.com
|
|
'url-desc [[...][description of an explicit link]]
|
|
'image [[image.png]]
|
|
'example <example> region (monospaced, block context, escaped)
|
|
'verbatim <verbatim> region (escaped)
|
|
'footnote footnote text
|
|
'document normal text"
|
|
(let ((specials (muse-style-element :specials nil t)))
|
|
(cond ((functionp specials)
|
|
(setq specials (funcall specials context)))
|
|
((symbolp specials)
|
|
(setq specials (symbol-value specials))))
|
|
(if (functionp specials)
|
|
(funcall specials beg end ignore-read-only)
|
|
(save-excursion
|
|
(save-restriction
|
|
(narrow-to-region beg end)
|
|
(goto-char (point-min))
|
|
(while (< (point) (point-max))
|
|
(if (and (not ignore-read-only)
|
|
(get-text-property (point) 'read-only))
|
|
(goto-char (or (next-single-property-change (point) 'read-only)
|
|
(point-max)))
|
|
(let ((repl (or (assoc (char-after) specials)
|
|
(assoc (char-after)
|
|
muse-publish-markup-specials))))
|
|
(if (null repl)
|
|
(forward-char 1)
|
|
(delete-char 1)
|
|
(insert-before-markers (cdr repl)))))))))))
|
|
|
|
(defun muse-publish-markup-word ()
|
|
(let* ((beg (match-beginning 2))
|
|
(end (1- (match-end 2)))
|
|
(leader (buffer-substring-no-properties beg end))
|
|
open-tag close-tag mark-read-only loc context)
|
|
(cond
|
|
((string= leader "_")
|
|
(setq context 'underline
|
|
open-tag (muse-markup-text 'begin-underline)
|
|
close-tag (muse-markup-text 'end-underline)))
|
|
((string= leader "=")
|
|
(setq context 'literal
|
|
open-tag (muse-markup-text 'begin-literal)
|
|
close-tag (muse-markup-text 'end-literal))
|
|
(setq mark-read-only t))
|
|
(t
|
|
(let ((l (length leader)))
|
|
(setq context 'emphasis)
|
|
(cond
|
|
((= l 1) (setq open-tag (muse-markup-text 'begin-emph)
|
|
close-tag (muse-markup-text 'end-emph)))
|
|
((= l 2) (setq open-tag (muse-markup-text 'begin-more-emph)
|
|
close-tag (muse-markup-text 'end-more-emph)))
|
|
((= l 3) (setq open-tag (muse-markup-text 'begin-most-emph)
|
|
close-tag (muse-markup-text 'end-most-emph)))
|
|
(t (setq context nil))))))
|
|
(if (and context
|
|
(not (get-text-property beg 'muse-link))
|
|
(setq loc (search-forward leader nil t))
|
|
(or (eobp) (not (eq (char-syntax (char-after loc)) ?w)))
|
|
(not (eq (char-syntax (char-before (point))) ?\ ))
|
|
(not (get-text-property (point) 'muse-link)))
|
|
(progn
|
|
(replace-match "")
|
|
(delete-region beg end)
|
|
(setq end (point-marker))
|
|
(muse-insert-markup close-tag)
|
|
(goto-char beg)
|
|
(muse-insert-markup open-tag)
|
|
(setq beg (point))
|
|
(when mark-read-only
|
|
(muse-publish-escape-specials beg end t context)
|
|
(muse-publish-mark-read-only beg end))
|
|
(set-marker end nil))
|
|
(backward-char))
|
|
nil))
|
|
|
|
(defun muse-publish-markup-emdash ()
|
|
(unless (get-text-property (match-beginning 0) 'muse-link)
|
|
(let ((prespace (match-string 1))
|
|
(postspace (match-string 2)))
|
|
(delete-region (match-beginning 0) (match-end 0))
|
|
(muse-insert-markup (muse-markup-text 'emdash prespace postspace))
|
|
(when (eq (char-after) ?\<)
|
|
(insert ?\n)))))
|
|
|
|
(defun muse-publish-markup-enddots ()
|
|
(unless (get-text-property (match-beginning 0) 'muse-link)
|
|
(delete-region (match-beginning 0) (match-end 0))
|
|
(muse-insert-markup (muse-markup-text 'enddots))))
|
|
|
|
(defun muse-publish-markup-dots ()
|
|
(unless (get-text-property (match-beginning 0) 'muse-link)
|
|
(delete-region (match-beginning 0) (match-end 0))
|
|
(muse-insert-markup (muse-markup-text 'dots))))
|
|
|
|
(defun muse-publish-markup-rule ()
|
|
(unless (get-text-property (match-beginning 0) 'muse-link)
|
|
(delete-region (match-beginning 0) (match-end 0))
|
|
(muse-insert-markup (muse-markup-text 'rule))))
|
|
|
|
(defun muse-publish-markup-no-break-space ()
|
|
(unless (get-text-property (match-beginning 0) 'muse-link)
|
|
(delete-region (match-beginning 0) (match-end 0))
|
|
(muse-insert-markup (muse-markup-text 'no-break-space))))
|
|
|
|
(defun muse-publish-markup-heading ()
|
|
(let* ((len (length (match-string 1)))
|
|
(start (muse-markup-text
|
|
(cond ((= len 1) 'section)
|
|
((= len 2) 'subsection)
|
|
((= len 3) 'subsubsection)
|
|
(t 'section-other))
|
|
len))
|
|
(end (muse-markup-text
|
|
(cond ((= len 1) 'section-end)
|
|
((= len 2) 'subsection-end)
|
|
((= len 3) 'subsubsection-end)
|
|
(t 'section-other-end))
|
|
len)))
|
|
(delete-region (match-beginning 0) (match-end 0))
|
|
(muse-insert-markup start)
|
|
(end-of-line)
|
|
(when end
|
|
(muse-insert-markup end))
|
|
(forward-line 1)
|
|
(unless (eq (char-after) ?\n)
|
|
(insert "\n"))
|
|
(muse-publish-section-close len)))
|
|
|
|
(defvar muse-publish-footnotes nil)
|
|
|
|
(defun muse-publish-markup-footnote ()
|
|
"Scan ahead and snarf up the footnote body."
|
|
(cond
|
|
((get-text-property (match-beginning 0) 'muse-link)
|
|
nil)
|
|
((= (muse-line-beginning-position) (match-beginning 0))
|
|
"")
|
|
(t
|
|
(let ((footnote (save-match-data
|
|
(string-to-number (match-string 1))))
|
|
(oldtext (match-string 0))
|
|
footnotemark)
|
|
(delete-region (match-beginning 0) (match-end 0))
|
|
(save-excursion
|
|
(when (re-search-forward (format "^\\[%d\\]\\s-+" footnote) nil t)
|
|
(let* ((start (match-beginning 0))
|
|
(beg (goto-char (match-end 0)))
|
|
(end (save-excursion
|
|
(if (search-forward "\n\n" nil t)
|
|
(copy-marker (match-beginning 0))
|
|
(goto-char (point-max))
|
|
(skip-chars-backward "\n")
|
|
(point-marker)))))
|
|
(while (re-search-forward
|
|
(concat "^[" muse-regexp-blank "]+\\([^\n]\\)")
|
|
end t)
|
|
(replace-match "\\1" t))
|
|
(let ((footnotemark-cmd (muse-markup-text 'footnotemark))
|
|
(footnotemark-end-cmd (muse-markup-text 'footnotemark-end)))
|
|
(if (string= "" footnotemark-cmd)
|
|
(setq footnotemark
|
|
(concat (muse-markup-text 'footnote)
|
|
(muse-publish-escape-specials-in-string
|
|
(buffer-substring-no-properties beg end)
|
|
'footnote)
|
|
(muse-markup-text 'footnote-end)))
|
|
(setq footnotemark (format footnotemark-cmd footnote
|
|
footnotemark-end-cmd))
|
|
(unless muse-publish-footnotes
|
|
(set (make-local-variable 'muse-publish-footnotes)
|
|
(make-vector 256 nil)))
|
|
(unless (aref muse-publish-footnotes footnote)
|
|
(setq footnotemark
|
|
(concat
|
|
footnotemark
|
|
(concat (format (muse-markup-text 'footnotetext)
|
|
footnote)
|
|
(buffer-substring-no-properties beg end)
|
|
(muse-markup-text 'footnotetext-end))))
|
|
(aset muse-publish-footnotes footnote footnotemark))))
|
|
(goto-char end)
|
|
(skip-chars-forward "\n")
|
|
(delete-region start (point))
|
|
(set-marker end nil))))
|
|
(if footnotemark
|
|
(muse-insert-markup footnotemark)
|
|
(insert oldtext))))))
|
|
|
|
(defun muse-publish-markup-fn-sep ()
|
|
(delete-region (match-beginning 0) (match-end 0))
|
|
(muse-insert-markup (muse-markup-text 'fn-sep)))
|
|
|
|
(defun muse-insert-markup-end-list (&rest args)
|
|
(let ((beg (point)))
|
|
(apply 'insert args)
|
|
(add-text-properties beg (point) '(muse-end-list t))
|
|
(muse-publish-mark-read-only beg (point))))
|
|
|
|
(defun muse-publish-determine-dl-indent (continue indent-sym determine-sym)
|
|
;; If the caller doesn't know how much indentation to use, figure it
|
|
;; out ourselves. It is assumed that `muse-forward-list-item' has
|
|
;; been called just before this to set the match data.
|
|
(when (and continue
|
|
(symbol-value determine-sym))
|
|
(save-match-data
|
|
;; snarf all leading whitespace
|
|
(let ((indent (and (match-beginning 2)
|
|
(buffer-substring (match-beginning 1)
|
|
(match-beginning 2)))))
|
|
(when (and indent
|
|
(not (string= indent "")))
|
|
(set indent-sym indent)
|
|
(set determine-sym nil))))))
|
|
|
|
(defun muse-publish-surround-dl (indent post-indent)
|
|
(let* ((beg-item (muse-markup-text 'begin-dl-item))
|
|
(end-item (muse-markup-text 'end-dl-item))
|
|
(beg-ddt (muse-markup-text 'begin-ddt)) ;; term
|
|
(end-ddt (muse-markup-text 'end-ddt))
|
|
(beg-dde (muse-markup-text 'begin-dde)) ;; definition
|
|
(end-dde (muse-markup-text 'end-dde))
|
|
(continue t)
|
|
(no-terms t)
|
|
beg)
|
|
(while continue
|
|
;; envelope this as one term+definitions unit -- HTML does not
|
|
;; need this, but DocBook and Muse's custom XML format do
|
|
(muse-insert-markup beg-item)
|
|
(when (looking-at muse-dl-term-regexp)
|
|
;; find the term and wrap it with published markup
|
|
(setq beg (point)
|
|
no-terms nil)
|
|
(goto-char (match-end 1))
|
|
(delete-region (point) (match-end 0))
|
|
(muse-insert-markup-end-list end-ddt)
|
|
;; if definition is immediately after term, move to next line
|
|
(unless (eq (char-after) ?\n)
|
|
(insert ?\n))
|
|
(save-excursion
|
|
(goto-char beg)
|
|
(delete-region (point) (match-beginning 1))
|
|
(muse-insert-markup beg-ddt)))
|
|
;; handle pathological edge case where there is no term -- I
|
|
;; would prefer to just disallow this, but people seem to want
|
|
;; this behavior
|
|
(when (and no-terms
|
|
(looking-at (concat "[" muse-regexp-blank "]*::"
|
|
"[" muse-regexp-blank "]*")))
|
|
(delete-region (point) (match-end 0))
|
|
;; but only do this once
|
|
(setq no-terms nil))
|
|
(setq beg (point)
|
|
;; move past current item
|
|
continue (muse-forward-list-item 'dl-term indent))
|
|
(save-restriction
|
|
(narrow-to-region beg (point))
|
|
(goto-char (point-min))
|
|
;; publish each definition that we find, defaulting to an
|
|
;; empty definition if none are found
|
|
(muse-publish-surround-text beg-dde end-dde
|
|
(lambda (indent)
|
|
(muse-forward-list-item 'dl-entry indent))
|
|
indent post-indent
|
|
#'muse-publish-determine-dl-indent)
|
|
(goto-char (point-max))
|
|
(skip-chars-backward (concat muse-regexp-blank "\n"))
|
|
(muse-insert-markup-end-list end-item)
|
|
(when continue
|
|
(goto-char (point-max)))))))
|
|
|
|
(defun muse-publish-strip-list-indentation (list-item empty-line indent post-indent)
|
|
(let ((list-nested nil)
|
|
(indent-found nil))
|
|
(while (< (point) (point-max))
|
|
(when (and (looking-at list-item)
|
|
(not (or (get-text-property
|
|
(muse-list-item-critical-point) 'read-only)
|
|
(get-text-property
|
|
(muse-list-item-critical-point) 'muse-link))))
|
|
;; if we encounter a list item, allow no post-indent space
|
|
(setq list-nested t))
|
|
(when (and (not (looking-at empty-line))
|
|
(looking-at (concat indent "\\("
|
|
(or (and list-nested "")
|
|
post-indent)
|
|
"\\)")))
|
|
;; if list is not nested, remove indentation
|
|
(unless indent-found
|
|
(setq post-indent (match-string 1)
|
|
indent-found t))
|
|
(replace-match ""))
|
|
(forward-line 1))))
|
|
|
|
(defun muse-publish-surround-text (beg-tag end-tag move-func &optional indent post-indent determine-indent-func list-item)
|
|
(unless list-item
|
|
(setq list-item (format muse-list-item-regexp
|
|
(concat "[" muse-regexp-blank "]*"))))
|
|
(let ((continue t)
|
|
(empty-line (concat "^[" muse-regexp-blank "]*\n"))
|
|
(determine-indent (if determine-indent-func t nil))
|
|
(new-indent indent)
|
|
(first t)
|
|
beg)
|
|
(unless indent
|
|
(setq indent (concat "[" muse-regexp-blank "]+")))
|
|
(if post-indent
|
|
(setq post-indent (concat " \\{0," (number-to-string post-indent)
|
|
"\\}"))
|
|
(setq post-indent ""))
|
|
(while continue
|
|
(if (or (not end-tag) (string= end-tag ""))
|
|
;; if no end of list item markup exists, treat the beginning
|
|
;; of list item markup as it if it were the end -- this
|
|
;; prevents multiple-level lists from being confused
|
|
(muse-insert-markup-end-list beg-tag)
|
|
(muse-insert-markup beg-tag))
|
|
(setq beg (point)
|
|
;; move past current item; continue is non-nil if there
|
|
;; are more like items to be processed
|
|
continue (if (and determine-indent-func first)
|
|
(funcall move-func (concat indent post-indent))
|
|
(funcall move-func indent)))
|
|
(when determine-indent-func
|
|
(funcall determine-indent-func continue 'new-indent 'determine-indent))
|
|
(when continue
|
|
;; remove list markup if we encountered another item of the
|
|
;; same type
|
|
(replace-match "" t t nil 1))
|
|
(save-restriction
|
|
;; narrow to current item
|
|
(narrow-to-region beg (point))
|
|
(goto-char (point-min))
|
|
(if (looking-at empty-line)
|
|
;; if initial line is blank, move to first non-blank line
|
|
(while (progn (forward-line 1)
|
|
(and (< (point) (point-max))
|
|
(looking-at empty-line))))
|
|
;; otherwise, move to second line of text
|
|
(forward-line 1))
|
|
;; strip list indentation
|
|
(muse-publish-strip-list-indentation list-item empty-line
|
|
indent post-indent)
|
|
(skip-chars-backward (concat muse-regexp-blank "\n"))
|
|
(muse-insert-markup-end-list end-tag)
|
|
(when determine-indent-func
|
|
(setq indent new-indent))
|
|
(when first
|
|
(setq first nil))
|
|
(when continue
|
|
(goto-char (point-max)))))))
|
|
|
|
(defun muse-publish-ensure-blank-line ()
|
|
"Make sure that a blank line exists on the line before point."
|
|
(let ((pt (point-marker)))
|
|
(beginning-of-line)
|
|
(cond ((eq (point) (point-min)) nil)
|
|
((prog2 (backward-char) (bolp) (forward-char)) nil)
|
|
(t (insert-before-markers "\n")))
|
|
(goto-char pt)
|
|
(set-marker pt nil)))
|
|
|
|
(defun muse-publish-markup-list ()
|
|
"Markup a list entry.
|
|
This function works by marking up items of the same list level
|
|
and type, respecting the end-of-list property."
|
|
(let* ((str (match-string 1))
|
|
(type (muse-list-item-type str))
|
|
(indent (buffer-substring (muse-line-beginning-position)
|
|
(match-beginning 1)))
|
|
(post-indent (length str)))
|
|
(cond
|
|
((or (get-text-property (muse-list-item-critical-point) 'read-only)
|
|
(get-text-property (muse-list-item-critical-point) 'muse-link))
|
|
nil)
|
|
((eq type 'ul)
|
|
(unless (eq (char-after (match-end 1)) ?-)
|
|
(delete-region (match-beginning 0) (match-end 0))
|
|
(muse-publish-ensure-blank-line)
|
|
(muse-insert-markup (muse-markup-text 'begin-uli))
|
|
(save-excursion
|
|
(muse-publish-surround-text
|
|
(muse-markup-text 'begin-uli-item)
|
|
(muse-markup-text 'end-uli-item)
|
|
(lambda (indent)
|
|
(muse-forward-list-item 'ul indent))
|
|
indent post-indent)
|
|
(muse-insert-markup-end-list (muse-markup-text 'end-uli)))
|
|
(forward-line 1)))
|
|
((eq type 'ol)
|
|
(delete-region (match-beginning 0) (match-end 0))
|
|
(muse-publish-ensure-blank-line)
|
|
(muse-insert-markup (muse-markup-text 'begin-oli))
|
|
(save-excursion
|
|
(muse-publish-surround-text
|
|
(muse-markup-text 'begin-oli-item)
|
|
(muse-markup-text 'end-oli-item)
|
|
(lambda (indent)
|
|
(muse-forward-list-item 'ol indent))
|
|
indent post-indent)
|
|
(muse-insert-markup-end-list (muse-markup-text 'end-oli)))
|
|
(forward-line 1))
|
|
(t
|
|
(goto-char (match-beginning 0))
|
|
(muse-publish-ensure-blank-line)
|
|
(muse-insert-markup (muse-markup-text 'begin-dl))
|
|
(save-excursion
|
|
(muse-publish-surround-dl indent post-indent)
|
|
(muse-insert-markup-end-list (muse-markup-text 'end-dl)))
|
|
(forward-line 1))))
|
|
nil)
|
|
|
|
(defun muse-publish-markup-quote ()
|
|
"Markup a quoted paragraph.
|
|
The reason this function is so funky, is to prevent text properties
|
|
like read-only from being inadvertently deleted."
|
|
(let* ((ws (match-string 1))
|
|
(centered (>= (string-width ws) 6))
|
|
(begin-elem (if centered 'begin-center 'begin-quote-item))
|
|
(end-elem (if centered 'end-center 'end-quote-item)))
|
|
(replace-match "" t t nil 1)
|
|
(unless centered
|
|
(muse-insert-markup (muse-markup-text 'begin-quote)))
|
|
(muse-publish-surround-text (muse-markup-text begin-elem)
|
|
(muse-markup-text end-elem)
|
|
(function (lambda (indent)
|
|
(muse-forward-paragraph)
|
|
nil)))
|
|
(unless centered
|
|
(muse-insert-markup (muse-markup-text 'end-quote)))))
|
|
|
|
(defun muse-publish-markup-leading-space (markup-space multiple)
|
|
(let (count)
|
|
(when (and markup-space
|
|
(>= (setq count (skip-chars-forward " ")) 0))
|
|
(delete-region (muse-line-beginning-position) (point))
|
|
(while (> count 0)
|
|
(muse-insert-markup markup-space)
|
|
(setq count (- count multiple))))))
|
|
|
|
(defun muse-publish-markup-verse ()
|
|
(let ((leader (match-string 0)))
|
|
(goto-char (match-beginning 0))
|
|
(muse-insert-markup (muse-markup-text 'begin-verse))
|
|
(while (looking-at leader)
|
|
(replace-match "")
|
|
(muse-publish-markup-leading-space (muse-markup-text 'verse-space) 2)
|
|
(let ((beg (point)))
|
|
(end-of-line)
|
|
(cond
|
|
((bolp)
|
|
(let ((text (muse-markup-text 'empty-verse-line)))
|
|
(when text (muse-insert-markup text))))
|
|
((save-excursion
|
|
(save-match-data
|
|
(forward-line 1)
|
|
(or (looking-at (concat leader "["
|
|
muse-regexp-blank
|
|
"]*$"))
|
|
(not (looking-at leader)))))
|
|
(let ((begin-text (muse-markup-text 'begin-last-stanza-line))
|
|
(end-text (muse-markup-text 'end-last-stanza-line)))
|
|
(when end-text (muse-insert-markup end-text))
|
|
(goto-char beg)
|
|
(when begin-text (muse-insert-markup begin-text))
|
|
(end-of-line)))
|
|
(t
|
|
(let ((begin-text (muse-markup-text 'begin-verse-line))
|
|
(end-text (muse-markup-text 'end-verse-line)))
|
|
(when end-text (muse-insert-markup end-text))
|
|
(goto-char beg)
|
|
(when begin-text (muse-insert-markup begin-text))
|
|
(end-of-line))))
|
|
(forward-line 1))))
|
|
(muse-insert-markup (muse-markup-text 'end-verse))
|
|
(insert ?\n))
|
|
|
|
(defun muse-publish-trim-table (table)
|
|
"Remove completely blank columns from table, if at start or end of row."
|
|
;; remove first
|
|
(catch 'found
|
|
(dolist (row (cdr table))
|
|
(let ((el (cadr row)))
|
|
(when (and (stringp el) (not (string= el "")))
|
|
(throw 'found t))))
|
|
(dolist (row (cdr table))
|
|
(setcdr row (cddr row)))
|
|
(setcar table (1- (car table))))
|
|
;; remove last
|
|
(catch 'found
|
|
(dolist (row (cdr table))
|
|
(let ((el (car (last row))))
|
|
(when (and (stringp el) (not (string= el "")))
|
|
(throw 'found t))))
|
|
(dolist (row (cdr table))
|
|
(setcdr (last row 2) nil))
|
|
(setcar table (1- (car table))))
|
|
table)
|
|
|
|
(defun muse-publish-table-fields (beg end)
|
|
"Parse given region as a table, returning a cons cell.
|
|
The car is the length of the longest row.
|
|
|
|
The cdr is a list of the fields of the table, with the first
|
|
element indicating the type of the row:
|
|
1: body, 2: header, 3: footer, hline: separator.
|
|
|
|
The existing region will be removed, except for initial blank lines."
|
|
(unless (muse-publishing-directive "disable-tables")
|
|
(let ((longest 0)
|
|
(left 0)
|
|
(seen-hline nil)
|
|
fields field-list)
|
|
(save-restriction
|
|
(narrow-to-region beg end)
|
|
(goto-char (point-min))
|
|
(while (looking-at (concat "^[" muse-regexp-blank "]*$"))
|
|
(forward-line 1))
|
|
(setq beg (point))
|
|
(while (= left 0)
|
|
(cond
|
|
((looking-at muse-table-hline-regexp)
|
|
(when field-list ; skip if at the beginning of table
|
|
(if seen-hline
|
|
(setq field-list (cons (cons 'hline nil) field-list))
|
|
(dolist (field field-list)
|
|
;; the preceding fields are header lines
|
|
(setcar field 2))
|
|
(setq seen-hline t))))
|
|
((looking-at muse-table-line-regexp)
|
|
(setq fields (cons (length (match-string 1))
|
|
(mapcar #'muse-trim-whitespace
|
|
(split-string (match-string 0)
|
|
muse-table-field-regexp)))
|
|
field-list (cons fields field-list)
|
|
longest (max (length fields) longest))
|
|
;; strip initial bars, if they exist
|
|
(let ((first (cadr fields)))
|
|
(when (and first (string-match "\\`|+\\s-*" first))
|
|
(setcar (cdr fields) (replace-match "" t t first))))))
|
|
(setq left (forward-line 1))))
|
|
(delete-region beg end)
|
|
(if (= longest 0)
|
|
(cons 0 nil)
|
|
;; if the last line was an hline, remove it
|
|
(when (eq (caar field-list) 'hline)
|
|
(setq field-list (cdr field-list)))
|
|
(muse-publish-trim-table (cons (1- longest) (nreverse field-list)))))))
|
|
|
|
(defun muse-publish-markup-table ()
|
|
"Style does not support tables.\n")
|
|
|
|
(defun muse-publish-table-el-table (variant)
|
|
"Publish table.el-style tables in the format given by VARIANT."
|
|
(when (condition-case nil
|
|
(progn (require 'table)
|
|
t)
|
|
(error nil))
|
|
(let ((muse-buf (current-buffer)))
|
|
(save-restriction
|
|
(narrow-to-region (match-beginning 0) (match-end 0))
|
|
(goto-char (point-min))
|
|
(forward-line 1)
|
|
(when (search-forward "|" nil t)
|
|
(with-temp-buffer
|
|
(let ((temp-buf (current-buffer)))
|
|
(with-current-buffer muse-buf
|
|
(table-generate-source variant temp-buf))
|
|
(with-current-buffer muse-buf
|
|
(delete-region (point-min) (point-max))
|
|
(insert-buffer-substring temp-buf)
|
|
(muse-publish-mark-read-only (point-min) (point-max))))))))))
|
|
|
|
(defun muse-publish-markup-table-el ()
|
|
"Mark up table.el-style tables."
|
|
(cond ((muse-style-derived-p 'html)
|
|
(muse-publish-table-el-table 'html))
|
|
((muse-style-derived-p 'latex)
|
|
(muse-publish-table-el-table 'latex))
|
|
((muse-style-derived-p 'docbook)
|
|
(muse-publish-table-el-table 'cals))
|
|
(t "Style does not support table.el tables.\n")))
|
|
|
|
(defun muse-publish-escape-specials-in-string (string &optional context)
|
|
"Escape specials in STRING using style-specific :specials.
|
|
CONTEXT is used to figure out what kind of specials to escape.
|
|
|
|
See the documentation of the `muse-publish-escape-specials'
|
|
function for the list of available contexts."
|
|
(unless string
|
|
(setq string ""))
|
|
(let ((specials (muse-style-element :specials nil t)))
|
|
(cond ((functionp specials)
|
|
(setq specials (funcall specials context)))
|
|
((symbolp specials)
|
|
(setq specials (symbol-value specials))))
|
|
(if (functionp specials)
|
|
(funcall specials string)
|
|
(apply (function concat)
|
|
(mapcar
|
|
(lambda (ch)
|
|
(let ((repl (or (assoc ch specials)
|
|
(assoc ch muse-publish-markup-specials))))
|
|
(if (null repl)
|
|
(char-to-string ch)
|
|
(cdr repl))))
|
|
(append string nil))))))
|
|
|
|
(defun muse-publish-markup-email ()
|
|
(let* ((beg (match-end 1))
|
|
(addr (buffer-substring-no-properties beg (match-end 0))))
|
|
(setq addr (muse-publish-escape-specials-in-string addr 'email))
|
|
(goto-char beg)
|
|
(delete-region beg (match-end 0))
|
|
(if (or (eq (char-before (match-beginning 0)) ?\")
|
|
(eq (char-after (match-end 0)) ?\"))
|
|
(insert addr)
|
|
(insert (format (muse-markup-text 'email-addr) addr addr)))
|
|
(muse-publish-mark-read-only beg (point))))
|
|
|
|
(defun muse-publish-classify-url (target)
|
|
"Transform anchors and get published name, if TARGET is a page.
|
|
The return value is two linked cons cells. The car is the type
|
|
of link, the cadr is the page name, and the cddr is the anchor."
|
|
(save-match-data
|
|
(cond ((or (null target) (string= target ""))
|
|
nil)
|
|
((string-match "\\`[uU][rR][lL]:\\(.+\\)\\'" target)
|
|
(cons 'url (cons (match-string 1 target) nil)))
|
|
((string-match muse-image-regexp target)
|
|
(cons 'image (cons target nil)))
|
|
((string-match muse-url-regexp target)
|
|
(cons 'url (cons target nil)))
|
|
((string-match muse-file-regexp target)
|
|
(cons 'file (cons target nil)))
|
|
((string-match "#" target)
|
|
(if (eq (aref target 0) ?\#)
|
|
(cons 'anchor-ref (cons nil (substring target 1)))
|
|
(cons 'link-and-anchor
|
|
;; match-data is changed by
|
|
;; `muse-publish-link-page' or descendants.
|
|
(cons (save-match-data
|
|
(muse-publish-link-page
|
|
(substring target 0 (match-beginning 0))))
|
|
(substring target (match-end 0))))))
|
|
(t
|
|
(cons 'link (cons (muse-publish-link-page target) nil))))))
|
|
|
|
(defun muse-publish-url-desc (desc explicit)
|
|
(when desc
|
|
(dolist (transform muse-publish-desc-transforms)
|
|
(setq desc (save-match-data
|
|
(when desc (funcall transform desc explicit)))))
|
|
(setq desc (muse-link-unescape desc))
|
|
(muse-publish-escape-specials-in-string desc 'url-desc)))
|
|
|
|
(defun muse-publish-url (url &optional desc orig-url explicit)
|
|
"Resolve a URL into its final <a href> form."
|
|
(let ((unesc-url url)
|
|
(unesc-orig-url orig-url)
|
|
(unesc-desc desc)
|
|
type anchor)
|
|
;; Transform URL
|
|
(dolist (transform muse-publish-url-transforms)
|
|
(setq url (save-match-data (when url (funcall transform url explicit)))))
|
|
;; Classify URL
|
|
(let ((target (muse-publish-classify-url url)))
|
|
(setq type (car target)
|
|
url (if (eq type 'image)
|
|
(muse-publish-escape-specials-in-string (cadr target)
|
|
'image)
|
|
(muse-publish-escape-specials-in-string (cadr target) 'url))
|
|
anchor (muse-publish-escape-specials-in-string
|
|
(cddr target) 'url)))
|
|
;; Transform description
|
|
(if desc
|
|
(setq desc (muse-publish-url-desc desc explicit))
|
|
(when orig-url
|
|
(setq orig-url (muse-publish-url-desc orig-url explicit))))
|
|
;; Act on URL classification
|
|
(cond ((eq type 'anchor-ref)
|
|
(muse-markup-text 'anchor-ref anchor (or desc orig-url)))
|
|
((and unesc-desc (string-match muse-image-regexp unesc-desc))
|
|
(let ((ext (or (file-name-extension desc) "")))
|
|
(setq desc (muse-publish-escape-specials-in-string unesc-desc
|
|
'image))
|
|
(setq desc (muse-path-sans-extension desc))
|
|
(muse-markup-text 'image-link url desc ext)))
|
|
((string= url "")
|
|
desc)
|
|
((eq type 'image)
|
|
(let ((ext (or (file-name-extension url) "")))
|
|
(setq url (muse-path-sans-extension url))
|
|
(if desc
|
|
(muse-markup-text 'image-with-desc url ext desc)
|
|
(muse-markup-text 'image url ext))))
|
|
((eq type 'link-and-anchor)
|
|
(muse-markup-text 'link-and-anchor url anchor
|
|
(or desc orig-url)
|
|
(muse-path-sans-extension url)))
|
|
((eq type 'link)
|
|
(muse-markup-text 'link url (or desc orig-url)))
|
|
(t
|
|
(or (and (or desc
|
|
;; compare the not-escaped versions of url and
|
|
;; orig-url
|
|
(not (string= unesc-url unesc-orig-url)))
|
|
(let ((text (muse-markup-text 'url-and-desc url
|
|
(or desc orig-url))))
|
|
(and (not (string= text ""))
|
|
text)))
|
|
(muse-markup-text 'url url (or desc orig-url)))))))
|
|
|
|
(defun muse-publish-insert-url (url &optional desc orig-url explicit)
|
|
"Resolve a URL into its final <a href> form."
|
|
(delete-region (match-beginning 0) (match-end 0))
|
|
(let ((text (muse-publish-url url desc orig-url explicit)))
|
|
(when text
|
|
(muse-insert-markup text))))
|
|
|
|
(defun muse-publish-markup-link ()
|
|
(let (desc explicit orig-link link)
|
|
(setq explicit (save-match-data
|
|
(if (string-match muse-explicit-link-regexp
|
|
(match-string 0))
|
|
t nil)))
|
|
(setq orig-link (if explicit (match-string 1) (match-string 0)))
|
|
(setq desc (when explicit (match-string 2)))
|
|
(setq link (if explicit
|
|
(muse-handle-explicit-link orig-link)
|
|
(muse-handle-implicit-link orig-link)))
|
|
(when (and link
|
|
(or explicit
|
|
(not (or (eq (char-before (match-beginning 0)) ?\")
|
|
(eq (char-after (match-end 0)) ?\")))))
|
|
;; if explicit link has no user-provided description, treat it
|
|
;; as if it were an implicit link
|
|
(when (and explicit (not desc))
|
|
(setq explicit nil))
|
|
(muse-publish-insert-url link desc orig-link explicit))))
|
|
|
|
(defun muse-publish-markup-url ()
|
|
(unless (or (eq (char-before (match-beginning 0)) ?\")
|
|
(eq (char-after (match-end 0)) ?\"))
|
|
(let ((url (match-string 0)))
|
|
(muse-publish-insert-url url nil url))))
|
|
|
|
;; Default publishing tags
|
|
|
|
(defcustom muse-publish-contents-depth 2
|
|
"The number of heading levels to include with <contents> tags."
|
|
:type 'integer
|
|
:group 'muse-publish)
|
|
|
|
(defun muse-publish-contents-tag (beg end attrs)
|
|
(set (make-local-variable 'muse-publish-generate-contents)
|
|
(cons (copy-marker (point) t)
|
|
(let ((depth (cdr (assoc "depth" attrs))))
|
|
(or (and depth (string-to-number depth))
|
|
muse-publish-contents-depth)))))
|
|
|
|
(defun muse-publish-verse-tag (beg end)
|
|
(muse-publish-ensure-block beg end)
|
|
(save-excursion
|
|
(save-restriction
|
|
(narrow-to-region beg end)
|
|
(goto-char (point-min))
|
|
(delete-char 1)
|
|
(while (< (point) (point-max))
|
|
(insert "> ")
|
|
(forward-line))
|
|
(if (eq ?\ (char-syntax (char-before)))
|
|
(delete-char -1)))))
|
|
|
|
(defun muse-publish-mark-read-only (beg end)
|
|
"Add read-only properties to the given region."
|
|
(add-text-properties beg end '(rear-nonsticky (read-only) read-only t))
|
|
nil)
|
|
|
|
(defun muse-publish-mark-link (&optional beg end)
|
|
"Indicate that the given region is a Muse link, so that other
|
|
markup elements respect it. If a region is not specified, use
|
|
the 0th match data to determine it.
|
|
|
|
This is usually applied to explicit links."
|
|
(unless beg (setq beg (match-beginning 0)))
|
|
(unless end (setq end (match-end 0)))
|
|
(add-text-properties beg end '(muse-link t))
|
|
nil)
|
|
|
|
(defun muse-publish-quote-tag (beg end)
|
|
(muse-publish-ensure-block beg)
|
|
(save-excursion
|
|
(save-restriction
|
|
(narrow-to-region beg end)
|
|
(let ((quote-regexp "^\\(<\\(/?\\)quote>\\)"))
|
|
(muse-insert-markup (muse-markup-text 'begin-quote))
|
|
(while (progn
|
|
(unless (looking-at (concat "[" muse-regexp-blank "\n]*"
|
|
"<quote>"))
|
|
(muse-publish-surround-text
|
|
(muse-markup-text 'begin-quote-item)
|
|
(muse-markup-text 'end-quote-item)
|
|
(function
|
|
(lambda (indent)
|
|
(muse-forward-paragraph)
|
|
(goto-char (match-end 0))
|
|
(and (< (point) (point-max))
|
|
(not (looking-at quote-regexp)))))
|
|
nil nil nil
|
|
quote-regexp))
|
|
(if (>= (point) (point-max))
|
|
t
|
|
(and (search-forward "<quote>" nil t)
|
|
(muse-goto-tag-end "quote" t)
|
|
(progn (forward-line 1) t)
|
|
(< (point) (point-max))))))
|
|
(goto-char (point-max))
|
|
(muse-insert-markup (muse-markup-text 'end-quote))))))
|
|
|
|
(defun muse-publish-code-tag (beg end)
|
|
(muse-publish-escape-specials beg end nil 'literal)
|
|
(goto-char beg)
|
|
(insert (muse-markup-text 'begin-literal))
|
|
(goto-char end)
|
|
(insert (muse-markup-text 'end-literal))
|
|
(muse-publish-mark-read-only beg (point)))
|
|
|
|
(defun muse-publish-cite-tag (beg end attrs)
|
|
(let* ((type (muse-publish-get-and-delete-attr "type" attrs))
|
|
(citetag (cond ((string-equal type "author")
|
|
'begin-cite-author)
|
|
((string-equal type "year")
|
|
'begin-cite-year)
|
|
(t
|
|
'begin-cite))))
|
|
(goto-char beg)
|
|
(insert (muse-markup-text citetag (muse-publishing-directive "bibsource")))
|
|
(goto-char end)
|
|
(insert (muse-markup-text 'end-cite))
|
|
(muse-publish-mark-read-only beg (point))))
|
|
|
|
(defun muse-publish-src-tag (beg end attrs)
|
|
(muse-publish-example-tag beg end))
|
|
|
|
(defun muse-publish-example-tag (beg end)
|
|
(muse-publish-ensure-block beg end)
|
|
(muse-publish-escape-specials beg end nil 'example)
|
|
(goto-char beg)
|
|
(insert (muse-markup-text 'begin-example))
|
|
(goto-char end)
|
|
(insert (muse-markup-text 'end-example))
|
|
(muse-publish-mark-read-only beg (point)))
|
|
|
|
(defun muse-publish-literal-tag (beg end attrs)
|
|
"Ensure that the text between BEG and END is not interpreted later on.
|
|
|
|
ATTRS is an alist of attributes.
|
|
|
|
If it contains a \"style\" element, delete the region if the
|
|
current style is neither derived from nor equal to this style.
|
|
|
|
If it contains both a \"style\" element and an \"exact\" element
|
|
with the value \"t\", delete the region only if the current style
|
|
is exactly this style."
|
|
(let* ((style (cdr (assoc "style" attrs)))
|
|
(exact (cdr (assoc "exact" attrs)))
|
|
(exactp (and (stringp exact) (string= exact "t"))))
|
|
(if (or (not style)
|
|
(and exactp (equal (muse-style style)
|
|
muse-publishing-current-style))
|
|
(and (not exactp) (muse-style-derived-p style)))
|
|
(muse-publish-mark-read-only beg end)
|
|
(delete-region beg end)
|
|
(when (and (bolp) (eolp) (not (eobp)))
|
|
(delete-char 1)))))
|
|
|
|
(put 'muse-publish-literal-tag 'muse-dangerous-tag t)
|
|
|
|
(defun muse-publish-verbatim-tag (beg end)
|
|
(muse-publish-escape-specials beg end nil 'verbatim)
|
|
(muse-publish-mark-read-only beg end))
|
|
|
|
(defun muse-publish-br-tag (beg end)
|
|
"Insert a line break."
|
|
(delete-region beg end)
|
|
(muse-insert-markup (muse-markup-text 'line-break)))
|
|
|
|
(defalias 'muse-publish-class-tag 'ignore)
|
|
(defalias 'muse-publish-div-tag 'ignore)
|
|
|
|
(defun muse-publish-call-tag-on-buffer (tag &optional attrs)
|
|
"Transform the current buffer as if it were surrounded by the tag TAG.
|
|
If attributes ATTRS are given, pass them to the tag function."
|
|
(let ((tag-info (muse-markup-tag-info tag)))
|
|
(when tag-info
|
|
(let* ((end (progn (goto-char (point-max)) (point-marker)))
|
|
(args (list (point-min) end))
|
|
(muse-inhibit-style-tags nil))
|
|
(when (nth 2 tag-info)
|
|
(nconc args (list attrs)))
|
|
(apply (nth 4 tag-info) args)
|
|
(set-marker end nil)))))
|
|
|
|
(defun muse-publish-examplify-buffer (&optional attrs)
|
|
"Transform the current buffer as if it were an <example> region."
|
|
(muse-publish-call-tag-on-buffer "example" attrs))
|
|
|
|
(defun muse-publish-srcify-buffer (&optional attrs)
|
|
"Transform the current buffer as if it were a <src> region."
|
|
(muse-publish-call-tag-on-buffer "src" attrs))
|
|
|
|
(defun muse-publish-versify-buffer (&optional attrs)
|
|
"Transform the current buffer as if it were a <verse> region."
|
|
(muse-publish-call-tag-on-buffer "verse" attrs)
|
|
(muse-publish-markup ""
|
|
`((100 ,(concat "^[" muse-regexp-blank "]*> ") 0
|
|
muse-publish-markup-verse)))
|
|
(goto-char (point-min)))
|
|
|
|
(defmacro muse-publish-markup-attribute (beg end attrs reinterp &rest body)
|
|
"Evaluate BODY within the bounds of BEG and END.
|
|
ATTRS is an alist. Only the \"markup\" element of ATTRS is acted
|
|
on.
|
|
|
|
If it is omitted, publish the region with the normal Muse rules.
|
|
If RE-INTERP is specified, this is done immediately in a new
|
|
publishing process. Currently, RE-INTERP is specified only by
|
|
the <include> tag.
|
|
|
|
If \"nil\", do not mark up the region at all, but prevent it from
|
|
being further interpreted by Muse.
|
|
|
|
If \"example\", treat the region as if it was surrounded by the
|
|
<example> tag.
|
|
|
|
If \"src\", treat the region as if it was surrounded by the
|
|
<src> tag.
|
|
|
|
If \"verse\", treat the region as if it was surrounded by the
|
|
<verse> tag, to preserve newlines.
|
|
|
|
Otherwise, it should be the name of a function to call in the
|
|
narrowed region after evaluating BODY. The function should
|
|
take the ATTRS parameter.
|
|
|
|
BEG is modified to be the start of the published markup."
|
|
(let ((attrs-sym (make-symbol "attrs"))
|
|
(markup (make-symbol "markup"))
|
|
(markup-function (make-symbol "markup-function")))
|
|
`(let* ((,attrs-sym ,attrs)
|
|
(,markup (muse-publish-get-and-delete-attr "markup" ,attrs-sym)))
|
|
(save-restriction
|
|
(narrow-to-region ,beg ,end)
|
|
(goto-char (point-min))
|
|
,@body
|
|
(if (not ,markup)
|
|
(when ,reinterp
|
|
(muse-publish-markup-region (point-min) (point-max))
|
|
(muse-publish-mark-read-only (point-min) (point-max))
|
|
(goto-char (point-max)))
|
|
(let ((,markup-function (read ,markup)))
|
|
(cond ((eq ,markup-function 'example)
|
|
(setq ,markup-function #'muse-publish-examplify-buffer))
|
|
((eq ,markup-function 'src)
|
|
(setq ,markup-function #'muse-publish-srcify-buffer))
|
|
((eq ,markup-function 'verse)
|
|
(setq ,markup-function #'muse-publish-versify-buffer))
|
|
((and ,markup-function (not (functionp ,markup-function)))
|
|
(error "Invalid markup function `%s'" ,markup))
|
|
(t nil))
|
|
(if ,markup-function
|
|
(funcall ,markup-function ,attrs-sym)
|
|
(muse-publish-mark-read-only (point-min) (point-max))
|
|
(goto-char (point-max)))))))))
|
|
|
|
(put 'muse-publish-markup-attribute 'lisp-indent-function 4)
|
|
(put 'muse-publish-markup-attribute 'edebug-form-spec
|
|
'(sexp sexp sexp sexp body))
|
|
|
|
(defun muse-publish-lisp-tag (beg end attrs)
|
|
(muse-publish-markup-attribute beg end attrs nil
|
|
(save-excursion
|
|
(save-restriction
|
|
(let ((str (muse-eval-lisp
|
|
(prog1
|
|
(concat "(progn "
|
|
(buffer-substring-no-properties (point-min)
|
|
(point-max))
|
|
")")
|
|
(delete-region (point-min) (point-max))
|
|
(widen)))))
|
|
(set-text-properties 0 (length str) nil str)
|
|
(insert str))))))
|
|
|
|
(put 'muse-publish-lisp-tag 'muse-dangerous-tag t)
|
|
|
|
(defun muse-publish-command-tag (beg end attrs)
|
|
(muse-publish-markup-attribute beg end attrs nil
|
|
(while (looking-at "\\s-*$")
|
|
(forward-line))
|
|
(let ((interp (muse-publish-get-and-delete-attr "interp" attrs)))
|
|
(if interp
|
|
(shell-command-on-region (point) (point-max) interp t t)
|
|
(shell-command
|
|
(prog1
|
|
(buffer-substring-no-properties (point) (point-max))
|
|
(delete-region (point-min) (point-max)))
|
|
t)))
|
|
;; make sure there is a newline at end
|
|
(goto-char (point-max))
|
|
(forward-line 0)
|
|
(unless (looking-at "\\s-*$")
|
|
(goto-char (point-max))
|
|
(insert ?\n))
|
|
(goto-char (point-min))))
|
|
|
|
(put 'muse-publish-command-tag 'muse-dangerous-tag t)
|
|
|
|
(defun muse-publish-perl-tag (beg end attrs)
|
|
(muse-publish-command-tag beg end
|
|
(cons (cons "interp" (executable-find "perl"))
|
|
attrs)))
|
|
|
|
(put 'muse-publish-perl-tag 'muse-dangerous-tag t)
|
|
|
|
(defun muse-publish-php-tag (beg end attrs)
|
|
(muse-publish-command-tag beg end
|
|
(cons (cons "interp" (executable-find "php"))
|
|
attrs)))
|
|
|
|
(put 'muse-publish-php-tag 'muse-dangerous-tag t)
|
|
|
|
(defun muse-publish-python-tag (beg end attrs)
|
|
(muse-publish-command-tag beg end
|
|
(cons (cons "interp" (executable-find "python"))
|
|
attrs)))
|
|
|
|
(put 'muse-publish-python-tag 'muse-dangerous-tag t)
|
|
|
|
(defun muse-publish-ruby-tag (beg end attrs)
|
|
(muse-publish-command-tag beg end
|
|
(cons (cons "interp" (executable-find "ruby"))
|
|
attrs)))
|
|
|
|
(put 'muse-publish-ruby-tag 'muse-dangerous-tag t)
|
|
|
|
(defun muse-publish-comment-tag (beg end)
|
|
(if (null muse-publish-comments-p)
|
|
(delete-region beg end)
|
|
(goto-char end)
|
|
(muse-insert-markup (muse-markup-text 'comment-end))
|
|
(muse-publish-mark-read-only beg end)
|
|
(goto-char beg)
|
|
(muse-insert-markup (muse-markup-text 'comment-begin))))
|
|
|
|
(defun muse-publish-include-tag (beg end attrs)
|
|
"Include the named file at the current location during publishing.
|
|
|
|
<include file=\"...\" markup=\"...\">
|
|
|
|
The `markup' attribute controls how this file is marked up after
|
|
being inserted. See `muse-publish-markup-attribute' for an
|
|
explanation of how it works."
|
|
(let ((filename (muse-publish-get-and-delete-attr "file" attrs))
|
|
(muse-publishing-directives (copy-alist muse-publishing-directives)))
|
|
(if filename
|
|
(setq filename (expand-file-name
|
|
filename
|
|
(file-name-directory muse-publishing-current-file)))
|
|
(error "No file attribute specified in <include> tag"))
|
|
(muse-publish-markup-attribute beg end attrs t
|
|
(muse-insert-file-contents filename))))
|
|
|
|
(put 'muse-publish-include-tag 'muse-dangerous-tag t)
|
|
|
|
(defun muse-publish-mark-up-tag (beg end attrs)
|
|
"Run an Emacs Lisp function on the region delimted by this tag.
|
|
|
|
<markup function=\"...\" style=\"...\" exact=\"...\">
|
|
|
|
The optional \"function\" attribute controls how this section is
|
|
marked up. If used, it should be the name of a function to call
|
|
with the buffer narrowed to the delimited region. Note that no
|
|
further marking-up will be performed on this region.
|
|
|
|
If \"function\" is omitted, use the standard Muse markup function.
|
|
This is useful for marking up content in headers and footers.
|
|
|
|
The optional \"style\" attribute causes the region to be deleted
|
|
if the current style is neither derived from nor equal to this
|
|
style.
|
|
|
|
If both a \"style\" attribute and an \"exact\" attribute are
|
|
provided, and \"exact\" is \"t\", delete the region only if the
|
|
current style is exactly this style."
|
|
(let* ((style (cdr (assoc "style" attrs)))
|
|
(exact (cdr (assoc "exact" attrs)))
|
|
(exactp (and (stringp exact) (string= exact "t"))))
|
|
(if (or (not style)
|
|
(and exactp (equal (muse-style style)
|
|
muse-publishing-current-style))
|
|
(and (not exactp) (muse-style-derived-p style)))
|
|
(let* ((function (cdr (assoc "function" attrs)))
|
|
(muse-publish-use-header-footer-tags nil)
|
|
(markup-function (and function (intern-soft function))))
|
|
(if (and markup-function (functionp markup-function))
|
|
(save-restriction
|
|
(narrow-to-region beg end)
|
|
(funcall markup-function)
|
|
(goto-char (point-max)))
|
|
(let ((muse-publish-inhibit-style-hooks t))
|
|
(muse-publish-markup-region beg end)))
|
|
(muse-publish-mark-read-only beg (point)))
|
|
(delete-region beg end))))
|
|
|
|
(put 'muse-publish-mark-up-tag 'muse-dangerous-tag t)
|
|
|
|
;; Miscellaneous helper functions
|
|
|
|
(defun muse-publish-strip-URL (string &rest ignored)
|
|
"If the text \"URL:\" exists at the beginning of STRING, remove it.
|
|
The text is removed regardless of whether and part of it is uppercase."
|
|
(save-match-data
|
|
(if (string-match "\\`[uU][rR][lL]:\\(.+\\)\\'" string)
|
|
(match-string 1 string)
|
|
string)))
|
|
|
|
(defun muse-publish-markup-type (category default-func)
|
|
(let ((rule (muse-find-markup-element :overrides category (muse-style))))
|
|
(funcall (or rule default-func))))
|
|
|
|
(defun muse-published-buffer-contents (buffer)
|
|
(with-current-buffer buffer
|
|
(goto-char (point-min))
|
|
(let ((beg (and (search-forward "Emacs Muse begins here")
|
|
(muse-line-end-position)))
|
|
(end (and (search-forward "Emacs Muse ends here")
|
|
(muse-line-beginning-position))))
|
|
(buffer-substring-no-properties beg end))))
|
|
|
|
(defun muse-published-contents (file)
|
|
(when (file-readable-p file)
|
|
(muse-with-temp-buffer
|
|
(muse-insert-file-contents file)
|
|
(muse-published-buffer-contents (current-buffer)))))
|
|
|
|
(defun muse-publish-transform-output
|
|
(file temp-file output-path name gen-func &rest cleanup-exts)
|
|
"Transform the given TEMP-FILE into the OUTPUT-PATH, using GEN-FUNC."
|
|
(setq file (muse-page-name file))
|
|
(message "Generating %s output for %s..." name file)
|
|
(if (not (funcall gen-func temp-file output-path))
|
|
(message "Generating %s from %s...failed" name file)
|
|
(message "Generating %s output for %s...done" name file)
|
|
(muse-delete-file-if-exists temp-file)
|
|
(dolist (ext cleanup-exts)
|
|
(muse-delete-file-if-exists
|
|
(expand-file-name (concat file ext)
|
|
(file-name-directory output-path))))
|
|
(message "Wrote %s" output-path)))
|
|
|
|
(defun muse-publish-read-only (string)
|
|
(let ((end (1- (length string))))
|
|
(add-text-properties 0 end
|
|
'(rear-nonsticky (read-only) read-only t)
|
|
string)
|
|
string))
|
|
|
|
;;; muse-publish.el ends here
|