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