lisp/muse.el

   1 ;;; muse.el --- An authoring and publishing tool for Emacs.
   2
   3 ;; Copyright (C) 2004 Free Software Foundation, Inc.
   4
   5 ;; Emacs Lisp Archive Entry
   6 ;; Filename: muse.el
   7 ;; Version: 3.01.90 (3.02 RC1)
   8 ;; Date: Thu 15-Jun-2005
   9 ;; Keywords: hypermedia
  10 ;; Author: John Wiegley (johnw AT gnu DOT org)
  11 ;; Maintainer: Michael Olson (mwolson AT gnu DOT org)
  12 ;; Description: An authoring and publishing tool for Emacs
  13 ;; URL: http://www.mwolson.org/projects/MuseMode.html
  14 ;; Compatibility: Emacs21
  15
  16 ;; This file is not part of GNU Emacs.
  17
  18 ;; This is free software; you can redistribute it and/or modify it under
  19 ;; the terms of the GNU General Public License as published by the Free
  20 ;; Software Foundation; either version 2, or (at your option) any later
  21 ;; version.
  22 ;;
  23 ;; This is distributed in the hope that it will be useful, but WITHOUT
  24 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  25 ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  26 ;; for more details.
  27 ;;
  28 ;; You should have received a copy of the GNU General Public License
  29 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  30 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  31 ;; Boston, MA 02110-1301, USA.
  32
  33 ;;; Commentary:
  34
  35 ;; Muse is a tool for easily authoring and publishing documents.  It
  36 ;; allows for rapid prototyping of hyperlinked text, which may then be
  37 ;; exported to multiple output formats -- such as HTML, LaTeX,
  38 ;; Texinfo, etc.
  39
  40 ;; The markup rules used by Muse are intended to be very friendly to
  41 ;; people familiar with Emacs.  See the included QuickStart file in
  42 ;; the `examples' directory for more information.
  43
  44 ;;; Contributors:
  45
  46 ;;; Code:
  47
  48 (defvar muse-version "3.01.90 (3.02 RC1)"
  49   "The version of Muse currently loaded")
  50
  51 (defun muse-version ()
  52   "Display the version of Muse that is currently loaded."
  53   (interactive)
  54   (message muse-version))
  55
  56 (defgroup muse nil
  57   "Options controlling the behavior of Muse.
  58 The markup used by Muse is intended to be very friendly to people
  59 familiar with Emacs."
  60   :group 'hypermedia)
  61
  62 (defvar muse-under-windows-p (memq system-type '(ms-dos windows-nt)))
  63
  64 (require 'wid-edit)
  65 (require 'muse-regexps)
  66
  67 ;; Default file extension
  68
  69 (defvar muse-ignored-extensions-regexp nil
  70   "A regexp of extensions to omit from the ending of a Muse page name.
  71 This is autogenerated from `muse-ignored-extensions'.")
  72
  73 (defcustom muse-file-extension nil
  74   "File extension of Muse files.  Omit the period at the beginning."
  75   :type '(choice
  76           (const :tag "None" nil)
  77           (string))
  78   :set #'(lambda (sym val)
  79            (when (and (boundp sym) (symbol-value sym))
  80              ;; remove old auto-mode-alist association
  81              (setq auto-mode-alist
  82                    (delete (cons (concat "\\." (symbol-value sym) "\\'")
  83                                  'muse-mode-choose-mode)
  84                            auto-mode-alist)))
  85            (set sym val)
  86            ;; associate .muse with muse-mode
  87            (when val
  88              (add-to-list 'auto-mode-alist
  89                           (cons (concat "\\." val "\\'")
  90                                 'muse-mode-choose-mode)))
  91            (when (fboundp 'muse-update-ignored-extensions-regexp)
  92              (muse-update-ignored-extensions-regexp
  93               'muse-ignored-extensions muse-ignored-extensions)))
  94   :group 'muse)
  95
  96 (defun muse-update-ignored-extensions-regexp (sym val)
  97   "Update the value of `muse-ignored-extensions-regexp'."
  98   (set sym val)
  99   (if val
 100       (setq muse-ignored-extensions-regexp
 101             (concat "\\.\\("
 102                     (regexp-quote (or muse-file-extension "")) "\\|"
 103                     (mapconcat 'identity val "\\|")
 104                     "\\)\\'"))
 105     (setq muse-ignored-extensions-regexp
 106           (if muse-file-extension
 107               (concat "\\.\\(" muse-file-extension "\\)\\'")
 108             nil))))
 109
 110 (defcustom muse-ignored-extensions '("bz2" "gz" "[Zz]")
 111   "A list of extensions to omit from the ending of a Muse page name.
 112 These are regexps.
 113
 114 Don't put a period at the beginning of each extension unless you
 115 understand that it is part of a regexp."
 116   :type '(repeat (regexp :tag "Extension"))
 117   :set 'muse-update-ignored-extensions-regexp
 118   :group 'muse)
 119
 120 ;;; Return an list of known wiki names and the files they represent.
 121
 122 (defsubst muse-delete-file-if-exists (file)
 123   (when (file-exists-p file)
 124     (delete-file file)
 125     (message "Removed %s" file)))
 126
 127 (defsubst muse-time-less-p (t1 t2)
 128   "Say whether time T1 is less than time T2."
 129   (or (< (car t1) (car t2))
 130       (and (= (car t1) (car t2))
 131            (< (nth 1 t1) (nth 1 t2)))))
 132
 133 (eval-when-compile
 134   (defvar muse-publishing-current-file nil))
 135
 136 (defun muse-page-name (&optional name)
 137   "Return the canonical form of a Muse page name.
 138 All this means is that certain extensions, like .gz, are removed."
 139   (save-match-data
 140     (unless (and name (not (string= name "")))
 141       (setq name (or (and (boundp 'muse-publishing-current-file)
 142                           muse-publishing-current-file)
 143                      buffer-file-name
 144                      (concat default-directory (buffer-name)))))
 145     (if name
 146         (let ((page (file-name-nondirectory name)))
 147           (if (and muse-ignored-extensions-regexp
 148                    (string-match muse-ignored-extensions-regexp page))
 149               (replace-match "" t t page)
 150             page)))))
 151
 152 (defun muse-eval-lisp (form)
 153   "Evaluate the given form and return the result as a string."
 154   (require 'pp)
 155   (save-match-data
 156     (condition-case err
 157         (let ((object (eval (read form))))
 158           (cond
 159            ((stringp object) object)
 160            ((and (listp object)
 161                  (not (eq object nil)))
 162             (let ((string (pp-to-string object)))
 163               (substring string 0 (1- (length string)))))
 164            ((numberp object)
 165             (number-to-string object))
 166            ((eq object nil) "")
 167            (t
 168             (pp-to-string object))))
 169       (error
 170        (if (fboundp 'display-warning)
 171            (display-warning 'muse
 172                             (format "%s: Error evaluating %s: %s"
 173                                     (muse-page-name) form err)
 174                             (if (featurep 'xemacs)
 175                                 'warning
 176                               :warning))
 177          (message "%s: Error evaluating %s: %s"
 178                   (muse-page-name) form err))
 179        "<!--INVALID LISP CODE-->"))))
 180
 181 (defmacro muse-with-temp-buffer (&rest body)
 182   "Create a temporary buffer, and evaluate BODY there like `progn'.
 183 See also `with-temp-file' and `with-output-to-string'.
 184 Unlike `with-temp-buffer', this will never attempt to save the temp buffer."
 185   (let ((temp-buffer (make-symbol "temp-buffer")))
 186     `(let ((,temp-buffer (generate-new-buffer " *muse-temp*")))
 187        (unwind-protect
 188            (if debug-on-error
 189                (with-current-buffer ,temp-buffer
 190                  ,@body)
 191              (condition-case err
 192                  (with-current-buffer ,temp-buffer
 193                    ,@body)
 194                (error
 195                 (if (and (boundp 'muse-batch-publishing-p)
 196                          muse-batch-publishing-p)
 197                     (progn
 198                       (message "%s: Error occured: %s"
 199                                (muse-page-name) err)
 200                       (backtrace))
 201                   (if (fboundp 'display-warning)
 202                       (display-warning 'muse
 203                                        (format "%s: Error occurred: %s\n\n%s"
 204                                                (muse-page-name) err
 205                                                (pp (quote ,body)))
 206                                        (if (featurep 'xemacs)
 207                                            'warning
 208                                          :warning))
 209                     (message "%s: Error occured: %s\n\n%s"
 210                              (muse-page-name) err (pp (quote ,body))))))))
 211          (when (buffer-live-p ,temp-buffer)
 212            (with-current-buffer ,temp-buffer
 213              (set-buffer-modified-p nil))
 214            (unless debug-on-error (kill-buffer ,temp-buffer)))))))
 215 (put 'muse-with-temp-buffer 'lisp-indent-function 0)
 216 (put 'muse-with-temp-buffer 'edebug-form-spec '(body))
 217
 218 ;; The following code was extracted from cl
 219
 220 (defun muse-const-expr-p (x)
 221   (cond ((consp x)
 222          (or (eq (car x) 'quote)
 223              (and (memq (car x) '(function function*))
 224                   (or (symbolp (nth 1 x))
 225                       (and (eq (and (consp (nth 1 x))
 226                                     (car (nth 1 x))) 'lambda) 'func)))))
 227         ((symbolp x) (and (memq x '(nil t)) t))
 228         (t t)))
 229
 230 (put 'muse-assertion-failed 'error-conditions '(error))
 231 (put 'muse-assertion-failed 'error-message "Assertion failed")
 232
 233 (defun muse-list* (arg &rest rest)
 234   "Return a new list with specified args as elements, cons'd to last arg.
 235 Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to
 236 `(cons A (cons B (cons C D)))'."
 237   (cond ((not rest) arg)
 238         ((not (cdr rest)) (cons arg (car rest)))
 239         (t (let* ((n (length rest))
 240                   (copy (copy-sequence rest))
 241                   (last (nthcdr (- n 2) copy)))
 242              (setcdr last (car (cdr last)))
 243              (cons arg copy)))))
 244
 245 (defmacro muse-assert (form &optional show-args string &rest args)
 246   "Verify that FORM returns non-nil; signal an error if not.
 247 Second arg SHOW-ARGS means to include arguments of FORM in message.
 248 Other args STRING and ARGS... are arguments to be passed to `error'.
 249 They are not evaluated unless the assertion fails.  If STRING is
 250 omitted, a default message listing FORM itself is used."
 251   (let ((sargs
 252          (and show-args
 253               (delq nil (mapcar
 254                          (function
 255                           (lambda (x)
 256                             (and (not (muse-const-expr-p x)) x)))
 257                          (cdr form))))))
 258     (list 'progn
 259           (list 'or form
 260                 (if string
 261                     (muse-list* 'error string (append sargs args))
 262                   (list 'signal '(quote muse-assertion-failed)
 263                         (muse-list* 'list (list 'quote form) sargs))))
 264           nil)))
 265
 266 ;; Compatibility functions
 267
 268 (defun muse-looking-back (regexp &optional limit)
 269   (if (fboundp 'looking-back)
 270       (looking-back regexp limit)
 271     (save-excursion
 272       (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t))))
 273
 274 (defun muse-line-end-position (&optional n)
 275   (if (fboundp 'line-end-position)
 276       (line-end-position n)
 277     (save-excursion (end-of-line n) (point))))
 278
 279 (defun muse-line-beginning-position (&optional n)
 280   (if (fboundp 'line-beginning-position)
 281       (line-beginning-position n)
 282     (save-excursion (beginning-of-line n) (point))))
 283
 284 (defun muse-match-string-no-properties (num &optional string)
 285   (if (fboundp 'match-string-no-properties)
 286       (match-string-no-properties num string)
 287     (match-string num string)))
 288
 289 (defun muse-replace-regexp-in-string (regexp replacement text &optional fixedcase literal)
 290   "Replace REGEXP with REPLACEMENT in TEXT.
 291 If fourth arg FIXEDCASE is non-nil, do not alter case of replacement text.
 292 If fifth arg LITERAL is non-nil, insert REPLACEMENT literally."
 293   (cond
 294    ((fboundp 'replace-regexp-in-string)
 295     (replace-regexp-in-string regexp replacement text fixedcase literal))
 296    ((fboundp 'replace-in-string)
 297     (replace-in-string text regexp replacement literal))
 298    (t (while (string-match regexp text)
 299         (setq text (replace-match replacement fixedcase literal text)))
 300       text)))
 301
 302 (defun muse-add-to-invisibility-spec (element)
 303   "Add ELEMENT to `buffer-invisibility-spec'.
 304 See documentation for `buffer-invisibility-spec' for the kind of elements
 305 that can be added."
 306   (if (fboundp 'add-to-invisibility-spec)
 307       (add-to-invisibility-spec element)
 308     (if (eq buffer-invisibility-spec t)
 309         (setq buffer-invisibility-spec (list t)))
 310     (setq buffer-invisibility-spec
 311           (cons element buffer-invisibility-spec))))
 312
 313 ;; Widget compatibility functions
 314
 315 (defun muse-widget-type-value-create (widget)
 316   "Convert and instantiate the value of the :type attribute of WIDGET.
 317 Store the newly created widget in the :children attribute.
 318
 319 The value of the :type attribute should be an unconverted widget type."
 320   (let ((value (widget-get widget :value))
 321         (type (widget-get widget :type)))
 322     (widget-put widget :children
 323                 (list (widget-create-child-value widget
 324                                                  (widget-convert type)
 325                                                  value)))))
 326
 327 (defun muse-widget-child-value-get (widget)
 328   "Get the value of the first member of :children in WIDGET."
 329   (widget-value (car (widget-get widget :children))))
 330
 331 (defun muse-widget-type-match (widget value)
 332   "Non-nil if the :type value of WIDGET matches VALUE.
 333
 334 The value of the :type attribute should be an unconverted widget type."
 335   (widget-apply (widget-convert (widget-get widget :type)) :match value))
 336
 337 ;; Link-handling functions and variables
 338
 339 (defun muse-handle-url (&optional string)
 340   "If STRING or point has a URL, match and return it."
 341   (if (if string (string-match muse-url-regexp string)
 342         (looking-at muse-url-regexp))
 343       (match-string 0 string)))
 344
 345 (defcustom muse-implicit-link-functions '(muse-handle-url)
 346   "A list of functions to handle an implicit link.
 347 An implicit link is one that is not surrounded by brackets.
 348
 349 By default, Muse handles URLs only.
 350 If you want to handle WikiWords, load muse-wiki.el."
 351   :type 'hook
 352   :options '(muse-handle-url)
 353   :group 'muse)
 354
 355 (defun muse-handle-implicit-link (&optional link)
 356   "Handle implicit links.  If LINK is not specified, look at point.
 357 An implicit link is one that is not surrounded by brackets.
 358 By default, Muse handles URLs only.
 359 If you want to handle WikiWords, load muse-wiki.el.
 360
 361 This function modifies the match data so that match 1 is the
 362 link.  Match 2 will usually be nil, unless the description is
 363 embedded in the text of the buffer.
 364
 365 The match data is restored after each unsuccessful handler
 366 function call.  If LINK is specified, only restore at very end.
 367
 368 This behavior is needed because the part of the buffer that
 369 `muse-implicit-link-regexp' matches must be narrowed to the part
 370 that is an accepted link."
 371   (let ((funcs muse-implicit-link-functions)
 372         (res nil)
 373         (data (match-data t)))
 374     (while funcs
 375       (setq res (funcall (car funcs) link))
 376       (if res
 377           (setq funcs nil)
 378         (unless link (set-match-data data))
 379         (setq funcs (cdr funcs))))
 380     (when link (set-match-data data))
 381     res))
 382
 383 (defcustom muse-explicit-link-functions nil
 384   "A list of functions to handle an explicit link.
 385 An explicit link is one [[like][this]] or [[this]]."
 386   :type 'hook
 387   :group 'muse)
 388
 389 (defun muse-handle-explicit-link (&optional link)
 390   "Handle explicit links.  If LINK is not specified, look at point.
 391 An explicit link is one that looks [[like][this]] or [[this]].
 392
 393 This function modifies the match data so that match 1 is the link
 394 and match 2 is the description.  Perhaps someday match 3 might be
 395 the text to use for the alt element of an <a> or <img> tag.
 396
 397 The match data is saved.  If no handlers are able to process
 398 LINK, return LINK (if specified) or the 1st match string.  If
 399 LINK is not specified, it is assumed that Muse has matched
 400 against `muse-explicit-link-regexp' before calling this
 401 function."
 402   (let ((funcs muse-explicit-link-functions)
 403         (res nil))
 404     (save-match-data
 405       (while funcs
 406         (setq res (funcall (car funcs) link))
 407         (if res
 408             (setq funcs nil)
 409           (setq funcs (cdr funcs)))))
 410     (if res
 411         res
 412       (or link (match-string 1)))))
 413
 414 (provide 'muse)
 415
 416 ;;; muse.el ends here