lisp/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 behavior 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             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 (and (not (string-equal file-or-string ""))
 411              (file-readable-p file-or-string))
 412         (setq end (+ beg (cadr (insert-file-contents file-or-string))))
 413       (insert file-or-string)
 414       (setq end (point)))
 415     (save-restriction
 416       (narrow-to-region beg end)
 417       (muse-publish-markup (or title "")
 418                            '((100 "<\\(lisp\\)>" 0
 419                               muse-publish-markup-tag))))))
 420
 421 (defun muse-style-run-hooks (keyword style &rest args)
 422   (let (handled)
 423     (while (and style (not handled))
 424       (setq style (muse-style style))
 425       (let ((func (muse-get-keyword keyword style t)))
 426         (if func
 427             (if (apply func args)
 428                 (setq handled t))))
 429       (unless handled
 430         (setq style (muse-style-element :base style))))
 431     handled))
 432
 433 (defun muse-publish-markup-region (beg end title style)
 434   "Apply the given STYLE's markup rules to the given region."
 435   (save-restriction
 436     (narrow-to-region beg end)
 437     (muse-style-run-hooks :before style)
 438     (muse-publish-markup
 439      title
 440      (sort (copy-alist (append muse-publish-markup-regexps
 441                                (muse-style-element :regexps style)))
 442            (function
 443             (lambda (l r)
 444               (< (car l) (car r))))))
 445     (muse-style-run-hooks :before-end style)))
 446
 447 (defun muse-publish-markup-buffer (title style)
 448   "Apply the given STYLE's markup rules to the current buffer."
 449   (setq style (muse-style style))
 450   (let ((style-header (muse-style-element :header style))
 451         (style-footer (muse-style-element :footer style))
 452         (muse-publishing-current-style style)
 453         (muse-publishing-directives
 454          (list (cons "title" title)
 455                (cons "author" (user-full-name))
 456                (cons "date" (format-time-string "%B %e, %Y"))))
 457         (muse-publishing-p t))
 458     (run-hooks 'muse-before-publish-hook)
 459     (muse-publish-markup-region (point-min) (point-max) title style)
 460     (goto-char (point-min))
 461     (if style-header (muse-insert-file-or-string style-header title))
 462     (goto-char (point-max))
 463     (if style-footer (muse-insert-file-or-string style-footer title))
 464     (muse-style-run-hooks :after style)
 465     (run-hooks 'muse-after-publish-hook)))
 466
 467 (defun muse-publish-markup-string (string &optional style)
 468   "Markup STRING using the given STYLE's markup rules."
 469   (setq style (muse-style style))
 470   (with-temp-buffer
 471     (insert string)
 472     (let ((muse-publishing-current-style style)
 473           (muse-publishing-p t))
 474       (muse-publish-markup "*string*" (muse-style-element :rules style)))
 475     (buffer-string)))
 476
 477 ;; Commands for publishing files
 478
 479 (defsubst muse-publish-get-style ()
 480   (if (= 1 (length muse-publishing-styles))
 481       (car muse-publishing-styles)
 482     (assoc (completing-read "Publish with style: "
 483                             muse-publishing-styles nil t)
 484            muse-publishing-styles)))
 485
 486 (defsubst muse-publish-get-output-dir (style)
 487   (let ((default-directory (or (muse-style-element :path style)
 488                                default-directory)))
 489     (read-file-name "Publish to directory: " nil default-directory)))
 490
 491 (defsubst muse-publish-get-info ()
 492   (let ((style (muse-publish-get-style)))
 493     (list style (muse-publish-get-output-dir style)
 494           current-prefix-arg)))
 495
 496 (defsubst muse-publish-output-name (&optional file style)
 497   (setq style (muse-style style))
 498   (concat (muse-style-element :prefix style)
 499           (muse-page-name (or file muse-publishing-current-file))
 500           (muse-style-element :suffix style)))
 501
 502 (defsubst muse-publish-output-file (file output-dir &optional style)
 503   (setq style (muse-style style))
 504   (expand-file-name (muse-publish-output-name file style) output-dir))
 505
 506 (defun muse-publish-file (file style &optional output-dir force)
 507   "Publish the given file in list FILES.
 508 If the argument FORCE is nil, each file is only published if it is
 509 newer than the published version.  If the argument FORCE is non-nil,
 510 the file is published no matter what."
 511   (interactive (cons (read-file-name "Publish file: ")
 512                      (muse-publish-get-info)))
 513   (setq style (muse-style style))
 514   (let* ((output-path (muse-publish-output-file file output-dir style))
 515          (output-suffix (muse-style-element :osuffix style))
 516          (muse-publishing-current-file file)
 517          (target (if output-suffix
 518                      (concat (file-name-sans-extension output-path)
 519                              output-suffix)
 520                    output-path)))
 521     (when (or force (file-newer-than-file-p file target))
 522       (if (and muse-publish-report-threshhold
 523                (> (nth 7 (file-attributes file))
 524                   muse-publish-report-threshhold))
 525           (message "Publishing %s ..." file))
 526       (with-temp-buffer
 527         (insert-file-contents file t)
 528         (muse-publish-markup-buffer (muse-page-name file) style)
 529         (let ((backup-inhibited t))
 530           (write-file output-path))
 531         (muse-style-run-hooks :final style file output-path target))
 532       t)))
 533
 534 (defun muse-publish-this-file (style output-dir &optional force)
 535   "Publish the page in the current file."
 536   (interactive (muse-publish-get-info))
 537   (muse-publish-file buffer-file-name style output-dir force))
 538
 539 (defun muse-batch-publish-files ()
 540   "Publish Muse files in batch mode."
 541   (let ((muse-batch-publishing-p t)
 542         style-name style output-dir)
 543     (setq style-name (car command-line-args-left)
 544           style (muse-style style-name)
 545           command-line-args-left (cdr command-line-args-left)
 546           output-dir (car command-line-args-left)
 547           output-dir
 548           (if (string-match "\\`--output-dir=" output-dir)
 549               (prog1
 550                   (substring output-dir (match-end 0))
 551                 (setq command-line-args-left (cdr command-line-args-left)))))
 552     (unless style
 553       (error "There is no style '%s' defined." style-name))
 554     (dolist (file command-line-args-left)
 555       (muse-publish-file file style output-dir t))))
 556
 557 ;; Default publishing rules
 558
 559 (defun muse-publish-markup-directive (&optional name value)
 560   (unless name (setq name (match-string 1)))
 561   (unless value (setq value (match-string 2)))
 562   (let ((elem (assoc name muse-publishing-directives)))
 563     (if elem
 564         (setcdr elem value)
 565       (setq muse-publishing-directives
 566             (cons (cons name value)
 567                   muse-publishing-directives))))
 568   (delete-region (match-beginning 0) (match-end 0)))
 569
 570 (defun muse-publish-markup-anchor () "")
 571 (defun muse-publish-markup-comment () "")
 572
 573 (defun muse-publish-markup-tag ()
 574   (let ((tag-info (muse-markup-tag-info (match-string 1))))
 575     (when (and tag-info
 576                (not (get-text-property (match-beginning 0) 'read-only)))
 577       (let ((closed-tag (match-string 3))
 578             (start (match-beginning 0))
 579             (beg (point)) end attrs)
 580         (when (nth 2 tag-info)
 581           (let ((attrstr (match-string 2)))
 582             (while (and attrstr
 583                         (string-match (concat "\\([^"
 584                                               muse-regexp-space
 585                                               "=]+\\)\\(=\"\\"
 586                                               "([^\"]+\\)\"\\)?")
 587                                       attrstr))
 588               (let ((attr (cons (downcase
 589                                  (muse-match-string-no-properties 1 attrstr))
 590                                 (muse-match-string-no-properties 3 attrstr))))
 591                 (setq attrstr (replace-match "" t t attrstr))
 592                 (if attrs
 593                     (nconc attrs (list attr))
 594                   (setq attrs (list attr)))))))
 595         (if (and (cadr tag-info) (not closed-tag))
 596             (if (search-forward (concat "</" (car tag-info) ">") nil t)
 597                 (delete-region (match-beginning 0) (point))
 598               (setq tag-info nil)))
 599         (when tag-info
 600           (setq end (point-marker))
 601           (delete-region start beg)
 602           (goto-char start)
 603           (let ((args (list start end)))
 604             (if (nth 2 tag-info)
 605                 (nconc args (list attrs)))
 606             (apply (nth 3 tag-info) args))))))
 607   nil)
 608
 609 (defun muse-publish-escape-specials (beg end)
 610   (save-excursion
 611     (goto-char beg)
 612     (while (< (point) end)
 613       (if (get-text-property (point) 'read-only)
 614           (forward-char 1)
 615         (let ((repl
 616                (or (assoc (char-after) (muse-style-element :specials))
 617                    (assoc (char-after) muse-publish-markup-specials))))
 618           (if (null repl)
 619               (forward-char 1)
 620             (delete-char 1)
 621             (insert (cdr repl))))))))
 622
 623 (defun muse-publish-markup-word ()
 624   (let* ((beg (match-beginning 2))
 625          (end (1- (match-end 2)))
 626          (leader (buffer-substring-no-properties beg end))
 627          open-tag close-tag mark-read-only loc multi-line)
 628     (cond
 629      ((string= leader "_")
 630       (setq multi-line t)
 631       (setq open-tag (muse-markup-text 'begin-underline)
 632             close-tag (muse-markup-text 'end-underline)))
 633      ((string= leader "=")
 634       (setq open-tag (muse-markup-text 'begin-literal)
 635             close-tag (muse-markup-text 'end-literal))
 636       (setq mark-read-only t))
 637      (t
 638       (setq multi-line t)
 639       (let ((l (length leader)))
 640         (cond
 641          ((= l 1) (setq open-tag (muse-markup-text 'begin-emph)
 642                         close-tag (muse-markup-text 'end-emph)))
 643          ((= l 2) (setq open-tag (muse-markup-text 'begin-more-emph)
 644                         close-tag (muse-markup-text 'end-more-emph)))
 645          ((= l 3) (setq open-tag (muse-markup-text 'begin-most-emph)
 646                         close-tag (muse-markup-text 'end-most-emph)))))))
 647     (if (and (setq loc (search-forward leader nil t))
 648              (eq 0 (skip-syntax-forward "w" (1+ loc)))
 649              (or multi-line (= 1 (count-lines beg loc))))
 650         (progn
 651           (replace-match "")
 652           (delete-region beg end)
 653           (setq end (point-marker))
 654           (insert close-tag)
 655           (save-excursion
 656             (goto-char beg)
 657             (insert open-tag)
 658             (setq beg (point)))
 659           (when mark-read-only
 660             (muse-publish-escape-specials beg end)
 661             (muse-publish-mark-read-only (1- beg) (1+ end))))
 662       (backward-char))
 663     nil))
 664
 665 (defun muse-publish-markup-emdash ()
 666   (delete-region (match-beginning 0) (match-end 0))
 667   (insert (muse-markup-text 'emdash))
 668   (if (eq (char-after) ?\<)
 669       (insert ?\n)))
 670
 671 (defun muse-publish-markup-enddots ()
 672   (delete-region (match-beginning 0) (match-end 0))
 673   (insert (muse-markup-text 'enddots)))
 674
 675 (defun muse-publish-markup-dots ()
 676   (delete-region (match-beginning 0) (match-end 0))
 677   (insert (muse-markup-text 'dots)))
 678
 679 (defun muse-publish-markup-rule ()
 680   (delete-region (match-beginning 0) (match-end 0))
 681   (insert (muse-markup-text 'rule)))
 682
 683 (defun muse-publish-markup-heading ()
 684   (let* ((len (length (match-string 1)))
 685          (start (muse-markup-text
 686                  (cond ((= len 1) 'section)
 687                        ((= len 2) 'subsection)
 688                        ((= len 3) 'subsubsection))))
 689          (end   (muse-markup-text
 690                  (cond ((= len 1) 'section-end)
 691                        ((= len 2) 'subsection-end)
 692                        ((= len 3) 'subsubsection-end)))))
 693     (delete-region (match-beginning 0) (match-end 0))
 694     (insert start)
 695     (end-of-line)
 696     (if end (insert end))))
 697
 698 (defvar muse-publish-footnotes nil)
 699
 700 (defun muse-publish-markup-footnote ()
 701   "Scan ahead and snarf up the footnote body"
 702   (if (= (muse-line-beginning-position) (match-beginning 0))
 703       ""
 704     (let ((footnote (save-match-data
 705                       (string-to-number (match-string 1))))
 706           footnotemark)
 707       (delete-region (match-beginning 0) (match-end 0))
 708       (save-excursion
 709         (when (re-search-forward (format "^\\[%d\\]\\s-+" footnote) nil t)
 710           (let* ((start (match-beginning 0))
 711                  (beg (goto-char (match-end 0)))
 712                  (end (save-excursion
 713                         (if (search-forward "\n\n" nil t)
 714                             (copy-marker (match-beginning 0))
 715                           (goto-char (point-max))
 716                           (skip-chars-backward "\n")
 717                           (point-marker)))))
 718             (while (re-search-forward (concat "^["
 719                                               muse-regexp-blank
 720                                               "]+\\([^\n]\\)")
 721                                       end t)
 722               (replace-match "\\1" t))
 723             (let ((footnotemark-cmd (muse-markup-text 'footnotemark))
 724                   (footnotemark-end-cmd (muse-markup-text 'footnotemark-end)))
 725               (if (string= "" footnotemark-cmd)
 726                   (setq footnotemark
 727                         (concat (muse-markup-text 'footnote)
 728                                 (buffer-substring-no-properties beg end)
 729                                 (muse-markup-text 'footnote-end)))
 730                 (setq footnotemark (format footnotemark-cmd footnote
 731                                            footnotemark-end-cmd))
 732                 (unless muse-publish-footnotes
 733                   (set (make-local-variable 'muse-publish-footnotes)
 734                        (make-vector 256 nil)))
 735                 (unless (aref muse-publish-footnotes footnote)
 736                   (setq footnotemark
 737                         (concat
 738                          footnotemark
 739                          (concat (format (muse-markup-text 'footnotetext)
 740                                          footnote)
 741                                  (buffer-substring-no-properties beg end)
 742                                  (muse-markup-text 'footnotetext-end))))
 743                   (aset muse-publish-footnotes footnote footnotemark))))
 744             (goto-char end)
 745             (skip-chars-forward "\n")
 746             (delete-region start (point)))))
 747       (insert (or footnotemark footnote)))))
 748
 749 (defun muse-publish-markup-fn-sep ()
 750   (delete-region (match-beginning 0) (match-end 0))
 751   (insert (muse-markup-text 'fn-sep)))
 752
 753 (defun muse-publish-surround-text (beg-tag end-tag move-func)
 754   (let ((beg (point)) end)
 755     (skip-chars-backward muse-regexp-space)
 756     (delete-region (point) beg)
 757     (insert "\n\n" beg-tag)
 758     (funcall move-func)
 759     (setq end (point-marker))
 760     (goto-char beg)
 761     (while (< (point) end)
 762       (if (looking-at "^\\s-+")
 763           (replace-match ""))
 764       (forward-line 1))
 765     (goto-char end)
 766     (setq beg (point))
 767     (skip-chars-backward muse-regexp-space)
 768     (delete-region (point) beg))
 769   (insert end-tag "\n"))
 770
 771 (defsubst muse-forward-paragraph (&optional pattern)
 772   (if (re-search-forward (if pattern
 773                              (concat "^\\(" pattern "["
 774                                      muse-regexp-blank
 775                                      "]+\\|$\\|\\'\\)")
 776                            "^\\s-*\\($\\|\\'\\)") nil t)
 777       (goto-char (match-beginning 0))
 778     (goto-char (point-max))))
 779
 780 (defun muse-publish-markup-list ()
 781   "Markup a list entry or quoted paragraph.
 782 The reason this function is so funky, is to prevent text properties
 783 like read-only from being inadvertently deleted."
 784   (let ((str (match-string 1)))
 785     (cond
 786      ((and (eq (aref str 0) ?-))
 787       (delete-region (match-beginning 0) (match-end 0))
 788       (muse-publish-surround-text
 789        (muse-markup-text 'begin-uli)
 790        (muse-markup-text 'end-uli)
 791        (function
 792         (lambda ()
 793           (muse-forward-paragraph (concat "["
 794                                           muse-regexp-blank
 795                                           "]+-"))))))
 796      ((and (>= (aref str 0) ?0)
 797            (<= (aref str 0) ?9))
 798       (delete-region (match-beginning 0) (match-end 0))
 799       (muse-publish-surround-text
 800        (muse-markup-text 'begin-oli)
 801        (muse-markup-text 'end-oli)
 802        (function
 803         (lambda ()
 804           (muse-forward-paragraph (concat "["
 805                                           muse-regexp-blank
 806                                           "]+[0-9]+\\."))))))
 807      (t
 808       (goto-char (match-beginning 1))
 809       (insert (muse-markup-text 'begin-ddt))
 810       (save-match-data
 811         (save-excursion
 812           (forward-line 1)
 813           (while (looking-at (concat "^\\(["
 814                                      muse-regexp-blank
 815                                      "]*\\)[^"
 816                                      muse-regexp-space
 817                                      "]"))
 818             (delete-region (match-beginning 1) (match-end 1))
 819             (forward-line 1))))
 820       (save-match-data
 821         (when (re-search-forward (concat "["
 822                                          muse-regexp-space
 823                                          "]+::["
 824                                          muse-regexp-space
 825                                          "]+")
 826                                  nil t)
 827           (replace-match (muse-markup-text 'start-dde))))
 828       (muse-forward-paragraph)
 829       (insert (muse-markup-text 'end-ddt) ?\n)))))
 830
 831 (defun muse-publish-markup-quote ()
 832   "Markup a list entry or quoted paragraph.
 833 The reason this function is so funky, is to prevent text properties
 834 like read-only from being inadvertently deleted."
 835   (let* ((ws (match-string 0))
 836          (centered (>= (string-width ws) 6))
 837          (begin-elem (if centered 'begin-center 'begin-quote))
 838          (end-elem (if centered 'end-center 'end-quote)))
 839     (muse-publish-surround-text (muse-markup-text begin-elem)
 840                                 (muse-markup-text end-elem)
 841                                 'muse-forward-paragraph)))
 842
 843 (defun muse-publish-markup-leading-space ()
 844   (let ((markup-space (muse-markup-text 'verse-space))
 845         count)
 846     (when (and markup-space
 847                (>= (setq count (skip-chars-forward " ")) 0))
 848       (delete-region (muse-line-beginning-position) (point))
 849       (while (> count 0)
 850         (insert markup-space)
 851         (setq count (- count 2))))))
 852
 853 (defun muse-publish-markup-verse ()
 854   (let ((leader (match-string 0)))
 855     (goto-char (match-beginning 0))
 856     (insert (muse-markup-text 'begin-verse))
 857     (while (looking-at leader)
 858       (replace-match "")
 859       (muse-publish-markup-leading-space)
 860       (end-of-line)
 861       (cond
 862        ((bolp)
 863         (let ((text (muse-markup-text 'empty-verse-line)))
 864           (if text (insert text))))
 865        ((save-excursion
 866           (save-match-data
 867             (forward-line 1)
 868             (or (looking-at (concat leader "["
 869                                     muse-regexp-blank
 870                                     "]*$"))
 871                 (not (looking-at leader)))))
 872         (let ((text (muse-markup-text 'last-stanza-end)))
 873           (if text (insert text))))
 874        (t
 875         (let ((text (muse-markup-text 'end-verse-line)))
 876           (if text (insert text)))))
 877       (forward-line 1)))
 878   (insert (muse-markup-text 'end-verse) ?\n))
 879
 880 (defun muse-publish-markup-table ()
 881   "Style does not support tables.")
 882
 883 (defun muse-publish-markup-email ()
 884   (let* ((beg (match-end 1))
 885          (addr (buffer-substring-no-properties beg (match-end 0))))
 886     (with-temp-buffer
 887       (insert addr)
 888       (muse-publish-escape-specials (point-min) (point-max))
 889       (setq addr (buffer-string)))
 890     (goto-char beg)
 891     (delete-region beg (match-end 0))
 892     (insert (format (muse-markup-text 'email-addr) addr addr))
 893     (muse-publish-mark-read-only beg (point))))
 894
 895 (defun muse-publish-url (url &optional desc)
 896   "Resolve a URL into its final <a href> form."
 897   (let ((orig-url url))
 898     (dolist (transform muse-publish-url-transforms)
 899       (setq url (funcall transform url)))
 900     (if (string-match muse-image-regexp url)
 901         (if desc
 902             (muse-markup-text 'image-with-desc url desc)
 903           (muse-markup-text 'image-link url))
 904       (if (and desc (string-match muse-image-regexp desc))
 905           (muse-markup-text 'url-with-image url desc)
 906         (muse-markup-text 'url-link url (or desc orig-url))))))
 907
 908 (defun muse-publish-insert-url (url &optional desc)
 909   "Resolve a URL into its final <a href> form."
 910   (delete-region (match-beginning 0) (match-end 0))
 911   (insert (muse-publish-url url desc)))
 912
 913 (defun muse-publish-markup-link ()
 914   (muse-publish-insert-url (match-string 1) (match-string 2)))
 915
 916 (defun muse-publish-markup-url ()
 917   (muse-publish-insert-url (match-string 0)))
 918
 919 ;; Default publishing tags
 920
 921 (defun muse-publish-contents-tag (beg end attrs)
 922   (set (make-local-variable 'muse-publish-generate-contents)
 923        (cons (copy-marker (point) t)
 924              (let ((depth (cdr (assoc "depth" attrs))))
 925                (or (and depth (string-to-number depth)) 2)))))
 926
 927 (defun muse-publish-verse-tag (beg end)
 928   (save-excursion
 929     (goto-char beg)
 930     (while (eq ?\  (char-syntax (char-after)))
 931       (delete-char 1))
 932     (while (< (point) end)
 933       (insert "> ")
 934       (forward-line))
 935     (if (eq ?\  (char-syntax (char-before)))
 936       (delete-char -1))))
 937
 938 (defun muse-publish-example-tag (beg end)
 939   (muse-publish-escape-specials beg end)
 940   (goto-char beg)
 941   (insert (muse-markup-text 'begin-example))
 942   (goto-char end)
 943   (insert (muse-markup-text 'end-example))
 944   (muse-publish-mark-read-only beg (point)))
 945
 946 (defun muse-publish-mark-read-only (beg end)
 947   (add-text-properties beg end '(rear-nonsticky (read-only) read-only t))
 948   nil)
 949
 950 (defun muse-publish-verbatim-tag (beg end)
 951   (muse-publish-escape-specials beg end)
 952   (muse-publish-mark-read-only beg end))
 953
 954 (defalias 'muse-publish-class-tag 'ignore)
 955
 956 (defun muse-publish-lisp-tag (beg end)
 957   (save-excursion
 958     (let ((str (muse-eval-lisp
 959                 (prog1
 960                     (buffer-substring-no-properties beg end)
 961                   (delete-region beg end)))))
 962       (set-text-properties 0 (length str) nil str)
 963       (insert str))))
 964
 965 (defun muse-publish-command-tag (beg end attrs)
 966   (while (looking-at "\\s-*$")
 967     (forward-line))
 968   (let ((interp (cdr (assoc "interp" attrs))))
 969     (if (null interp)
 970         (shell-command
 971          (prog1
 972              (buffer-substring-no-properties (point) end)
 973            (delete-region beg end)) t)
 974       (shell-command-on-region beg end interp t t))
 975     (muse-publish-mark-read-only beg (point))))
 976
 977 (defun muse-publish-comment-tag (beg end)
 978   (delete-region beg end))
 979
 980 ;; Miscellaneous helper functions
 981
 982 (defsubst muse-publishing-directive (name)
 983   (cdr (assoc name muse-publishing-directives)))
 984
 985 (defun muse-publish-strip-tags (string)
 986   "Remove all tags from the string."
 987   (while (string-match "<.*?>" string)
 988     (setq string (replace-match "" nil t string)))
 989   string)
 990
 991 (defun muse-publish-markup-type (category default-func)
 992   (let ((rule (muse-find-markup-element :overrides category (muse-style))))
 993     (funcall (or rule default-func))))
 994
 995 (defun muse-published-buffer-contents (buffer)
 996   (with-current-buffer buffer
 997     (goto-char (point-min))
 998     (let ((beg (and (search-forward "Emacs Muse begins here")
 999                     (muse-line-end-position)))
1000           (end (and (search-forward "Emacs Muse ends here")
1001                     (muse-line-beginning-position))))
1002       (buffer-substring-no-properties beg end))))
1003
1004 (defun muse-published-contents (file)
1005   (when (file-readable-p file)
1006     (with-temp-buffer
1007       (insert-file-contents file)
1008       (muse-published-buffer-contents (current-buffer)))))
1009
1010 (defun muse-publish-transform-output
1011   (file temp-file output-path name gen-func &rest cleanup-exts)
1012   "Transform the given TEMP-FILE into the OUTPUT-PATH, using GEN-FUNC."
1013   (setq file (muse-page-name file))
1014   (message "Generating %s output for %s..." name file)
1015   (if (not (funcall gen-func temp-file output-path))
1016       (message "Generating %s from %s...failed" name file)
1017     (message "Generating %s output for %s...done" name file)
1018     (muse-delete-file-if-exists temp-file)
1019     (dolist (ext cleanup-exts)
1020       (muse-delete-file-if-exists
1021        (expand-file-name (concat file ext)
1022                          (file-name-directory output-path))))
1023     (message "Wrote %s" output-path)))
1024
1025 (defun muse-publish-read-only (string)
1026   (add-text-properties 0 (1- (length string))
1027                        '(rear-nonsticky (read-only) read-only t)
1028                        string)
1029   string)
1030
1031 (defun muse-publish-prepare-url (target)
1032   (save-match-data
1033     (unless (or (string-match muse-url-regexp target)
1034                 (string-match muse-image-regexp target)
1035                 (string-match muse-file-regexp target))
1036       (setq target (if (string-match "#" target)
1037                        (concat (muse-publish-output-name
1038                                 (substring target 0 (match-beginning 0)))
1039                                "#" (substring target (match-end 0)))
1040                      (muse-publish-output-name target)))))
1041   (muse-publish-read-only target))
1042
1043 (provide 'muse-publish)
1044
1045 ;;; muse-publish.el ends here