lisp/muse.el

   1 ;;; muse.el --- an authoring and publishing tool for Emacs
   2
   3 ;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc.
   4
   5 ;; Emacs Lisp Archive Entry
   6 ;; Filename: muse.el
   7 ;; Version: 3.02.6
   8 ;; Date: Sat 12-Jan-2006
   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/EmacsMuse.html
  14 ;; Compatibility: Emacs21 XEmacs21 Emacs22
  15
  16 ;; This file is part of Emacs Muse.  It is not part of GNU Emacs.
  17
  18 ;; Emacs Muse is free software; you can redistribute it and/or modify
  19 ;; it under the terms of the GNU General Public License as published
  20 ;; by the Free Software Foundation; either version 2, or (at your
  21 ;; option) any later version.
  22
  23 ;; Emacs Muse is distributed in the hope that it will be useful, but
  24 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  25 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  26 ;; General Public License for more details.
  27
  28 ;; You should have received a copy of the GNU General Public License
  29 ;; along with Emacs Muse; 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 manual for more
  42 ;; information.
  43
  44 ;;; Contributors:
  45
  46 ;;; Code:
  47
  48 (defvar muse-version "3.02.6"
  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 "muse"
  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 ;; URL protocols
 130
 131 (require 'muse-protocols)
 132
 133 ;;; Return an list of known wiki names and the files they represent.
 134
 135 (defsubst muse-delete-file-if-exists (file)
 136   (when (file-exists-p file)
 137     (delete-file file)
 138     (message "Removed %s" file)))
 139
 140 (defsubst muse-time-less-p (t1 t2)
 141   "Say whether time T1 is less than time T2."
 142   (or (< (car t1) (car t2))
 143       (and (= (car t1) (car t2))
 144            (< (nth 1 t1) (nth 1 t2)))))
 145
 146 (eval-when-compile
 147   (defvar muse-publishing-current-file nil))
 148
 149 (defun muse-current-file ()
 150   "Return the name of the currently visited or published file."
 151   (or (and (boundp 'muse-publishing-current-file)
 152            muse-publishing-current-file)
 153       (buffer-file-name)
 154       (concat default-directory (buffer-name))))
 155
 156 (defun muse-page-name (&optional name)
 157   "Return the canonical form of a Muse page name.
 158 All this means is that certain extensions, like .gz, are removed."
 159   (save-match-data
 160     (unless (and name (not (string= name "")))
 161       (setq name (muse-current-file)))
 162     (if name
 163         (let ((page (file-name-nondirectory name)))
 164           (if (and muse-ignored-extensions-regexp
 165                    (string-match muse-ignored-extensions-regexp page))
 166               (replace-match "" t t page)
 167             page)))))
 168
 169 (defun muse-display-warning (message)
 170   "Display the given MESSAGE as a warning."
 171   (if (fboundp 'display-warning)
 172       (display-warning 'muse message
 173                        (if (featurep 'xemacs)
 174                            'warning
 175                          :warning))
 176     (message message)))
 177
 178 (defun muse-eval-lisp (form)
 179   "Evaluate the given form and return the result as a string."
 180   (require 'pp)
 181   (save-match-data
 182     (condition-case err
 183         (let ((object (eval (read form))))
 184           (cond
 185            ((stringp object) object)
 186            ((and (listp object)
 187                  (not (eq object nil)))
 188             (let ((string (pp-to-string object)))
 189               (substring string 0 (1- (length string)))))
 190            ((numberp object)
 191             (number-to-string object))
 192            ((eq object nil) "")
 193            (t
 194             (pp-to-string object))))
 195       (error
 196        (muse-display-warning (format "%s: Error evaluating %s: %s"
 197                                      (muse-page-name) form err))
 198        "; INVALID LISP CODE"))))
 199
 200 (defmacro muse-with-temp-buffer (&rest body)
 201   "Create a temporary buffer, and evaluate BODY there like `progn'.
 202 See also `with-temp-file' and `with-output-to-string'.
 203 Unlike `with-temp-buffer', this will never attempt to save the temp buffer.
 204 It is meant to be used along with `insert-file-contents'."
 205   (let ((temp-buffer (make-symbol "temp-buffer")))
 206     `(let ((,temp-buffer (generate-new-buffer " *muse-temp*")))
 207        (unwind-protect
 208            (if debug-on-error
 209                (with-current-buffer ,temp-buffer
 210                  ,@body)
 211              (condition-case err
 212                  (with-current-buffer ,temp-buffer
 213                    ,@body)
 214                (error
 215                 (if (and (boundp 'muse-batch-publishing-p)
 216                          muse-batch-publishing-p)
 217                     (progn
 218                       (message "%s: Error occured: %s"
 219                                (muse-page-name) err)
 220                       (backtrace))
 221                   (muse-display-warning
 222                    (format (concat "An error occurred while publishing"
 223                                    " %s: %s\n\nSet debug-on-error to"
 224                                    " `t' if you would like a backtrace.")
 225                                  (muse-page-name) err))))))
 226          (when (buffer-live-p ,temp-buffer)
 227            (with-current-buffer ,temp-buffer
 228              (set-buffer-modified-p nil))
 229            (unless debug-on-error (kill-buffer ,temp-buffer)))))))
 230 (put 'muse-with-temp-buffer 'lisp-indent-function 0)
 231 (put 'muse-with-temp-buffer 'edebug-form-spec '(body))
 232
 233 ;; The following code was extracted from cl
 234
 235 (defun muse-const-expr-p (x)
 236   (cond ((consp x)
 237          (or (eq (car x) 'quote)
 238              (and (memq (car x) '(function function*))
 239                   (or (symbolp (nth 1 x))
 240                       (and (eq (and (consp (nth 1 x))
 241                                     (car (nth 1 x))) 'lambda) 'func)))))
 242         ((symbolp x) (and (memq x '(nil t)) t))
 243         (t t)))
 244
 245 (put 'muse-assertion-failed 'error-conditions '(error))
 246 (put 'muse-assertion-failed 'error-message "Assertion failed")
 247
 248 (defun muse-list* (arg &rest rest)
 249   "Return a new list with specified args as elements, cons'd to last arg.
 250 Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to
 251 `(cons A (cons B (cons C D)))'."
 252   (cond ((not rest) arg)
 253         ((not (cdr rest)) (cons arg (car rest)))
 254         (t (let* ((n (length rest))
 255                   (copy (copy-sequence rest))
 256                   (last (nthcdr (- n 2) copy)))
 257              (setcdr last (car (cdr last)))
 258              (cons arg copy)))))
 259
 260 (defmacro muse-assert (form &optional show-args string &rest args)
 261   "Verify that FORM returns non-nil; signal an error if not.
 262 Second arg SHOW-ARGS means to include arguments of FORM in message.
 263 Other args STRING and ARGS... are arguments to be passed to `error'.
 264 They are not evaluated unless the assertion fails.  If STRING is
 265 omitted, a default message listing FORM itself is used."
 266   (let ((sargs
 267          (and show-args
 268               (delq nil (mapcar
 269                          (function
 270                           (lambda (x)
 271                             (and (not (muse-const-expr-p x)) x)))
 272                          (cdr form))))))
 273     (list 'progn
 274           (list 'or form
 275                 (if string
 276                     (muse-list* 'error string (append sargs args))
 277                   (list 'signal '(quote muse-assertion-failed)
 278                         (muse-list* 'list (list 'quote form) sargs))))
 279           nil)))
 280
 281 ;; Compatibility functions
 282
 283 (defun muse-looking-back (regexp &optional limit)
 284   (if (fboundp 'looking-back)
 285       (looking-back regexp limit)
 286     (save-excursion
 287       (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t))))
 288
 289 (defun muse-line-end-position (&optional n)
 290   (if (fboundp 'line-end-position)
 291       (line-end-position n)
 292     (save-excursion (end-of-line n) (point))))
 293
 294 (defun muse-line-beginning-position (&optional n)
 295   (if (fboundp 'line-beginning-position)
 296       (line-beginning-position n)
 297     (save-excursion (beginning-of-line n) (point))))
 298
 299 (defun muse-match-string-no-properties (num &optional string)
 300   (if (fboundp 'match-string-no-properties)
 301       (match-string-no-properties num string)
 302     (match-string num string)))
 303
 304 (defun muse-replace-regexp-in-string (regexp replacement text &optional fixedcase literal)
 305   "Replace REGEXP with REPLACEMENT in TEXT.
 306 If fourth arg FIXEDCASE is non-nil, do not alter case of replacement text.
 307 If fifth arg LITERAL is non-nil, insert REPLACEMENT literally."
 308   (cond
 309    ((fboundp 'replace-in-string)
 310     (replace-in-string text regexp replacement literal))
 311    ((fboundp 'replace-regexp-in-string)
 312     (replace-regexp-in-string regexp replacement text fixedcase literal))
 313    (t (let ((repl-len (length replacement))
 314             start)
 315         (while (setq start (string-match regexp text start))
 316           (setq start (+ start repl-len)
 317                 text (replace-match replacement fixedcase literal text))))
 318       text)))
 319
 320 (defun muse-add-to-invisibility-spec (element)
 321   "Add ELEMENT to `buffer-invisibility-spec'.
 322 See documentation for `buffer-invisibility-spec' for the kind of elements
 323 that can be added."
 324   (if (fboundp 'add-to-invisibility-spec)
 325       (add-to-invisibility-spec element)
 326     (if (eq buffer-invisibility-spec t)
 327         (setq buffer-invisibility-spec (list t)))
 328     (setq buffer-invisibility-spec
 329           (cons element buffer-invisibility-spec))))
 330
 331 (defun muse-read-directory-name (prompt &optional dir default-dirname mustmatch initial)
 332   "Read directory name - see `read-file-name' for details."
 333   (if (fboundp 'read-directory-name)
 334       (read-directory-name prompt dir default-dirname mustmatch initial)
 335     (unless dir
 336       (setq dir default-directory))
 337     (read-file-name prompt dir (or default-dirname
 338                                    (if initial (expand-file-name initial dir)
 339                                      dir))
 340                     mustmatch initial)))
 341
 342 ;; Widget compatibility functions
 343
 344 (defun muse-widget-type-value-create (widget)
 345   "Convert and instantiate the value of the :type attribute of WIDGET.
 346 Store the newly created widget in the :children attribute.
 347
 348 The value of the :type attribute should be an unconverted widget type."
 349   (let ((value (widget-get widget :value))
 350         (type (widget-get widget :type)))
 351     (widget-put widget :children
 352                 (list (widget-create-child-value widget
 353                                                  (widget-convert type)
 354                                                  value)))))
 355
 356 (defun muse-widget-child-value-get (widget)
 357   "Get the value of the first member of :children in WIDGET."
 358   (widget-value (car (widget-get widget :children))))
 359
 360 (defun muse-widget-type-match (widget value)
 361   "Non-nil if the :type value of WIDGET matches VALUE.
 362
 363 The value of the :type attribute should be an unconverted widget type."
 364   (widget-apply (widget-convert (widget-get widget :type)) :match value))
 365
 366 ;; Link-handling functions and variables
 367
 368 (defun muse-get-link (&optional target)
 369   "Based on the match data, retrieve the link.
 370 Use TARGET to get the string, if it is specified."
 371   (muse-match-string-no-properties 1 target))
 372
 373 (defun muse-get-link-desc (&optional target)
 374   "Based on the match data, retrieve the link description.
 375 Use TARGET to get the string, if it is specified."
 376   (muse-match-string-no-properties 2 target))
 377
 378 (defun muse-link-escape (text)
 379   "Escape characters in TEXT that conflict with the explicit link
 380 regexp."
 381   (if text
 382       (progn
 383         (muse-replace-regexp-in-string "\\[" "%5B" text t t)
 384         (muse-replace-regexp-in-string "\\]" "%5D" text t t)
 385         text)
 386     ""))
 387
 388 (defun muse-link-unescape (text)
 389   "Un-escape characters in TEXT that conflict with the explicit
 390 link regexp."
 391   (if text
 392       (progn
 393         (muse-replace-regexp-in-string "%5B" "[" text t t)
 394         (muse-replace-regexp-in-string "%5D" "]" text t t)
 395         text)
 396     ""))
 397
 398 (defun muse-handle-url (&optional string)
 399   "If STRING or point has a URL, match and return it."
 400   (if (if string (string-match muse-url-regexp string)
 401         (looking-at muse-url-regexp))
 402       (match-string 0 string)))
 403
 404 (defcustom muse-implicit-link-functions '(muse-handle-url)
 405   "A list of functions to handle an implicit link.
 406 An implicit link is one that is not surrounded by brackets.
 407
 408 By default, Muse handles URLs only.
 409 If you want to handle WikiWords, load muse-wiki.el."
 410   :type 'hook
 411   :options '(muse-handle-url)
 412   :group 'muse)
 413
 414 (defun muse-handle-implicit-link (&optional link)
 415   "Handle implicit links.  If LINK is not specified, look at point.
 416 An implicit link is one that is not surrounded by brackets.
 417 By default, Muse handles URLs only.
 418 If you want to handle WikiWords, load muse-wiki.el.
 419
 420 This function modifies the match data so that match 1 is the
 421 link.  Match 2 will usually be nil, unless the description is
 422 embedded in the text of the buffer.
 423
 424 The match data is restored after each unsuccessful handler
 425 function call.  If LINK is specified, only restore at very end.
 426
 427 This behavior is needed because the part of the buffer that
 428 `muse-implicit-link-regexp' matches must be narrowed to the part
 429 that is an accepted link."
 430   (let ((funcs muse-implicit-link-functions)
 431         (res nil)
 432         (data (match-data t)))
 433     (while funcs
 434       (setq res (funcall (car funcs) link))
 435       (if res
 436           (setq funcs nil)
 437         (unless link (set-match-data data))
 438         (setq funcs (cdr funcs))))
 439     (when link (set-match-data data))
 440     res))
 441
 442 (defcustom muse-explicit-link-functions nil
 443   "A list of functions to handle an explicit link.
 444 An explicit link is one [[like][this]] or [[this]]."
 445   :type 'hook
 446   :group 'muse)
 447
 448 (defun muse-handle-explicit-link (&optional link)
 449   "Handle explicit links.  If LINK is not specified, look at point.
 450 An explicit link is one that looks [[like][this]] or [[this]].
 451
 452 This function modifies the match data so that match 1 is the link
 453 and match 2 is the description.  Perhaps someday match 3 might be
 454 the text to use for the alt element of an <a> or <img> tag.
 455
 456 The match data is saved.  If no handlers are able to process
 457 LINK, return LINK (if specified) or the 1st match string.  If
 458 LINK is not specified, it is assumed that Muse has matched
 459 against `muse-explicit-link-regexp' before calling this
 460 function."
 461   (let ((funcs muse-explicit-link-functions)
 462         (res nil))
 463     (save-match-data
 464       (while funcs
 465         (setq res (funcall (car funcs) link))
 466         (if res
 467             (setq funcs nil)
 468           (setq funcs (cdr funcs)))))
 469     (muse-link-unescape
 470      (if res
 471          res
 472        (or link (muse-get-link))))))
 473
 474 ;; Movement functions
 475
 476 (defun muse-list-item-type (str)
 477 "Determine the type of list given STR.
 478 Returns either 'ul, 'ol, 'dl-term, or 'dl-entry."
 479   (cond ((or (string= str "")
 480              (< (length str) 2))
 481          nil)
 482         ((and (= (aref str 0) ?\  )
 483               (= (aref str 1) ?-))
 484          'ul)
 485         ((save-match-data
 486            (string-match (concat "\\`[" muse-regexp-blank "][0-9]+\\.") str))
 487          'ol)
 488         ((save-match-data
 489            (not (string-match (concat "\\`[" muse-regexp-blank "]*::") str)))
 490          ;; if str is not any kind of list, it will be interpreted as
 491          ;; a dl-term
 492          'dl-term)
 493         (t 'dl-entry)))
 494
 495 (defun muse-forward-paragraph (&optional pattern)
 496   (when (get-text-property (point) 'end-list)
 497     (goto-char (next-single-property-change (point) 'end-list)))
 498   (let ((next-list-end (or (next-single-property-change (point) 'end-list)
 499                            (point-max))))
 500     (forward-line 1)
 501     (if (re-search-forward (if pattern
 502                                (concat "^\\(?:" pattern "\\|\n\\|\\'\\)")
 503                              "^\\s-*\\(\n\\|\\'\\)") nil t)
 504         (goto-char (match-beginning 0))
 505       (goto-char (point-max)))
 506     (when (> (point) next-list-end)
 507       (goto-char next-list-end))))
 508
 509 (defun muse-forward-list-item-1 (type empty-line indented-line)
 510   "Determine whether a nested list item is after point."
 511   (if (match-beginning 1)
 512       ;; if we are given a dl entry, skip past everything on the same
 513       ;; level, except for other dl entries
 514       (and (eq type 'dl-entry)
 515            (not (eq (char-after (match-beginning 2)) ?\:)))
 516     ;; blank line encountered with no list item on the same
 517     ;; level after it
 518     (let ((beg (point)))
 519       (forward-line 1)
 520       (if (save-match-data
 521             (and (looking-at indented-line)
 522                  (not (looking-at empty-line))))
 523           ;; found that this blank line is followed by some
 524           ;; indentation, plus other text, so we'll keep
 525           ;; going
 526           t
 527         (goto-char beg)
 528         nil))))
 529
 530 (defun muse-forward-list-item (type indent &optional no-skip-nested)
 531   "Move forward to the next item of TYPE.
 532 Return non-nil if successful, nil otherwise.
 533 The beginning indentation is given by INDENT.
 534
 535 If NO-SKIP-NESTED is non-nil, do not skip past nested items.
 536 Note that if you desire this behavior, you will also need to
 537 provide a very liberal INDENT value, such as
 538 \(concat \"[\" muse-regexp-blank \"]*\")."
 539   (let* ((list-item (format muse-list-item-regexp indent))
 540          (empty-line (concat "^[" muse-regexp-blank "]*\n"))
 541          (indented-line (concat "^" indent "[" muse-regexp-blank "]"))
 542          (list-pattern (concat "\\(?:" empty-line "\\)?"
 543                                "\\(" list-item "\\)")))
 544     (while (progn
 545              (muse-forward-paragraph list-pattern)
 546              ;; make sure we don't go past boundary
 547              (and (not no-skip-nested)
 548                   (not (or (get-text-property (point) 'end-list)
 549                            (>= (point) (point-max))))
 550                   (muse-forward-list-item-1 type empty-line indented-line))))
 551     (cond ((or (get-text-property (point) 'end-list)
 552                (>= (point) (point-max)))
 553            ;; at a list boundary, so stop
 554            nil)
 555           ((and (match-string 2)
 556                 (eq type (muse-list-item-type (match-string 2))))
 557            ;; same type, so indicate that there are more items to be
 558            ;; parsed
 559            (goto-char (match-beginning 1)))
 560           (t
 561            (when (match-beginning 1)
 562              (goto-char (match-beginning 1)))
 563            ;; move to just before foreign list item markup
 564            nil))))
 565
 566 (provide 'muse)
 567
 568 ;;; muse.el ends here