Permalink
Cannot retrieve contributors at this time
Fetching contributors…

;;; muse.el --- an authoring and publishing tool for Emacs | |
;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 | |
;; Free Software Foundation, Inc. | |
;; Emacs Lisp Archive Entry | |
;; Filename: muse.el | |
;; Version: 3.20 | |
;; Date: Sun 31 Jan-2010 | |
;; Keywords: hypermedia | |
;; Author: John Wiegley <johnw@gnu.org> | |
;; Maintainer: Michael Olson <mwolson@gnu.org> | |
;; Description: An authoring and publishing tool for Emacs | |
;; URL: http://mwolson.org/projects/EmacsMuse.html | |
;; Compatibility: Emacs21 XEmacs21 Emacs22 | |
;; 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: | |
;; Muse is a tool for easily authoring and publishing documents. It | |
;; allows for rapid prototyping of hyperlinked text, which may then be | |
;; exported to multiple output formats -- such as HTML, LaTeX, | |
;; Texinfo, etc. | |
;; The markup rules used by Muse are intended to be very friendly to | |
;; people familiar with Emacs. See the included manual for more | |
;; information. | |
;;; Contributors: | |
;;; Code: | |
;; Indicate that this version of Muse supports nested tags | |
(provide 'muse-nested-tags) | |
(defvar muse-version "3.20" | |
"The version of Muse currently loaded") | |
(defun muse-version (&optional insert) | |
"Display the version of Muse that is currently loaded. | |
If INSERT is non-nil, insert the text instead of displaying it." | |
(interactive "P") | |
(if insert | |
(insert muse-version) | |
(message muse-version))) | |
(defgroup muse nil | |
"Options controlling the behavior of Muse. | |
The markup used by Muse is intended to be very friendly to people | |
familiar with Emacs." | |
:group 'hypermedia) | |
(defvar muse-under-windows-p (memq system-type '(ms-dos windows-nt))) | |
(provide 'muse) | |
(condition-case nil | |
(require 'derived) | |
(error nil)) | |
(require 'wid-edit) | |
(require 'muse-regexps) | |
(defvar muse-update-values-hook nil | |
"Hook for values that are automatically generated. | |
This is to be used by add-on modules for Muse. | |
It is run just before colorizing or publishing a buffer.") | |
(defun muse-update-values () | |
"Update various values that are automatically generated. | |
Call this after changing `muse-project-alist'." | |
(interactive) | |
(run-hooks 'muse-update-values-hook) | |
(dolist (buffer (buffer-list)) | |
(when (buffer-live-p buffer) | |
(with-current-buffer buffer | |
(when (derived-mode-p 'muse-mode) | |
(and (boundp 'muse-current-project) | |
(fboundp 'muse-project-of-file) | |
(setq muse-current-project nil) | |
(setq muse-current-project (muse-project-of-file)))))))) | |
;; Default file extension | |
;; By default, use the .muse file extension. | |
;;;###autoload (add-to-list 'auto-mode-alist '("\\.muse\\'" . muse-mode-choose-mode)) | |
;; We need to have this at top-level, as well, so that any Muse or | |
;; Planner documents opened during init will just work. | |
(add-to-list 'auto-mode-alist '("\\.muse\\'" . muse-mode-choose-mode)) | |
(eval-when-compile | |
(defvar muse-ignored-extensions)) | |
(defvar muse-ignored-extensions-regexp nil | |
"A regexp of extensions to omit from the ending of a Muse page name. | |
This is autogenerated from `muse-ignored-extensions'.") | |
(defun muse-update-file-extension (sym val) | |
"Update the value of `muse-file-extension'." | |
(let ((old (and (boundp sym) (symbol-value sym)))) | |
(set sym val) | |
(when (and (featurep 'muse-mode) | |
(or (not (stringp val)) | |
(not (stringp old)) | |
(not (string= old val)))) | |
;; remove old auto-mode-alist association | |
(when (and (boundp sym) (stringp old)) | |
(setq auto-mode-alist | |
(delete (cons (concat "\\." old "\\'") | |
'muse-mode-choose-mode) | |
auto-mode-alist))) | |
;; associate the new file extension with muse-mode | |
(when (stringp val) | |
(add-to-list 'auto-mode-alist | |
(cons (concat "\\." val "\\'") | |
'muse-mode-choose-mode))) | |
;; update the ignored extensions regexp | |
(when (fboundp 'muse-update-ignored-extensions-regexp) | |
(muse-update-ignored-extensions-regexp | |
'muse-ignored-extensions muse-ignored-extensions))))) | |
(defcustom muse-file-extension "muse" | |
"File extension of Muse files. Omit the period at the beginning. | |
If you don't want Muse files to have an extension, set this to nil." | |
:type '(choice | |
(const :tag "None" nil) | |
(string)) | |
:set 'muse-update-file-extension | |
:group 'muse) | |
(defcustom muse-completing-read-function 'completing-read | |
"Function to call when prompting user to choose between a list of options. | |
This should take the same arguments as `completing-read'." | |
:type 'function | |
:group 'muse) | |
(defun muse-update-ignored-extensions-regexp (sym val) | |
"Update the value of `muse-ignored-extensions-regexp'." | |
(set sym val) | |
(if val | |
(setq muse-ignored-extensions-regexp | |
(concat "\\.\\(" | |
(regexp-quote (or muse-file-extension "")) "\\|" | |
(mapconcat 'identity val "\\|") | |
"\\)\\'")) | |
(setq muse-ignored-extensions-regexp | |
(if muse-file-extension | |
(concat "\\.\\(" muse-file-extension "\\)\\'") | |
nil)))) | |
(add-hook 'muse-update-values-hook | |
(lambda () | |
(muse-update-ignored-extensions-regexp | |
'muse-ignored-extensions muse-ignored-extensions))) | |
(defcustom muse-ignored-extensions '("bz2" "gz" "[Zz]") | |
"A list of extensions to omit from the ending of a Muse page name. | |
These are regexps. | |
Don't put a period at the beginning of each extension unless you | |
understand that it is part of a regexp." | |
:type '(repeat (regexp :tag "Extension")) | |
:set 'muse-update-ignored-extensions-regexp | |
:group 'muse) | |
(defun muse-update-file-extension-after-init () | |
;; This is short, but it has to be a function, otherwise Emacs21 | |
;; does not load it properly when running after-init-hook | |
(unless (string= muse-file-extension "muse") | |
(let ((val muse-file-extension) | |
(muse-file-extension "muse")) | |
(muse-update-file-extension 'muse-file-extension val)))) | |
;; Once the user's init file has been processed, determine whether | |
;; they want a file extension | |
(add-hook 'after-init-hook 'muse-update-file-extension-after-init) | |
;; URL protocols | |
(require 'muse-protocols) | |
;; Helper functions | |
(defsubst muse-delete-file-if-exists (file) | |
(when (file-exists-p file) | |
(delete-file file) | |
(message "Removed %s" file))) | |
(defsubst muse-time-less-p (t1 t2) | |
"Say whether time T1 is less than time T2." | |
(or (< (car t1) (car t2)) | |
(and (= (car t1) (car t2)) | |
(< (nth 1 t1) (nth 1 t2))))) | |
(eval-when-compile | |
(defvar muse-publishing-current-file nil)) | |
(defun muse-current-file () | |
"Return the name of the currently visited or published file." | |
(or (and (boundp 'muse-publishing-current-file) | |
muse-publishing-current-file) | |
(buffer-file-name) | |
(concat default-directory (buffer-name)))) | |
(defun muse-page-name (&optional name) | |
"Return the canonical form of a Muse page name. | |
What this means is that the directory part of NAME is removed, | |
and the file extensions in `muse-ignored-extensions' are also | |
removed from NAME." | |
(save-match-data | |
(unless (and name (not (string= name ""))) | |
(setq name (muse-current-file))) | |
(if name | |
(let ((page (file-name-nondirectory name))) | |
(if (and muse-ignored-extensions-regexp | |
(string-match muse-ignored-extensions-regexp page)) | |
(replace-match "" t t page) | |
page))))) | |
(defun muse-display-warning (message) | |
"Display the given MESSAGE as a warning." | |
(if (fboundp 'display-warning) | |
(display-warning 'muse message | |
(if (featurep 'xemacs) | |
'warning | |
:warning)) | |
(let ((buf (get-buffer-create "*Muse warnings*"))) | |
(with-current-buffer buf | |
(goto-char (point-max)) | |
(insert "Warning (muse): " message) | |
(unless (bolp) | |
(newline))) | |
(display-buffer buf) | |
(sit-for 0)))) | |
(defun muse-eval-lisp (form) | |
"Evaluate the given form and return the result as a string." | |
(require 'pp) | |
(save-match-data | |
(condition-case err | |
(let ((object (eval (read form)))) | |
(cond | |
((stringp object) object) | |
((and (listp object) | |
(not (eq object nil))) | |
(let ((string (pp-to-string object))) | |
(substring string 0 (1- (length string))))) | |
((numberp object) | |
(number-to-string object)) | |
((eq object nil) "") | |
(t | |
(pp-to-string object)))) | |
(error | |
(muse-display-warning (format "%s: Error evaluating %s: %s" | |
(muse-page-name) form err)) | |
"; INVALID LISP CODE")))) | |
(defmacro muse-with-temp-buffer (&rest body) | |
"Create a temporary buffer, and evaluate BODY there like `progn'. | |
See also `with-temp-file' and `with-output-to-string'. | |
Unlike `with-temp-buffer', this will never attempt to save the | |
temp buffer. It is meant to be used along with | |
`insert-file-contents' or `muse-insert-file-contents'. | |
The undo feature will be disabled in the new buffer. | |
If `debug-on-error' is set to t, keep the buffer around for | |
debugging purposes rather than removing it." | |
(let ((temp-buffer (make-symbol "temp-buffer"))) | |
`(let ((,temp-buffer (generate-new-buffer " *muse-temp*"))) | |
(buffer-disable-undo ,temp-buffer) | |
(unwind-protect | |
(if debug-on-error | |
(with-current-buffer ,temp-buffer | |
,@body) | |
(condition-case err | |
(with-current-buffer ,temp-buffer | |
,@body) | |
(error | |
(if (and (boundp 'muse-batch-publishing-p) | |
muse-batch-publishing-p) | |
(progn | |
(message "%s: Error occured: %s" | |
(muse-page-name) err) | |
(backtrace)) | |
(muse-display-warning | |
(format (concat "An error occurred while publishing" | |
" %s:\n %s\n\nSet debug-on-error to" | |
" `t' if you would like a backtrace.") | |
(muse-page-name) err)))))) | |
(when (buffer-live-p ,temp-buffer) | |
(with-current-buffer ,temp-buffer | |
(set-buffer-modified-p nil)) | |
(unless debug-on-error (kill-buffer ,temp-buffer))))))) | |
(put 'muse-with-temp-buffer 'lisp-indent-function 0) | |
(put 'muse-with-temp-buffer 'edebug-form-spec '(body)) | |
(defun muse-insert-file-contents (filename &optional visit) | |
"Insert the contents of file FILENAME after point. | |
Do character code conversion and end-of-line conversion, but none | |
of the other unnecessary things like format decoding or | |
`find-file-hook'. | |
If VISIT is non-nil, the buffer's visited filename | |
and last save file modtime are set, and it is marked unmodified. | |
If visiting and the file does not exist, visiting is completed | |
before the error is signaled." | |
(let ((format-alist nil) | |
(after-insert-file-functions nil) | |
(inhibit-file-name-handlers | |
(append '(jka-compr-handler image-file-handler epa-file-handler) | |
inhibit-file-name-handlers)) | |
(inhibit-file-name-operation 'insert-file-contents)) | |
(insert-file-contents filename visit))) | |
(defun muse-write-file (filename &optional nomessage) | |
"Write current buffer into file FILENAME. | |
Unlike `write-file', this does not visit the file, try to back it | |
up, or interact with vc.el in any way. | |
If the file was not written successfully, return nil. Otherwise, | |
return non-nil. | |
If the NOMESSAGE argument is non-nil, suppress the \"Wrote file\" | |
message." | |
(when nomessage (setq nomessage 'nomessage)) | |
(let ((backup-inhibited t) | |
(buffer-file-name filename) | |
(buffer-file-truename (file-truename filename))) | |
(save-current-buffer | |
(save-restriction | |
(widen) | |
(if (not (file-writable-p buffer-file-name)) | |
(prog1 nil | |
(muse-display-warning | |
(format "Cannot write file %s:\n %s" buffer-file-name | |
(let ((dir (file-name-directory buffer-file-name))) | |
(if (not (file-directory-p dir)) | |
(if (file-exists-p dir) | |
(format "%s is not a directory" dir) | |
(format "No directory named %s exists" dir)) | |
(if (not (file-exists-p buffer-file-name)) | |
(format "Directory %s write-protected" dir) | |
"File is write-protected")))))) | |
(let ((coding-system-for-write | |
(or (and (boundp 'save-buffer-coding-system) | |
save-buffer-coding-system) | |
coding-system-for-write))) | |
(write-region (point-min) (point-max) buffer-file-name | |
nil nomessage)) | |
(when (boundp 'last-file-coding-system-used) | |
(when (boundp 'buffer-file-coding-system-explicit) | |
(setq buffer-file-coding-system-explicit | |
last-coding-system-used)) | |
(if save-buffer-coding-system | |
(setq save-buffer-coding-system last-coding-system-used) | |
(setq buffer-file-coding-system last-coding-system-used))) | |
t))))) | |
(defun muse-collect-alist (list element &optional test) | |
"Collect items from LIST whose car is equal to ELEMENT. | |
If TEST is specified, use it to compare ELEMENT." | |
(unless test (setq test 'equal)) | |
(let ((items nil)) | |
(dolist (item list) | |
(when (funcall test element (car item)) | |
(setq items (cons item items)))) | |
items)) | |
(defmacro muse-sort-with-closure (list predicate closure) | |
"Sort LIST, stably, comparing elements using PREDICATE. | |
Returns the sorted list. LIST is modified by side effects. | |
PREDICATE is called with two elements of list and CLOSURE. | |
PREDICATE should return non-nil if the first element should sort | |
before the second." | |
`(sort ,list (lambda (a b) (funcall ,predicate a b ,closure)))) | |
(put 'muse-sort-with-closure 'lisp-indent-function 0) | |
(put 'muse-sort-with-closure 'edebug-form-spec '(form function-form form)) | |
(defun muse-sort-by-rating (rated-list &optional test) | |
"Sort RATED-LIST according to the rating of each element. | |
The rating is stripped out in the returned list. | |
Default sorting is highest-first. | |
If TEST if specified, use it to sort the list. The default test is '>." | |
(unless test (setq test '>)) | |
(mapcar (function cdr) | |
(muse-sort-with-closure | |
rated-list | |
(lambda (a b closure) | |
(let ((na (numberp (car a))) | |
(nb (numberp (car b)))) | |
(cond ((and na nb) (funcall closure (car a) (car b))) | |
(na (not nb)) | |
(t nil)))) | |
test))) | |
(defun muse-escape-specials-in-string (specials string &optional reverse) | |
"Apply the transformations in SPECIALS to STRING. | |
The transforms should form a fully reversible and non-ambiguous | |
syntax when STRING is parsed from left to right. | |
If REVERSE is specified, reverse an already-escaped string." | |
(let ((rules (mapcar (lambda (rule) | |
(cons (regexp-quote (if reverse | |
(cdr rule) | |
(car rule))) | |
(if reverse (car rule) (cdr rule)))) | |
specials))) | |
(save-match-data | |
(with-temp-buffer | |
(insert string) | |
(goto-char (point-min)) | |
(while (not (eobp)) | |
(unless (catch 'found | |
(dolist (rule rules) | |
(when (looking-at (car rule)) | |
(replace-match (cdr rule) t t) | |
(throw 'found t)))) | |
(forward-char))) | |
(buffer-string))))) | |
(defun muse-trim-whitespace (string) | |
"Return a version of STRING with no initial nor trailing whitespace." | |
(muse-replace-regexp-in-string | |
(concat "\\`[" muse-regexp-blank "]+\\|[" muse-regexp-blank "]+\\'") | |
"" string)) | |
(defun muse-path-sans-extension (path) | |
"Return PATH sans final \"extension\". | |
The extension, in a file name, is the part that follows the last `.', | |
except that a leading `.', if any, doesn't count. | |
This differs from `file-name-sans-extension' in that it will | |
never modify the directory part of the path." | |
(concat (file-name-directory path) | |
(file-name-nondirectory (file-name-sans-extension path)))) | |
;; The following code was extracted from cl | |
(defun muse-const-expr-p (x) | |
(cond ((consp x) | |
(or (eq (car x) 'quote) | |
(and (memq (car x) '(function function*)) | |
(or (symbolp (nth 1 x)) | |
(and (eq (and (consp (nth 1 x)) | |
(car (nth 1 x))) 'lambda) 'func))))) | |
((symbolp x) (and (memq x '(nil t)) t)) | |
(t t))) | |
(put 'muse-assertion-failed 'error-conditions '(error)) | |
(put 'muse-assertion-failed 'error-message "Assertion failed") | |
(defun muse-list* (arg &rest rest) | |
"Return a new list with specified args as elements, cons'd to last arg. | |
Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to | |
`(cons A (cons B (cons C D)))'." | |
(cond ((not rest) arg) | |
((not (cdr rest)) (cons arg (car rest))) | |
(t (let* ((n (length rest)) | |
(copy (copy-sequence rest)) | |
(last (nthcdr (- n 2) copy))) | |
(setcdr last (car (cdr last))) | |
(cons arg copy))))) | |
(defmacro muse-assert (form &optional show-args string &rest args) | |
"Verify that FORM returns non-nil; signal an error if not. | |
Second arg SHOW-ARGS means to include arguments of FORM in message. | |
Other args STRING and ARGS... are arguments to be passed to `error'. | |
They are not evaluated unless the assertion fails. If STRING is | |
omitted, a default message listing FORM itself is used." | |
(let ((sargs | |
(and show-args | |
(delq nil (mapcar | |
(function | |
(lambda (x) | |
(and (not (muse-const-expr-p x)) x))) | |
(cdr form)))))) | |
(list 'progn | |
(list 'or form | |
(if string | |
(muse-list* 'error string (append sargs args)) | |
(list 'signal '(quote muse-assertion-failed) | |
(muse-list* 'list (list 'quote form) sargs)))) | |
nil))) | |
;; Compatibility functions | |
(if (fboundp 'looking-back) | |
(defalias 'muse-looking-back 'looking-back) | |
(defun muse-looking-back (regexp &optional limit &rest ignored) | |
(save-excursion | |
(re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t)))) | |
(eval-and-compile | |
(if (fboundp 'line-end-position) | |
(defalias 'muse-line-end-position 'line-end-position) | |
(defun muse-line-end-position (&optional n) | |
(save-excursion (end-of-line n) (point)))) | |
(if (fboundp 'line-beginning-position) | |
(defalias 'muse-line-beginning-position 'line-beginning-position) | |
(defun muse-line-beginning-position (&optional n) | |
(save-excursion (beginning-of-line n) (point)))) | |
(if (fboundp 'match-string-no-properties) | |
(defalias 'muse-match-string-no-properties 'match-string-no-properties) | |
(defun muse-match-string-no-properties (num &optional string) | |
(match-string num string)))) | |
(defun muse-replace-regexp-in-string (regexp replacement text &optional fixedcase literal) | |
"Replace REGEXP with REPLACEMENT in TEXT. | |
Return a new string containing the replacements. | |
If fourth arg FIXEDCASE is non-nil, do not alter case of replacement text. | |
If fifth arg LITERAL is non-nil, insert REPLACEMENT literally." | |
(cond | |
((and (featurep 'xemacs) (fboundp 'replace-in-string)) | |
(and (fboundp 'replace-in-string) ; stupid byte-compiler warning | |
(replace-in-string text regexp replacement literal))) | |
((fboundp 'replace-regexp-in-string) | |
(replace-regexp-in-string regexp replacement text fixedcase literal)) | |
(t (error (concat "Neither `replace-in-string' nor " | |
"`replace-regexp-in-string' was found"))))) | |
(if (fboundp 'add-to-invisibility-spec) | |
(defalias 'muse-add-to-invisibility-spec 'add-to-invisibility-spec) | |
(defun muse-add-to-invisibility-spec (element) | |
"Add ELEMENT to `buffer-invisibility-spec'. | |
See documentation for `buffer-invisibility-spec' for the kind of elements | |
that can be added." | |
(if (eq buffer-invisibility-spec t) | |
(setq buffer-invisibility-spec (list t))) | |
(setq buffer-invisibility-spec | |
(cons element buffer-invisibility-spec)))) | |
(if (fboundp 'read-directory-name) | |
(defalias 'muse-read-directory-name 'read-directory-name) | |
(defun muse-read-directory-name (prompt &optional dir default-dirname mustmatch initial) | |
"Read directory name - see `read-file-name' for details." | |
(unless dir | |
(setq dir default-directory)) | |
(read-file-name prompt dir (or default-dirname | |
(if initial (expand-file-name initial dir) | |
dir)) | |
mustmatch initial))) | |
(defun muse-file-remote-p (file) | |
"Test whether FILE specifies a location on a remote system. | |
Return non-nil if the location is indeed remote. | |
For example, the filename \"/user@host:/foo\" specifies a location | |
on the system \"/user@host:\"." | |
(cond ((fboundp 'file-remote-p) | |
(file-remote-p file)) | |
((fboundp 'tramp-handle-file-remote-p) | |
(tramp-handle-file-remote-p file)) | |
((and (boundp 'ange-ftp-name-format) | |
(string-match (car ange-ftp-name-format) file)) | |
t) | |
(t nil))) | |
(if (fboundp 'delete-and-extract-region) | |
(defalias 'muse-delete-and-extract-region 'delete-and-extract-region) | |
(defun muse-delete-and-extract-region (start end) | |
"Delete the text between START and END and return it." | |
(prog1 (buffer-substring start end) | |
(delete-region start end)))) | |
(if (fboundp 'delete-dups) | |
(defalias 'muse-delete-dups 'delete-dups) | |
(defun muse-delete-dups (list) | |
"Destructively remove `equal' duplicates from LIST. | |
Store the result in LIST and return it. LIST must be a proper list. | |
Of several `equal' occurrences of an element in LIST, the first | |
one is kept." | |
(let ((tail list)) | |
(while tail | |
(setcdr tail (delete (car tail) (cdr tail))) | |
(setq tail (cdr tail)))) | |
list)) | |
;; Set face globally in a predictable fashion | |
(defun muse-copy-face (old new) | |
"Copy face OLD to NEW." | |
(if (featurep 'xemacs) | |
(copy-face old new 'all) | |
(copy-face old new))) | |
;; Widget compatibility functions | |
(defun muse-widget-type-value-create (widget) | |
"Convert and instantiate the value of the :type attribute of WIDGET. | |
Store the newly created widget in the :children attribute. | |
The value of the :type attribute should be an unconverted widget type." | |
(let ((value (widget-get widget :value)) | |
(type (widget-get widget :type))) | |
(widget-put widget :children | |
(list (widget-create-child-value widget | |
(widget-convert type) | |
value))))) | |
(defun muse-widget-child-value-get (widget) | |
"Get the value of the first member of :children in WIDGET." | |
(widget-value (car (widget-get widget :children)))) | |
(defun muse-widget-type-match (widget value) | |
"Non-nil if the :type value of WIDGET matches VALUE. | |
The value of the :type attribute should be an unconverted widget type." | |
(widget-apply (widget-convert (widget-get widget :type)) :match value)) | |
;; Link-handling functions and variables | |
(defun muse-get-link (&optional target) | |
"Based on the match data, retrieve the link. | |
Use TARGET to get the string, if it is specified." | |
(muse-match-string-no-properties 1 target)) | |
(defun muse-get-link-desc (&optional target) | |
"Based on the match data, retrieve the link description. | |
Use TARGET to get the string, if it is specified." | |
(muse-match-string-no-properties 2 target)) | |
(defvar muse-link-specials | |
'(("[" . "%5B") | |
("]" . "%5D") | |
("%" . "%%")) | |
"Syntax used for escaping and unescaping links. | |
This allows brackets to occur in explicit links as long as you | |
use the standard Muse functions to create them.") | |
(defun muse-link-escape (text) | |
"Escape characters in TEXT that conflict with the explicit link | |
regexp." | |
(when (stringp text) | |
(muse-escape-specials-in-string muse-link-specials text))) | |
(defun muse-link-unescape (text) | |
"Un-escape characters in TEXT that conflict with the explicit | |
link regexp." | |
(when (stringp text) | |
(muse-escape-specials-in-string muse-link-specials text t))) | |
(defun muse-handle-url (&optional string) | |
"If STRING or point has a URL, match and return it." | |
(if (if string (string-match muse-url-regexp string) | |
(looking-at muse-url-regexp)) | |
(match-string 0 string))) | |
(defcustom muse-implicit-link-functions '(muse-handle-url) | |
"A list of functions to handle an implicit link. | |
An implicit link is one that is not surrounded by brackets. | |
By default, Muse handles URLs only. | |
If you want to handle WikiWords, load muse-wiki.el." | |
:type 'hook | |
:options '(muse-handle-url) | |
:group 'muse) | |
(defun muse-handle-implicit-link (&optional link) | |
"Handle implicit links. If LINK is not specified, look at point. | |
An implicit link is one that is not surrounded by brackets. | |
By default, Muse handles URLs only. | |
If you want to handle WikiWords, load muse-wiki.el. | |
This function modifies the match data so that match 0 is the | |
link. | |
The match data is restored after each unsuccessful handler | |
function call. If LINK is specified, only restore at very end. | |
This behavior is needed because the part of the buffer that | |
`muse-implicit-link-regexp' matches must be narrowed to the part | |
that is an accepted link." | |
(let ((funcs muse-implicit-link-functions) | |
(res nil) | |
(data (match-data t))) | |
(while funcs | |
(setq res (funcall (car funcs) link)) | |
(if res | |
(setq funcs nil) | |
(unless link (set-match-data data)) | |
(setq funcs (cdr funcs)))) | |
(when link (set-match-data data)) | |
res)) | |
(defcustom muse-explicit-link-functions nil | |
"A list of functions to handle an explicit link. | |
An explicit link is one [[like][this]] or [[this]]." | |
:type 'hook | |
:group 'muse) | |
(defun muse-handle-explicit-link (&optional link) | |
"Handle explicit links. If LINK is not specified, look at point. | |
An explicit link is one that looks [[like][this]] or [[this]]. | |
The match data is preserved. If no handlers are able to process | |
LINK, return LINK (if specified) or the 1st match string. If | |
LINK is not specified, it is assumed that Muse has matched | |
against `muse-explicit-link-regexp' before calling this | |
function." | |
(let ((funcs muse-explicit-link-functions) | |
(res nil)) | |
(save-match-data | |
(while funcs | |
(setq res (funcall (car funcs) link)) | |
(if res | |
(setq funcs nil) | |
(setq funcs (cdr funcs))))) | |
(muse-link-unescape | |
(if res | |
res | |
(or link (muse-get-link)))))) | |
;; Movement functions | |
(defun muse-list-item-type (str) | |
"Determine the type of list given STR. | |
Returns either 'ul, 'ol, 'dl-term, 'dl-entry, or nil." | |
(save-match-data | |
(cond ((or (string= str "") | |
(< (length str) 2)) | |
nil) | |
((string-match muse-dl-entry-regexp str) | |
'dl-entry) | |
((string-match muse-dl-term-regexp str) | |
'dl-term) | |
((string-match muse-ol-item-regexp str) | |
'ol) | |
((string-match muse-ul-item-regexp str) | |
'ul) | |
(t nil)))) | |
(defun muse-list-item-critical-point (&optional offset) | |
"Figure out where the important markup character for the | |
currently-matched list item is. | |
If OFFSET is specified, it is the number of groupings outside of | |
the contents of `muse-list-item-regexp'." | |
(unless offset (setq offset 0)) | |
(if (match-end (+ offset 2)) | |
;; at a definition list | |
(match-end (+ offset 2)) | |
;; at a different kind of list | |
(match-beginning (+ offset 1)))) | |
(defun muse-forward-paragraph (&optional pattern) | |
"Move forward safely by one paragraph, or according to PATTERN." | |
(when (get-text-property (point) 'muse-end-list) | |
(goto-char (next-single-property-change (point) 'muse-end-list))) | |
(setq pattern (if pattern | |
(concat "^\\(?:" pattern "\\|\n\\|\\'\\)") | |
"^\\s-*\\(\n\\|\\'\\)")) | |
(let ((next-list-end (or (next-single-property-change (point) 'muse-end-list) | |
(point-max)))) | |
(forward-line 1) | |
(if (re-search-forward pattern nil t) | |
(goto-char (match-beginning 0)) | |
(goto-char (point-max))) | |
(when (> (point) next-list-end) | |
(goto-char next-list-end)))) | |
(defun muse-forward-list-item-1 (type empty-line indented-line) | |
"Determine whether a nested list item is after point." | |
(if (match-beginning 1) | |
;; if we are given a dl entry, skip past everything on the same | |
;; level, except for other dl entries | |
(and (eq type 'dl-entry) | |
(not (eq (char-after (match-beginning 2)) ?\:))) | |
;; blank line encountered with no list item on the same | |
;; level after it | |
(let ((beg (point))) | |
(forward-line 1) | |
(if (save-match-data | |
(and (looking-at indented-line) | |
(not (looking-at empty-line)))) | |
;; found that this blank line is followed by some | |
;; indentation, plus other text, so we'll keep | |
;; going | |
t | |
(goto-char beg) | |
nil)))) | |
(defun muse-forward-list-item (type indent &optional no-skip-nested) | |
"Move forward to the next item of TYPE. | |
Return non-nil if successful, nil otherwise. | |
The beginning indentation is given by INDENT. | |
If NO-SKIP-NESTED is non-nil, do not skip past nested items. | |
Note that if you desire this behavior, you will also need to | |
provide a very liberal INDENT value, such as | |
\(concat \"[\" muse-regexp-blank \"]*\")." | |
(let* ((list-item (format muse-list-item-regexp indent)) | |
(empty-line (concat "^[" muse-regexp-blank "]*\n")) | |
(indented-line (concat "^" indent "[" muse-regexp-blank "]")) | |
(list-pattern (concat "\\(?:" empty-line "\\)?" | |
"\\(" list-item "\\)"))) | |
(while (progn | |
(muse-forward-paragraph list-pattern) | |
;; make sure we don't go past boundary | |
(and (not (or (get-text-property (point) 'muse-end-list) | |
(>= (point) (point-max)))) | |
;; move past markup that is part of another construct | |
(or (and (match-beginning 1) | |
(or (get-text-property | |
(muse-list-item-critical-point 1) 'muse-link) | |
(and (derived-mode-p 'muse-mode) | |
(get-text-property | |
(muse-list-item-critical-point 1) | |
'face)))) | |
;; skip nested items | |
(and (not no-skip-nested) | |
(muse-forward-list-item-1 type empty-line | |
indented-line)))))) | |
(cond ((or (get-text-property (point) 'muse-end-list) | |
(>= (point) (point-max))) | |
;; at a list boundary, so stop | |
nil) | |
((let ((str (when (match-beginning 2) | |
;; get the entire line | |
(save-excursion | |
(goto-char (match-beginning 2)) | |
(buffer-substring (muse-line-beginning-position) | |
(muse-line-end-position)))))) | |
(and str (eq type (muse-list-item-type str)))) | |
;; same type, so indicate that there are more items to be | |
;; parsed | |
(goto-char (match-beginning 1))) | |
(t | |
(when (match-beginning 1) | |
(goto-char (match-beginning 1))) | |
;; move to just before foreign list item markup | |
nil)))) | |
(defun muse-goto-tag-end (tag nested) | |
"Move forward past the end of TAG. | |
If NESTED is non-nil, look for other instances of this tag that | |
may be nested inside of this tag, and skip past them." | |
(if (not nested) | |
(search-forward (concat "</" tag ">") nil t) | |
(let ((nesting 1) | |
(tag-regexp (concat "\\(<\\(/?\\)" tag "\\([ >]\\)\\)")) | |
(match-found nil)) | |
(while (and (> nesting 0) | |
(setq match-found (re-search-forward tag-regexp nil t))) | |
;; for the sake of font-locking code, skip matches in comments | |
(unless (get-text-property (match-beginning 0) 'muse-comment) | |
(if (string-equal (match-string 2) "/") | |
(and (string-equal (match-string 3) ">") | |
(setq nesting (1- nesting))) | |
(setq nesting (1+ nesting))))) | |
match-found))) | |
;;; muse.el ends here |