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