muse-publish.el

   1 ;;; muse-publish.el --- Base publishing implementation.
   2
   3 ;; Copyright (C) 2004, 2005  Free Software Foundation, Inc.
   4
   5 ;; This file is not part of GNU Emacs.
   6
   7 ;; This is free software; you can redistribute it and/or modify it under
   8 ;; the terms of the GNU General Public License as published by the Free
   9 ;; Software Foundation; either version 2, or (at your option) any later
  10 ;; version.
  11 ;;
  12 ;; This is distributed in the hope that it will be useful, but WITHOUT
  13 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 ;; for more details.
  16 ;;
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  19 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  20 ;; Boston, MA 02110-1301, USA.
  21
  22 ;;; Commentary:
  23
  24 ;;; Contributors:
  25
  26 ;; Yann Hodique (yann DOT hodique AT gmail DOT com) fixed an
  27 ;; unnecessary URL description transform in `muse-publish-url'.
  28
  29 ;;; Code:
  30
  31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32 ;;
  33 ;; Muse Publishing
  34 ;;
  35 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36
  37 (require 'muse)
  38 (require 'muse-regexps)
  39
  40 (defgroup muse-publish nil
  41   "Options controlling the general behaviour of Muse publishing.
  42 See `muse-publish' for more information."
  43   :group 'muse)
  44
  45 (defcustom muse-before-publish-hook nil
  46   "A hook run in the buffer to be published, before it is done."
  47   :type 'hook
  48   :group 'muse-publish)
  49
  50 (defcustom muse-after-publish-hook nil
  51   "A hook run in the buffer to be published, after it is done."
  52   :type 'hook
  53   :group 'muse-publish)
  54
  55 (defcustom muse-publish-url-transforms '(muse-publish-prepare-url)
  56   "A list of functions used to prepare URLs for publication.
  57 Each is passed the URL and expects a URL to be returned."
  58   :type 'hook
  59   :group 'muse-publish)
  60
  61 (defcustom muse-publish-report-threshhold 100000
  62   "If a file is this size or larger, report publishing progress."
  63   :type 'integer
  64   :group 'muse-publish)
  65
  66 (defcustom muse-publish-markup-regexps
  67   `(;; Remove leading and trailing whitespace from the file
  68     (1000 "\\(\\`\n+\\|\n+\\'\\)" 0 "")
  69
  70     ;; Remove trailing whitespace from all lines
  71     (1100 ,(concat "[" muse-regexp-blank "]+$") 0 "")
  72
  73     ;; Handle any leading #directives
  74     (1200 "\\`#\\([a-zA-Z]+\\)\\s-+\\(.+\\)\n+" 0 directive)
  75
  76     ;; markup tags
  77     (1300 muse-tag-regexp 0 tag)
  78
  79     ;; commented lines
  80     (1350 "^;\\s-+\\(.+\\)" 0 comment)
  81
  82     ;; define anchor points
  83     (1400 "^#\\(\\S-+\\)\\s-*" 0 anchor)
  84
  85     ;; emphasized or literal text
  86     (1500 ,(concat
  87             "\\(^\\|[-["
  88             muse-regexp-space
  89             "<('`\"]\\)\\(=[^="
  90             muse-regexp-space
  91             "]\\|_[^_"
  92             muse-regexp-space
  93             "]\\|\\*+[^*"
  94             muse-regexp-space
  95             "]\\)")
  96           2 word)
  97
  98     ;; headings, outline-mode style
  99     (1600 "^\\(\\*+\\)\\s-+" 0 heading)
 100
 101     ;; ellipses
 102     (1700 "\\.\\.\\.\\." 0 enddots)
 103     (1800 "\\.\\.\\." 0 dots)
 104
 105     ;; horizontal rule, or section separator
 106     (1900 "^----+" 0 rule)
 107
 108     (2000 ,(concat "\n*\\(^\\|["
 109                    muse-regexp-blank
 110                    "]+\\)--\\($\\|["
 111                    muse-regexp-blank
 112                    "]+\\)")
 113           0 emdash)
 114
 115     ;; beginning of footnotes section
 116     (2100 "^Footnotes:?\\s-*" 0 fn-sep)
 117     ;; footnote definition/reference (def if at beginning of line)
 118     (2200 "\\[\\([1-9][0-9]*\\)\\]" 0 footnote)
 119
 120     ;; unnumbered List items begin with a -.  numbered list items
 121     ;; begin with number and a period.  definition lists have a
 122     ;; leading term separated from the body with ::.  centered
 123     ;; paragraphs begin with at least six columns of whitespace; any
 124     ;; other whitespace at the beginning indicates a blockquote.  The
 125     ;; reason all of these rules are handled here, is so that
 126     ;; blockquote detection doesn't interfere with indented list
 127     ;; members.
 128     (2300 ,(concat "^["
 129                    muse-regexp-blank
 130                    "]+\\(-["
 131                    muse-regexp-blank
 132                    "]*\\|[0-9]+\\.["
 133                    muse-regexp-blank
 134                    "]*\\|\\(?:.+?\\)["
 135                    muse-regexp-blank
 136                    "]+::\n?\\)")
 137           1 list)
 138
 139     (2400 ,(concat "^\\(\\(?:.+?\\)["
 140                    muse-regexp-blank
 141                    "]+::\n?\\)")
 142           0 list)
 143
 144     (2500 ,(concat "^\\(["
 145                    muse-regexp-blank
 146                    "]+\\)")
 147           0 quote)
 148
 149     ;; "verse" text is indicated the same way as a quoted e-mail
 150     ;; response: "> text", where text may contain initial whitespace
 151     ;; (see below).
 152     (2600 ,(concat "^["
 153                    muse-regexp-blank
 154                    "]*> ")
 155           0 verse)
 156
 157     ;; simple table markup is supported, nothing fancy.  use | to
 158     ;; separate cells, || to separate header cells, and ||| for footer
 159     ;; cells
 160     (2700 ,(concat "^["
 161                    muse-regexp-blank
 162                    "]*\\(.+?\\(["
 163                    muse-regexp-blank
 164                    "]+|+["
 165                    muse-regexp-blank
 166                    "]+.+?\\)\\)$")
 167           0 table)
 168
 169     ;; bare email addresses
 170     (2800
 171      "\\([^[]\\)[-a-zA-Z0-9._]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+" 0 email)
 172
 173     ;; replace links in the buffer (links to other pages)
 174     (2900 muse-link-regexp 0 link)
 175     (3000 muse-url-regexp  0 url))
 176   "List of markup rules for publishing a page with Muse.
 177 The rules given in this variable are invoked first, followed by
 178 whatever rules are specified by the current style.
 179
 180 Each member of the list is either a function, or a list of the form:
 181
 182   (REGEXP/SYMBOL TEXT-BEGIN-GROUP REPLACEMENT-TEXT/FUNCTION/SYMBOL)
 183
 184 REGEXP is a regular expression, or symbol whose value is a regular
 185 expression, which is searched for using `re-search-forward'.
 186 TEXT-BEGIN-GROUP is the matching group within that regexp which
 187 denotes the beginning of the actual text to be marked up.
 188 REPLACEMENT-TEXT is a string that will be passed to `replace-match'.
 189 If it is not a string, but a function, it will be called to determine
 190 what the replacement text should be (it must return a string).  If it
 191 is a symbol, the value of that symbol should be a string.
 192
 193 The replacements are done in order, one rule at a time.  Writing
 194 the regular expressions can be a tricky business.  Note that case
 195 is never ignored.  `case-fold-search' is always bound to nil
 196 while processing the markup rules."
 197   :type '(repeat (choice
 198                   (list :tag "Markup rule"
 199                         integer
 200                         (choice regexp symbol)
 201                         integer
 202                         (choice string function symbol))
 203                   function))
 204   :group 'muse-publish)
 205
 206 (defcustom muse-publish-markup-functions
 207   '((directive . muse-publish-markup-directive)
 208     (comment   . muse-publish-markup-comment)
 209     (anchor    . muse-publish-markup-anchor)
 210     (tag       . muse-publish-markup-tag)
 211     (word      . muse-publish-markup-word)
 212     (emdash    . muse-publish-markup-emdash)
 213     (enddots   . muse-publish-markup-enddots)
 214     (dots      . muse-publish-markup-dots)
 215     (rule      . muse-publish-markup-rule)
 216     (heading   . muse-publish-markup-heading)
 217     (footnote  . muse-publish-markup-footnote)
 218     (fn-sep    . muse-publish-markup-fn-sep)
 219     (list      . muse-publish-markup-list)
 220     (quote     . muse-publish-markup-quote)
 221     (verse     . muse-publish-markup-verse)
 222     (table     . muse-publish-markup-table)
 223     (email     . muse-publish-markup-email)
 224     (link      . muse-publish-markup-link)
 225     (url       . muse-publish-markup-url))
 226   "An alist of style types to custom functions for that kind of text."
 227   :type '(alist :key-type symbol :value-type function)
 228   :group 'muse-publish)
 229
 230 (defcustom muse-publish-markup-tags
 231   '(("contents" nil t   muse-publish-contents-tag)
 232     ("verse"    t   nil muse-publish-verse-tag)
 233     ("example"  t   nil muse-publish-example-tag)
 234     ("literal"  t   nil muse-publish-mark-read-only)
 235     ("verbatim" t   nil muse-publish-verbatim-tag)
 236     ("lisp"     t   nil muse-publish-lisp-tag)
 237     ("class"    t   t   muse-publish-class-tag)
 238     ("command"  t   t   muse-publish-command-tag)
 239     ("comment"  t   nil muse-publish-comment-tag))
 240   "A list of tag specifications, for specially marking up text.
 241 XML-style tags are the best way to add custom markup to Muse.
 242 This is easily accomplished by customizing this list of markup tags.
 243
 244 For each entry, the name of the tag is given, whether it expects
 245 a closing tag and/or an optional set of attributes, and a
 246 function that performs whatever action is desired within the
 247 delimited region.
 248
 249 The tags themselves are deleted during publishing, before the
 250 function is called.  The function is called with three arguments,
 251 the beginning and end of the region surrounded by the tags.  If
 252 properties are allowed, they are passed as a third argument in
 253 the form of an alist.  The `end' argument to the function is
 254 always a marker.
 255
 256 Point is always at the beginning of the region within the tags, when
 257 the function is called.  Wherever point is when the function finishes
 258 is where tag markup will resume.
 259
 260 These tag rules are processed once at the beginning of markup, and
 261 once at the end, to catch any tags which may have been inserted
 262 in-between."
 263   :type '(repeat (list (string :tag "Markup tag")
 264                        (boolean :tag "Expect closing tag" :value t)
 265                        (boolean :tag "Parse attributes" :value nil)
 266                        function))
 267   :group 'muse-publish)
 268
 269 (defcustom muse-publish-markup-specials nil
 270   "A table of characters which must be represented specially."
 271   :type '(alist :key-type character :value-type string)
 272   :group 'muse-publish)
 273
 274 (defvar muse-publishing-p nil
 275   "Set to t while a page is being published.")
 276 (defvar muse-batch-publishing-p nil
 277   "Set to t while a page is being batch published.")
 278 (defvar muse-publishing-styles nil)
 279 (defvar muse-publishing-current-file nil)
 280 (defvar muse-publishing-current-style nil)
 281 (defvar muse-publishing-directives nil
 282   "An alist of publishing directives from the top of a file.")
 283 (defvar muse-publish-generate-contents nil
 284   "Non-nil if a table of contents should be generated.
 285 If non-nil, it is a cons cell specifying (MARKER . DEPTH), to
 286 tell where the <contents> was seen, and to what depth the
 287 contents were requested.")
 288
 289 ;; Functions for handling style information
 290
 291 (defsubst muse-style (&optional style)
 292   "Resolve the given STYLE into a Muse style, if it is a string."
 293   (if (null style)
 294       muse-publishing-current-style
 295     (if (stringp style)
 296         (assoc style muse-publishing-styles)
 297       (muse-assert (consp style))
 298       style)))
 299
 300 (defun muse-define-style (name &rest elements)
 301   (let ((entry (assoc name muse-publishing-styles)))
 302     (if entry
 303         (error "There is already a style named %s." name)
 304       (setq muse-publishing-styles
 305             (cons (append (list name) elements)
 306                   muse-publishing-styles)))))
 307
 308 (defun muse-derive-style (new-name base-name &rest elements)
 309   (let ((entry (assoc new-name muse-publishing-styles)))
 310     (if entry
 311         (error "There is already a style named %s." new-name)
 312       (apply 'muse-define-style new-name
 313              (append elements (list :base base-name))))))
 314
 315 (defsubst muse-get-keyword (keyword list &optional direct)
 316   (let ((value (cadr (memq keyword list))))
 317     (if (and (not direct) (symbolp value))
 318         (symbol-value value)
 319       value)))
 320
 321 (defsubst muse-style-element (elem &optional style direct)
 322   (setq style (muse-style style))
 323   (let ((value (muse-get-keyword elem style direct)))
 324     (if value
 325         value
 326       (let ((base (muse-get-keyword :base style)))
 327         (if base
 328             (muse-style-element elem base direct))))))
 329
 330 (defun muse-find-markup-element (keyword ident style)
 331   (let ((def (assq ident (muse-style-element keyword style))))
 332     (if def
 333         (cdr def)
 334       (let ((base (muse-style-element :base style)))
 335         (if base
 336             (muse-find-markup-element keyword ident base))))))
 337
 338 (defsubst muse-markup-text (ident &rest args)
 339   (let ((text (muse-find-markup-element :strings ident (muse-style))))
 340     (if (and text args)
 341         (apply 'format text args)
 342       (or text ""))))
 343
 344 (defun muse-find-markup-tag (keyword tagname style)
 345   (let ((def (assoc tagname (muse-style-element keyword style))))
 346     (or def
 347         (let ((base (muse-style-element :base style)))
 348           (if base
 349               (muse-find-markup-tag keyword tagname base))))))
 350
 351 (defsubst muse-markup-tag-info (tagname &rest args)
 352   (let ((tag-info (muse-find-markup-tag :tags tagname (muse-style))))
 353     (or tag-info
 354         (assoc (match-string 1) muse-publish-markup-tags))))
 355
 356 (defsubst muse-markup-function (category)
 357   (let ((func (muse-find-markup-element :functions category (muse-style))))
 358     (or func
 359         (cdr (assq category muse-publish-markup-functions)))))
 360
 361 ;; Publishing routines
 362
 363 (defun muse-publish-markup (name rules)
 364   (let* ((case-fold-search nil)
 365          (inhibit-read-only t)
 366          (limit (* (length rules) (point-max)))
 367          (verbose (and muse-publish-report-threshhold
 368                        (> (point-max) muse-publish-report-threshhold)))
 369          (base 0))
 370     (while rules
 371       (goto-char (point-min))
 372       (let ((regexp (nth 1 (car rules)))
 373             (group (nth 2 (car rules)))
 374             (repl (nth 3 (car rules)))
 375             start last-pos pos)
 376         (if (symbolp regexp)
 377             (setq regexp (symbol-value regexp)))
 378         (if (and verbose (not muse-batch-publishing-p))
 379             (message "Publishing %s...%d%%" name
 380                      (* (/ (float (+ (point) base)) limit) 100)))
 381         (while (and regexp (setq pos (re-search-forward regexp nil t)))
 382           (if (and verbose (not muse-batch-publishing-p))
 383               (message "Publishing %s...%d%%" name
 384                        (* (/ (float (+ (point) base)) limit) 100)))
 385           (unless (get-text-property (match-beginning group) 'read-only)
 386             (let* (func
 387                    (text (cond
 388                           ((and (symbolp repl)
 389                                 (setq func (muse-markup-function repl)))
 390                            (funcall func))
 391                           ((functionp repl)
 392                            (funcall repl))
 393                           ((symbolp repl)
 394                            (symbol-value repl))
 395                           (t repl))))
 396               (if text
 397                   (replace-match text t))))
 398           (if (and last-pos (= pos last-pos))
 399               (if (eobp)
 400                   (setq regexp nil)
 401                 (forward-char 1)))
 402           (setq last-pos pos)))
 403       (setq rules (cdr rules)
 404             base (+ base (point-max))))
 405     (if (and verbose (not muse-batch-publishing-p))
 406         (message "Publishing %s...done" name))))
 407
 408 (defun muse-insert-file-or-string (file-or-string &optional title)
 409   (let ((beg (point)) end)
 410     (if (file-readable-p file-or-string)
 411         (setq end (+ beg (cadr (insert-file-contents file-or-string))))
 412       (insert file-or-string)
 413       (setq end (point)))
 414     (save-restriction
 415       (narrow-to-region beg end)
 416       (muse-publish-markup (or title "")
 417                            '((100 "<\\(lisp\\)>" 0
 418                               muse-publish-markup-tag))))))
 419
 420 (defun muse-style-run-hooks (keyword style &rest args)
 421   (let (handled)
 422     (while (and style (not handled))
 423       (setq style (muse-style style))
 424       (let ((func (muse-get-keyword keyword style t)))
 425         (if func
 426             (if (apply func args)
 427                 (setq handled t))))
 428       (unless handled
 429         (setq style (muse-style-element :base style))))
 430     handled))
 431
 432 (defun muse-publish-markup-region (beg end title style)
 433   "Apply the given STYLE's markup rules to the given region."
 434   (save-restriction
 435     (narrow-to-region beg end)
 436     (muse-style-run-hooks :before style)
 437     (muse-publish-markup
 438      title
 439      (sort (copy-alist (append muse-publish-markup-regexps
 440                                (muse-style-element :regexps style)))
 441            (function
 442             (lambda (l r)
 443               (< (car l) (car r))))))
 444     (muse-style-run-hooks :before-end style)))
 445
 446 (defun muse-publish-markup-buffer (title style)
 447   "Apply the given STYLE's markup rules to the current buffer."
 448   (setq style (muse-style style))
 449   (let ((style-header (muse-style-element :header style))
 450         (style-footer (muse-style-element :footer style))
 451         (muse-publishing-current-style style)
 452         (muse-publishing-directives
 453          (list (cons "title" title)
 454                (cons "author" (user-full-name))
 455                (cons "date" (format-time-string "%B %e, %Y"))))
 456         (muse-publishing-p t))
 457     (run-hooks 'muse-before-publish-hook)
 458     (muse-publish-markup-region (point-min) (point-max) title style)
 459     (goto-char (point-min))
 460     (if style-header (muse-insert-file-or-string style-header title))
 461     (goto-char (point-max))
 462     (if style-footer (muse-insert-file-or-string style-footer title))
 463     (muse-style-run-hooks :after style)
 464     (run-hooks 'muse-after-publish-hook)))
 465
 466 (defun muse-publish-markup-string (string &optional style)
 467   "Markup STRING using the given STYLE's markup rules."
 468   (setq style (muse-style style))
 469   (with-temp-buffer
 470     (insert string)
 471     (let ((muse-publishing-current-style style)
 472           (muse-publishing-p t))
 473       (muse-publish-markup "*string*" (muse-style-element :rules style)))
 474     (buffer-string)))
 475
 476 ;; Commands for publishing files
 477
 478 (defsubst muse-publish-get-style ()
 479   (if (= 1 (length muse-publishing-styles))
 480       (car muse-publishing-styles)
 481     (assoc (completing-read "Publish with style: "
 482                             muse-publishing-styles nil t)
 483            muse-publishing-styles)))
 484
 485 (defsubst muse-publish-get-output-dir (style)
 486   (let ((default-directory (or (muse-style-element :path style)
 487                                default-directory)))
 488     (read-file-name "Publish to directory: " nil default-directory)))
 489
 490 (defsubst muse-publish-get-info ()
 491   (let ((style (muse-publish-get-style)))
 492     (list style (muse-publish-get-output-dir style)
 493           current-prefix-arg)))
 494
 495 (defsubst muse-publish-output-name (&optional file style)
 496   (setq style (muse-style style))
 497   (concat (muse-style-element :prefix style)
 498           (muse-page-name (or file muse-publishing-current-file))
 499           (muse-style-element :suffix style)))
 500
 501 (defsubst muse-publish-output-file (file output-dir &optional style)
 502   (setq style (muse-style style))
 503   (expand-file-name (muse-publish-output-name file style) output-dir))
 504
 505 (defun muse-publish-file (file style &optional output-dir force)
 506   "Publish the given file in list FILES.
 507 If the argument FORCE is nil, each file is only published if it is
 508 newer than the published version.  If the argument FORCE is non-nil,
 509 the file is published no matter what."
 510   (interactive (cons (read-file-name "Publish file: ")
 511                      (muse-publish-get-info)))
 512   (setq style (muse-style style))
 513   (let* ((output-path (muse-publish-output-file file output-dir style))
 514          (output-suffix (muse-style-element :osuffix style))
 515          (muse-publishing-current-file file)
 516          (target (if output-suffix
 517                      (concat (file-name-sans-extension output-path)
 518                              output-suffix)
 519                    output-path)))
 520     (when (or force (file-newer-than-file-p file target))
 521       (if (and muse-publish-report-threshhold
 522                (> (nth 7 (file-attributes file))
 523                   muse-publish-report-threshhold))
 524           (message "Publishing %s ..." file))
 525       (with-temp-buffer
 526         (insert-file-contents file t)
 527         (muse-publish-markup-buffer (muse-page-name file) style)
 528         (let ((backup-inhibited t))
 529           (write-file output-path))
 530         (muse-style-run-hooks :final style file output-path target))
 531       t)))
 532
 533 (defun muse-publish-this-file (style output-dir &optional force)
 534   "Publish the page in the current file."
 535   (interactive (muse-publish-get-info))
 536   (muse-publish-file buffer-file-name style output-dir force))
 537
 538 (defun muse-batch-publish-files ()
 539   "Publish Muse files in batch mode."
 540   (let ((muse-batch-publishing-p t)
 541         style-name style output-dir)
 542     (setq style-name (car command-line-args-left)
 543           style (muse-style style-name)
 544           command-line-args-left (cdr command-line-args-left)
 545           output-dir (car command-line-args-left)
 546           output-dir
 547           (if (string-match "\\`--output-dir=" output-dir)
 548               (prog1
 549                   (substring output-dir (match-end 0))
 550                 (setq command-line-args-left (cdr command-line-args-left)))))
 551     (unless style
 552       (error "There is no style '%s' defined." style-name))
 553     (dolist (file command-line-args-left)
 554       (muse-publish-file file style output-dir t))))
 555
 556 ;; Default publishing rules
 557
 558 (defun muse-publish-markup-directive (&optional name value)
 559   (unless name (setq name (match-string 1)))
 560   (unless value (setq value (match-string 2)))
 561   (let ((elem (assoc name muse-publishing-directives)))
 562     (if elem
 563         (setcdr elem value)
 564       (setq muse-publishing-directives
 565             (cons (cons name value)
 566                   muse-publishing-directives))))
 567   (delete-region (match-beginning 0) (match-end 0)))
 568
 569 (defun muse-publish-markup-anchor () "")
 570 (defun muse-publish-markup-comment () "")
 571
 572 (defun muse-publish-markup-tag ()
 573   (let ((tag-info (muse-markup-tag-info (match-string 1))))
 574     (when (and tag-info
 575                (not (get-text-property (match-beginning 0) 'read-only)))
 576       (let ((closed-tag (match-string 3))
 577             (start (match-beginning 0))
 578             (beg (point)) end attrs)
 579         (when (nth 2 tag-info)
 580           (let ((attrstr (match-string 2)))
 581             (while (and attrstr
 582                         (string-match (concat "\\([^"
 583                                               muse-regexp-space
 584                                               "=]+\\)\\(=\"\\"
 585                                               "([^\"]+\\)\"\\)?")
 586                                       attrstr))
 587               (let ((attr (cons (downcase
 588                                  (match-string-no-properties 1 attrstr))
 589                                 (match-string-no-properties 3 attrstr))))
 590                 (setq attrstr (replace-match "" t t attrstr))
 591                 (if attrs
 592                     (nconc attrs (list attr))
 593                   (setq attrs (list attr)))))))
 594         (if (and (cadr tag-info) (not closed-tag))
 595             (if (search-forward (concat "</" (car tag-info) ">") nil t)
 596                 (delete-region (match-beginning 0) (point))
 597               (setq tag-info nil)))
 598         (when tag-info
 599           (setq end (point-marker))
 600           (delete-region start beg)
 601           (goto-char start)
 602           (let ((args (list start end)))
 603             (if (nth 2 tag-info)
 604                 (nconc args (list attrs)))
 605             (apply (nth 3 tag-info) args))))))
 606   nil)
 607
 608 (defun muse-publish-escape-specials (beg end)
 609   (save-excursion
 610     (goto-char beg)
 611     (while (< (point) end)
 612       (if (get-text-property (point) 'read-only)
 613           (forward-char 1)
 614         (let ((repl
 615                (or (assoc (char-after) (muse-style-element :specials))
 616                    (assoc (char-after) muse-publish-markup-specials))))
 617           (if (null repl)
 618               (forward-char 1)
 619             (delete-char 1)
 620             (insert (cdr repl))))))))
 621
 622 (defun muse-publish-markup-word ()
 623   (let* ((beg (match-beginning 2))
 624          (end (1- (match-end 2)))
 625          (leader (buffer-substring-no-properties beg end))
 626          open-tag close-tag mark-read-only loc multi-line)
 627     (cond
 628      ((string= leader "_")
 629       (setq multi-line t)
 630       (setq open-tag (muse-markup-text 'begin-underline)
 631             close-tag (muse-markup-text 'end-underline)))
 632      ((string= leader "=")
 633       (setq open-tag (muse-markup-text 'begin-literal)
 634             close-tag (muse-markup-text 'end-literal))
 635       (setq mark-read-only t))
 636      (t
 637       (setq multi-line t)
 638       (let ((l (length leader)))
 639         (cond
 640          ((= l 1) (setq open-tag (muse-markup-text 'begin-emph)
 641                         close-tag (muse-markup-text 'end-emph)))
 642          ((= l 2) (setq open-tag (muse-markup-text 'begin-more-emph)
 643                         close-tag (muse-markup-text 'end-more-emph)))
 644          ((= l 3) (setq open-tag (muse-markup-text 'begin-most-emph)
 645                         close-tag (muse-markup-text 'end-most-emph)))))))
 646     (if (and (setq loc (search-forward leader nil t))
 647              (eq 0 (skip-syntax-forward "w" (1+ loc)))
 648              (or multi-line (= 1 (count-lines beg loc))))
 649         (progn
 650           (replace-match "")
 651           (delete-region beg end)
 652           (setq end (point-marker))
 653           (insert close-tag)
 654           (save-excursion
 655             (goto-char beg)
 656             (insert open-tag)
 657             (setq beg (point)))
 658           (when mark-read-only
 659             (muse-publish-escape-specials beg end)
 660             (muse-publish-mark-read-only (1- beg) (1+ end))))
 661       (backward-char))
 662     nil))
 663
 664 (defun muse-publish-markup-emdash ()
 665   (delete-region (match-beginning 0) (match-end 0))
 666   (insert (muse-markup-text 'emdash))
 667   (if (eq (char-after) ?\<)
 668       (insert ?\n)))
 669
 670 (defun muse-publish-markup-enddots ()
 671   (delete-region (match-beginning 0) (match-end 0))
 672   (insert (muse-markup-text 'enddots)))
 673
 674 (defun muse-publish-markup-dots ()
 675   (delete-region (match-beginning 0) (match-end 0))
 676   (insert (muse-markup-text 'dots)))
 677
 678 (defun muse-publish-markup-rule ()
 679   (delete-region (match-beginning 0) (match-end 0))
 680   (insert (muse-markup-text 'rule)))
 681
 682 (defun muse-publish-markup-heading ()
 683   (let* ((len (length (match-string 1)))
 684          (start (muse-markup-text
 685                  (cond ((= len 1) 'section)
 686                        ((= len 2) 'subsection)
 687                        ((= len 3) 'subsubsection))))
 688          (end   (muse-markup-text
 689                  (cond ((= len 1) 'section-end)
 690                        ((= len 2) 'subsection-end)
 691                        ((= len 3) 'subsubsection-end)))))
 692     (delete-region (match-beginning 0) (match-end 0))
 693     (insert start)
 694     (end-of-line)
 695     (if end (insert end))))
 696
 697 (defvar muse-publish-footnotes nil)
 698
 699 (defun muse-publish-markup-footnote ()
 700   "Scan ahead and snarf up the footnote body"
 701   (if (= (line-beginning-position) (match-beginning 0))
 702       ""
 703     (let ((footnote (save-match-data
 704                       (string-to-number (match-string 1))))
 705           footnotemark)
 706       (delete-region (match-beginning 0) (match-end 0))
 707       (save-excursion
 708         (when (re-search-forward (format "^\\[%d\\]\\s-+" footnote) nil t)
 709           (let* ((start (match-beginning 0))
 710                  (beg (goto-char (match-end 0)))
 711                  (end (save-excursion
 712                         (if (search-forward "\n\n" nil t)
 713                             (copy-marker (match-beginning 0))
 714                           (goto-char (point-max))
 715                           (skip-chars-backward "\n")
 716                           (point-marker)))))
 717             (while (re-search-forward (concat "^["
 718                                               muse-regexp-blank
 719                                               "]+\\([^\n]\\)")
 720                                       end t)
 721               (replace-match "\\1" t))
 722             (let ((footnotemark-cmd (muse-markup-text 'footnotemark))
 723                   (footnotemark-end-cmd (muse-markup-text 'footnotemark-end)))
 724               (if (string= "" footnotemark-cmd)
 725                   (setq footnotemark
 726                         (concat (muse-markup-text 'footnote)
 727                                 (buffer-substring-no-properties beg end)
 728                                 (muse-markup-text 'footnote-end)))
 729                 (setq footnotemark (format footnotemark-cmd footnote
 730                                            footnotemark-end-cmd))
 731                 (unless muse-publish-footnotes
 732                   (set (make-local-variable 'muse-publish-footnotes)
 733                        (make-vector 256 nil)))
 734                 (unless (aref muse-publish-footnotes footnote)
 735                   (setq footnotemark
 736                         (concat
 737                          footnotemark
 738                          (concat (format (muse-markup-text 'footnotetext)
 739                                          footnote)
 740                                  (buffer-substring-no-properties beg end)
 741                                  (muse-markup-text 'footnotetext-end))))
 742                   (aset muse-publish-footnotes footnote footnotemark))))
 743             (goto-char end)
 744             (skip-chars-forward "\n")
 745             (delete-region start (point)))))
 746       (insert (or footnotemark footnote)))))
 747
 748 (defun muse-publish-markup-fn-sep ()
 749   (delete-region (match-beginning 0) (match-end 0))
 750   (insert (muse-markup-text 'fn-sep)))
 751
 752 (defun muse-publish-surround-text (beg-tag end-tag move-func)
 753   (let ((beg (point)) end)
 754     (skip-chars-backward muse-regexp-space)
 755     (delete-region (point) beg)
 756     (insert "\n\n" beg-tag)
 757     (funcall move-func)
 758     (setq end (point-marker))
 759     (goto-char beg)
 760     (while (< (point) end)
 761       (if (looking-at "^\\s-+")
 762           (replace-match ""))
 763       (forward-line 1))
 764     (goto-char end)
 765     (setq beg (point))
 766     (skip-chars-backward muse-regexp-space)
 767     (delete-region (point) beg))
 768   (insert end-tag "\n"))
 769
 770 (defsubst muse-forward-paragraph (&optional pattern)
 771   (if (re-search-forward (if pattern
 772                              (concat "^\\(" pattern "["
 773                                      muse-regexp-blank
 774                                      "]+\\|$\\|\\'\\)")
 775                            "^\\s-*\\($\\|\\'\\)") nil t)
 776       (goto-char (match-beginning 0))
 777     (goto-char (point-max))))
 778
 779 (defun muse-publish-markup-list ()
 780   "Markup a list entry or quoted paragraph.
 781 The reason this function is so funky, is to prevent text properties
 782 like read-only from being inadvertently deleted."
 783   (let ((str (match-string 1)))
 784     (cond
 785      ((and (eq (aref str 0) ?-))
 786       (delete-region (match-beginning 0) (match-end 0))
 787       (muse-publish-surround-text
 788        (muse-markup-text 'begin-uli)
 789        (muse-markup-text 'end-uli)
 790        (function
 791         (lambda ()
 792           (muse-forward-paragraph (concat "["
 793                                           muse-regexp-blank
 794                                           "]+-"))))))
 795      ((and (>= (aref str 0) ?0)
 796            (<= (aref str 0) ?9))
 797       (delete-region (match-beginning 0) (match-end 0))
 798       (muse-publish-surround-text
 799        (muse-markup-text 'begin-oli)
 800        (muse-markup-text 'end-oli)
 801        (function
 802         (lambda ()
 803           (muse-forward-paragraph (concat "["
 804                                           muse-regexp-blank
 805                                           "]+[0-9]+\\."))))))
 806      (t
 807       (goto-char (match-beginning 1))
 808       (insert (muse-markup-text 'begin-ddt))
 809       (save-match-data
 810         (save-excursion
 811           (forward-line 1)
 812           (while (looking-at (concat "^\\(["
 813                                      muse-regexp-blank
 814                                      "]*\\)[^"
 815                                      muse-regexp-space
 816                                      "]"))
 817             (delete-region (match-beginning 1) (match-end 1))
 818             (forward-line 1))))
 819       (save-match-data
 820         (when (re-search-forward (concat "["
 821                                          muse-regexp-space
 822                                          "]+::["
 823                                          muse-regexp-space
 824                                          "]+")
 825                                  nil t)
 826           (replace-match (muse-markup-text 'start-dde))))
 827       (muse-forward-paragraph)
 828       (insert (muse-markup-text 'end-ddt) ?\n)))))
 829
 830 (defun muse-publish-markup-quote ()
 831   "Markup a list entry or quoted paragraph.
 832 The reason this function is so funky, is to prevent text properties
 833 like read-only from being inadvertently deleted."
 834   (let* ((ws (match-string 0))
 835          (centered (>= (string-width ws) 6))
 836          (begin-elem (if centered 'begin-center 'begin-quote))
 837          (end-elem (if centered 'end-center 'end-quote)))
 838     (muse-publish-surround-text (muse-markup-text begin-elem)
 839                                 (muse-markup-text end-elem)
 840                                 'muse-forward-paragraph)))
 841
 842 (defun muse-publish-markup-leading-space ()
 843   (let ((markup-space (muse-markup-text 'verse-space))
 844         count)
 845     (when (and markup-space
 846                (>= (setq count (skip-chars-forward " ")) 0))
 847       (delete-region (line-beginning-position) (point))
 848       (while (> count 0)
 849         (insert markup-space)
 850         (setq count (- count 2))))))
 851
 852 (defun muse-publish-markup-verse ()
 853   (let ((leader (match-string 0)))
 854     (goto-char (match-beginning 0))
 855     (insert (muse-markup-text 'begin-verse))
 856     (while (looking-at leader)
 857       (replace-match "")
 858       (muse-publish-markup-leading-space)
 859       (end-of-line)
 860       (cond
 861        ((bolp)
 862         (let ((text (muse-markup-text 'empty-verse-line)))
 863           (if text (insert text))))
 864        ((save-excursion
 865           (save-match-data
 866             (forward-line 1)
 867             (or (looking-at (concat leader "["
 868                                     muse-regexp-blank
 869                                     "]*$"))
 870                 (not (looking-at leader)))))
 871         (let ((text (muse-markup-text 'last-stanza-end)))
 872           (if text (insert text))))
 873        (t
 874         (let ((text (muse-markup-text 'end-verse-line)))
 875           (if text (insert text)))))
 876       (forward-line 1)))
 877   (insert (muse-markup-text 'end-verse) ?\n))
 878
 879 (defun muse-publish-markup-table ()
 880   "Style does not support tables.")
 881
 882 (defun muse-publish-markup-email ()
 883   (let* ((beg (match-end 1))
 884          (addr (buffer-substring-no-properties beg (match-end 0))))
 885     (with-temp-buffer
 886       (insert addr)
 887       (muse-publish-escape-specials (point-min) (point-max))
 888       (setq addr (buffer-string)))
 889     (goto-char beg)
 890     (delete-region beg (match-end 0))
 891     (insert (format (muse-markup-text 'email-addr) addr addr))
 892     (muse-publish-mark-read-only beg (point))))
 893
 894 (defun muse-publish-url (url &optional desc)
 895   "Resolve a URL into its final <a href> form."
 896   (let ((orig-url url))
 897     (dolist (transform muse-publish-url-transforms)
 898       (setq url (funcall transform url)))
 899     (if (string-match muse-image-regexp url)
 900         (if desc
 901             (muse-markup-text 'image-with-desc url desc)
 902           (muse-markup-text 'image-link url))
 903       (if (and desc (string-match muse-image-regexp desc))
 904           (muse-markup-text 'url-with-image url desc)
 905         (muse-markup-text 'url-link url (or desc orig-url))))))
 906
 907 (defun muse-publish-insert-url (url &optional desc)
 908   "Resolve a URL into its final <a href> form."
 909   (delete-region (match-beginning 0) (match-end 0))
 910   (insert (muse-publish-url url desc)))
 911
 912 (defun muse-publish-markup-link ()
 913   (muse-publish-insert-url (match-string 1) (match-string 2)))
 914
 915 (defun muse-publish-markup-url ()
 916   (muse-publish-insert-url (match-string 0)))
 917
 918 ;; Default publishing tags
 919
 920 (defun muse-publish-contents-tag (beg end attrs)
 921   (set (make-local-variable 'muse-publish-generate-contents)
 922        (cons (copy-marker (point) t)
 923              (let ((depth (cdr (assoc "depth" attrs))))
 924                (or (and depth (string-to-number depth)) 2)))))
 925
 926 (defun muse-publish-verse-tag (beg end)
 927   (save-excursion
 928     (goto-char beg)
 929     (while (eq ?\  (char-syntax (char-after)))
 930       (delete-char 1))
 931     (while (< (point) end)
 932       (insert "> ")
 933       (forward-line))
 934     (if (eq ?\  (char-syntax (char-before)))
 935       (delete-char -1))))
 936
 937 (defun muse-publish-example-tag (beg end)
 938   (muse-publish-escape-specials beg end)
 939   (goto-char beg)
 940   (insert (muse-markup-text 'begin-example))
 941   (goto-char end)
 942   (insert (muse-markup-text 'end-example))
 943   (muse-publish-mark-read-only beg (point)))
 944
 945 (defun muse-publish-mark-read-only (beg end)
 946   (add-text-properties beg end '(rear-nonsticky (read-only) read-only t))
 947   nil)
 948
 949 (defun muse-publish-verbatim-tag (beg end)
 950   (muse-publish-escape-specials beg end)
 951   (muse-publish-mark-read-only beg end))
 952
 953 (defalias 'muse-publish-class-tag 'ignore)
 954
 955 (defun muse-publish-lisp-tag (beg end)
 956   (save-excursion
 957     (let ((str (muse-eval-lisp
 958                 (prog1
 959                     (buffer-substring-no-properties beg end)
 960                   (delete-region beg end)))))
 961       (set-text-properties 0 (length str) nil str)
 962       (insert str))))
 963
 964 (defun muse-publish-command-tag (beg end attrs)
 965   (while (looking-at "\\s-*$")
 966     (forward-line))
 967   (let ((interp (cdr (assoc "interp" attrs))))
 968     (if (null interp)
 969         (shell-command
 970          (prog1
 971              (buffer-substring-no-properties (point) end)
 972            (delete-region beg end)) t)
 973       (shell-command-on-region beg end interp t t))
 974     (muse-publish-mark-read-only beg (point))))
 975
 976 (defun muse-publish-comment-tag (beg end)
 977   (delete-region beg end))
 978
 979 ;; Miscellaneous helper functions
 980
 981 (defsubst muse-publishing-directive (name)
 982   (cdr (assoc name muse-publishing-directives)))
 983
 984 (defun muse-publish-strip-tags (string)
 985   "Remove all tags from the string."
 986   (while (string-match "<.*?>" string)
 987     (setq string (replace-match "" nil t string)))
 988   string)
 989
 990 (defun muse-publish-markup-type (category default-func)
 991   (let ((rule (muse-find-markup-element :overrides category (muse-style))))
 992     (funcall (or rule default-func))))
 993
 994 (defun muse-published-buffer-contents (buffer)
 995   (with-current-buffer buffer
 996     (goto-char (point-min))
 997     (let ((beg (and (search-forward "Emacs Muse begins here")
 998                     (line-end-position)))
 999           (end (and (search-forward "Emacs Muse ends here")
1000                     (line-beginning-position))))
1001       (buffer-substring-no-properties beg end))))
1002
1003 (defun muse-published-contents (file)
1004   (when (file-readable-p file)
1005     (with-temp-buffer
1006       (insert-file-contents file)
1007       (muse-published-buffer-contents (current-buffer)))))
1008
1009 (defun muse-publish-transform-output
1010   (file temp-file output-path name gen-func &rest cleanup-exts)
1011   "Transform the given TEMP-FILE into the OUTPUT-PATH, using GEN-FUNC."
1012   (setq file (muse-page-name file))
1013   (message "Generating %s output for %s..." name file)
1014   (if (not (funcall gen-func temp-file output-path))
1015       (message "Generating %s from %s...failed" name file)
1016     (message "Generating %s output for %s...done" name file)
1017     (muse-delete-file-if-exists temp-file)
1018     (dolist (ext cleanup-exts)
1019       (muse-delete-file-if-exists
1020        (expand-file-name (concat file ext)
1021                          (file-name-directory output-path))))
1022     (message "Wrote %s" output-path)))
1023
1024 (defun muse-publish-read-only (string)
1025   (add-text-properties 0 (1- (length string))
1026                        '(rear-nonsticky (read-only) read-only t)
1027                        string)
1028   string)
1029
1030 (defun muse-publish-prepare-url (target)
1031   (save-match-data
1032     (unless (or (string-match muse-url-regexp target)
1033                 (string-match muse-image-regexp target)
1034                 (string-match muse-file-regexp target))
1035       (setq target (if (string-match "#" target)
1036                        (concat (muse-publish-output-name
1037                                 (substring target 0 (match-beginning 0)))
1038                                "#" (substring target (match-end 0)))
1039                      (muse-publish-output-name target)))))
1040   (muse-publish-read-only target))
1041
1042 (provide 'muse-publish)
1043
1044 ;;; muse-publish.el ends here