ryuslash/legacy-dotfiles
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity
legacy-dotfiles/emacs.d/elisp/muse/muse-publish.el
Tom Willemsen 57366f385a Big changes, last one before I wipe it all. 
* Added muse

  * Added graphviz-dot-mode

  * Remove all trailing whitespace on save.

This is the last commit I'm going to do before throwing it all away
again.
2011-03-17 11:23:07 +01:00

2193 lines
87 KiB
EmacsLisp
Raw Blame History

;;; 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
Reference in a new issue View git blame Copy permalink