diff options
Diffstat (limited to 'emacs.d/elisp/muse/muse-publish.el')
| -rw-r--r-- | emacs.d/elisp/muse/muse-publish.el | 2193 |
1 files changed, 0 insertions, 2193 deletions
diff --git a/emacs.d/elisp/muse/muse-publish.el b/emacs.d/elisp/muse/muse-publish.el deleted file mode 100644 index ec6e176..0000000 --- a/emacs.d/elisp/muse/muse-publish.el +++ /dev/null @@ -1,2193 +0,0 @@ -;;; 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 |