lisp/muse-publish.el

   1 ;;; muse-publish.el --- base publishing implementation
   2
   3 ;; Copyright (C) 2004, 2005, 2006, 2007, 2008  Free Software Foundation, Inc.
   4
   5 ;; This file is part of Emacs Muse.  It is not part of GNU Emacs.
   6
   7 ;; Emacs Muse is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published
   9 ;; by the Free Software Foundation; either version 3, or (at your
  10 ;; option) any later version.
  11
  12 ;; Emacs Muse is distributed in the hope that it will be useful, but
  13 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 ;; General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with Emacs Muse; 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 ;; Peter K. Lee (saint AT corenova DOT com) provided the
  30 ;; `muse-style-elements-list' function.
  31
  32 ;; Jim Ottaway (j DOT ottaway AT lse DOT ac DOT uk) provided a
  33 ;; reference implementation for nested lists, as well as some code for
  34 ;; the "style" element of the <literal> tag.
  35
  36 ;; Deus Max (deusmax AT gmail DOT com) provided the <php> tag.
  37
  38 ;;; Code:
  39
  40 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41 ;;
  42 ;; Muse Publishing
  43 ;;
  44 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  45
  46 (provide 'muse-publish)
  47
  48 (require 'muse)
  49 (require 'muse-regexps)
  50
  51 (defgroup muse-publish nil
  52   "Options controlling the general behavior of Muse publishing."
  53   :group 'muse)
  54
  55 (defcustom muse-before-publish-hook nil
  56   "A hook run in the buffer to be published, before it is done."
  57   :type 'hook
  58   :group 'muse-publish)
  59
  60 (defcustom muse-after-publish-hook nil
  61   "A hook run in the buffer to be published, after it is done."
  62   :type 'hook
  63   :group 'muse-publish)
  64
  65 (defcustom muse-publish-url-transforms
  66   '(muse-resolve-url)
  67   "A list of functions used to prepare URLs for publication.
  68 Each is passed the URL.  The transformed URL should be returned."
  69   :type 'hook
  70   :options '(muse-resolve-url)
  71   :group 'muse-publish)
  72
  73 (defcustom muse-publish-desc-transforms
  74   '(muse-publish-strip-URL)
  75   "A list of functions used to prepare URL desciptions for publication.
  76 Each is passed the description.  The modified description should
  77 be returned."
  78   :type 'hook
  79   :options '(muse-publish-strip-URL)
  80   :group 'muse-publish)
  81
  82 (defcustom muse-publish-date-format "%B %e, %Y"
  83   "Format string for the date, used by `muse-publish-markup-buffer'.
  84 See `format-time-string' for details on the format options."
  85   :type 'string
  86   :group 'muse-publish)
  87
  88 (defcustom muse-publish-comments-p nil
  89   "If nil, remove comments before publishing.
  90 If non-nil, publish comments using the markup of the current style."
  91   :type 'boolean
  92   :group 'muse-publish)
  93
  94 (defcustom muse-publish-report-threshhold 100000
  95   "If a file is this size or larger, report publishing progress."
  96   :type 'integer
  97   :group 'muse-publish)
  98
  99 (defcustom muse-publish-markup-regexps
 100   `(;; Remove leading and trailing whitespace from the file
 101     (1000 "\\(\\`\n+\\|\n+\\'\\)" 0 "")
 102
 103     ;; Remove trailing whitespace from all lines
 104     (1100 ,(concat "[" muse-regexp-blank "]+$") 0 "")
 105
 106     ;; Handle any leading #directives
 107     (1200 "\\`#\\([a-zA-Z-]+\\)\\s-+\\(.+\\)\n+" 0 directive)
 108
 109     ;; commented lines
 110     (1250 ,(concat "^;\\(?:[" muse-regexp-blank "]+\\(.+\\)\\|$\\|'\\)")
 111           0 comment)
 112
 113     ;; markup tags
 114     (1300 muse-tag-regexp 0 tag)
 115
 116     ;; prevent emphasis characters in explicit links from being marked
 117     (1400 muse-explicit-link-regexp 0 muse-publish-mark-link)
 118
 119     ;; emphasized or literal text
 120     (1600 ,(concat "\\(^\\|[-[" muse-regexp-blank
 121                    "<('`\"\n]\\)\\(=[^=" muse-regexp-blank
 122                    "\n]\\|_[^_" muse-regexp-blank
 123                    "\n]\\|\\*+[^*" muse-regexp-blank
 124                    "\n]\\)")
 125           2 word)
 126
 127     ;; headings, outline-mode style
 128     (1700 "^\\(\\*+\\)\\s-+" 0 heading)
 129
 130     ;; ellipses
 131     (1800 "\\.\\.\\.\\." 0 enddots)
 132     (1850 "\\.\\.\\." 0 dots)
 133
 134     ;; horizontal rule, or section separator
 135     (1900 "^----+" 0 rule)
 136
 137     ;; non-breaking space
 138     (1950 "~~" 0 no-break-space)
 139
 140     ;; beginning of footnotes section
 141     (2000 "^Footnotes:?\\s-*" 0 fn-sep)
 142     ;; footnote definition/reference (def if at beginning of line)
 143     (2100 "\\[\\([1-9][0-9]*\\)\\]" 0 footnote)
 144
 145     ;; unnumbered List items begin with a -.  numbered list items
 146     ;; begin with number and a period.  definition lists have a
 147     ;; leading term separated from the body with ::.  centered
 148     ;; paragraphs begin with at least six columns of whitespace; any
 149     ;; other whitespace at the beginning indicates a blockquote.  The
 150     ;; reason all of these rules are handled here, is so that
 151     ;; blockquote detection doesn't interfere with indented list
 152     ;; members.
 153     (2200 ,(format muse-list-item-regexp (concat "[" muse-regexp-blank "]*"))
 154           0 list)
 155
 156     ;; support table.el style tables
 157     (2300 ,(concat "^" muse-table-el-border-regexp "\n"
 158                    "\\(\\(" muse-table-line-regexp "\n\\)+"
 159                    "\\(" muse-table-el-border-regexp "\\)"
 160                    "\\(\n\\|\\'\\)\\)+")
 161           0 table-el)
 162
 163     ;; simple table markup is supported, nothing fancy.  use | to
 164     ;; separate cells, || to separate header cells, and ||| for footer
 165     ;; cells
 166     (2350 ,(concat "\\(\\([" muse-regexp-blank "]*\n\\)?"
 167                    "\\(\\(?:" muse-table-line-regexp "\\|"
 168                    muse-table-hline-regexp "\\)\\(?:\n\\|\\'\\)\\)\\)+")
 169           0 table)
 170
 171     ;; blockquote and centered text
 172     (2400 ,(concat "^\\([" muse-regexp-blank "]+\\).+") 0 quote)
 173
 174     ;; the emdash ("--" or "---")
 175     (2500 ,(concat "\\(^\\|[" muse-regexp-blank "]*\\)---?\\($\\|["
 176                    muse-regexp-blank "]*\\)")
 177           0 emdash)
 178
 179     ;; "verse" text is indicated the same way as a quoted e-mail
 180     ;; response: "> text", where text may contain initial whitespace
 181     ;; (see below).
 182     (2600 ,(concat "^[" muse-regexp-blank "]*> ") 0 verse)
 183
 184     ;; define anchor points
 185     (2700 "^\\(\\W*\\)#\\(\\S-+\\)\\s-*" 0 anchor)
 186
 187     ;; replace links in the buffer (links to other pages)
 188     (2900 muse-explicit-link-regexp 0 link)
 189
 190     ;; bare URLs
 191     (3000 muse-url-regexp 0 url)
 192
 193     ;; bare email addresses
 194     (3500
 195      "\\([^[]\\)[-a-zA-Z0-9._]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+" 0 email)
 196     )
 197   "List of markup rules for publishing a page with Muse.
 198 The rules given in this variable are invoked first, followed by
 199 whatever rules are specified by the current style.
 200
 201 Each member of the list is either a function, or a list of the form:
 202
 203   (REGEXP/SYMBOL TEXT-BEGIN-GROUP REPLACEMENT-TEXT/FUNCTION/SYMBOL)
 204
 205 REGEXP is a regular expression, or symbol whose value is a regular
 206 expression, which is searched for using `re-search-forward'.
 207 TEXT-BEGIN-GROUP is the matching group within that regexp which
 208 denotes the beginning of the actual text to be marked up.
 209 REPLACEMENT-TEXT is a string that will be passed to `replace-match'.
 210 If it is not a string, but a function, it will be called to determine
 211 what the replacement text should be (it must return a string).  If it
 212 is a symbol, the value of that symbol should be a string.
 213
 214 The replacements are done in order, one rule at a time.  Writing
 215 the regular expressions can be a tricky business.  Note that case
 216 is never ignored.  `case-fold-search' is always bound to nil
 217 while processing the markup rules."
 218   :type '(repeat (choice
 219                   (list :tag "Markup rule"
 220                         integer
 221                         (choice regexp symbol)
 222                         integer
 223                         (choice string function symbol))
 224                   function))
 225   :group 'muse-publish)
 226
 227 (defcustom muse-publish-markup-functions
 228   '((directive . muse-publish-markup-directive)
 229     (comment   . muse-publish-markup-comment)
 230     (anchor    . muse-publish-markup-anchor)
 231     (tag       . muse-publish-markup-tag)
 232     (word      . muse-publish-markup-word)
 233     (emdash    . muse-publish-markup-emdash)
 234     (enddots   . muse-publish-markup-enddots)
 235     (dots      . muse-publish-markup-dots)
 236     (rule      . muse-publish-markup-rule)
 237     (no-break-space . muse-publish-markup-no-break-space)
 238     (heading   . muse-publish-markup-heading)
 239     (footnote  . muse-publish-markup-footnote)
 240     (fn-sep    . muse-publish-markup-fn-sep)
 241     (list      . muse-publish-markup-list)
 242     (quote     . muse-publish-markup-quote)
 243     (verse     . muse-publish-markup-verse)
 244     (table     . muse-publish-markup-table)
 245     (table-el  . muse-publish-markup-table-el)
 246     (email     . muse-publish-markup-email)
 247     (link      . muse-publish-markup-link)
 248     (url       . muse-publish-markup-url))
 249   "An alist of style types to custom functions for that kind of text.
 250
 251 Each member of the list is of the form:
 252
 253   (SYMBOL FUNCTION)
 254
 255 SYMBOL describes the type of text to associate with this rule.
 256 `muse-publish-markup-regexps' maps regexps to these symbols.
 257
 258 FUNCTION is the function to use to mark up this kind of rule if
 259 no suitable function is found through the :functions tag of the
 260 current style."
 261   :type '(alist :key-type symbol :value-type function)
 262   :group 'muse-publish)
 263
 264 (defcustom muse-publish-markup-tags
 265   '(("contents" nil t   nil muse-publish-contents-tag)
 266     ("verse"    t   nil nil muse-publish-verse-tag)
 267     ("example"  t   nil nil muse-publish-example-tag)
 268     ("src"      t   t   nil muse-publish-src-tag)
 269     ("code"     t   nil nil muse-publish-code-tag)
 270     ("quote"    t   nil t   muse-publish-quote-tag)
 271     ("literal"  t   t   nil muse-publish-literal-tag)
 272     ("verbatim" t   nil nil muse-publish-verbatim-tag)
 273     ("br"       nil nil nil muse-publish-br-tag)
 274     ("lisp"     t   t   nil muse-publish-lisp-tag)
 275     ("class"    t   t   nil muse-publish-class-tag)
 276     ("command"  t   t   nil muse-publish-command-tag)
 277     ("perl"     t   t   nil muse-publish-perl-tag)
 278     ("php"      t   t   nil muse-publish-php-tag)
 279     ("python"   t   t   nil muse-publish-python-tag)
 280     ("ruby"     t   t   nil muse-publish-ruby-tag)
 281     ("comment"  t   nil nil muse-publish-comment-tag)
 282     ("include"  nil t   nil muse-publish-include-tag)
 283     ("markup"   t   t   nil muse-publish-mark-up-tag)
 284     ("cite"     t   t   nil muse-publish-cite-tag))
 285   "A list of tag specifications, for specially marking up text.
 286 XML-style tags are the best way to add custom markup to Muse.
 287 This is easily accomplished by customizing this list of markup tags.
 288
 289 For each entry, the name of the tag is given, whether it expects
 290 a closing tag, whether it takes an optional set of attributes,
 291 whether it is nestable, and a function that performs whatever
 292 action is desired within the delimited region.
 293
 294 The tags themselves are deleted during publishing, before the
 295 function is called.  The function is called with three arguments,
 296 the beginning and end of the region surrounded by the tags.  If
 297 properties are allowed, they are passed as a third argument in
 298 the form of an alist.  The `end' argument to the function is
 299 always a marker.
 300
 301 Point is always at the beginning of the region within the tags, when
 302 the function is called.  Wherever point is when the function finishes
 303 is where tag markup will resume.
 304
 305 These tag rules are processed once at the beginning of markup, and
 306 once at the end, to catch any tags which may have been inserted
 307 in-between."
 308   :type '(repeat (list (string :tag "Markup tag")
 309                        (boolean :tag "Expect closing tag" :value t)
 310                        (boolean :tag "Parse attributes" :value nil)
 311                        (boolean :tag "Nestable" :value nil)
 312                        function))
 313   :group 'muse-publish)
 314
 315 (defcustom muse-publish-markup-header-footer-tags
 316   '(("lisp"     t   t   nil muse-publish-lisp-tag)
 317     ("markup"   t   t   nil muse-publish-mark-up-tag))
 318   "Tags used when publishing headers and footers.
 319 See `muse-publish-markup-tags' for details."
 320   :type '(repeat (list (string :tag "Markup tag")
 321                        (boolean :tag "Expect closing tag" :value t)
 322                        (boolean :tag "Parse attributes" :value nil)
 323                        (boolean :tag "Nestable" :value nil)
 324                        function))
 325   :group 'muse-publish)
 326
 327 (defcustom muse-publish-markup-specials nil
 328   "A table of characters which must be represented specially."
 329   :type '(alist :key-type character :value-type string)
 330   :group 'muse-publish)
 331
 332 (defcustom muse-publish-enable-local-variables nil
 333   "If non-nil, interpret local variables in a file when publishing."
 334   :type 'boolean
 335   :group 'muse-publish)
 336
 337 (defcustom muse-publish-enable-dangerous-tags t
 338   "If non-nil, publish tags like <lisp> and <command> that can
 339 call external programs or expose sensitive information.
 340 Otherwise, ignore tags like this.
 341
 342 This is useful to set to nil when the file to publish is coming
 343 from an untrusted source."
 344   :type 'boolean
 345   :group 'muse-publish)
 346
 347 (defvar muse-publishing-p nil
 348   "This is set to t while a page is being published.")
 349 (defvar muse-batch-publishing-p nil
 350   "This is set to t while a page is being batch published.")
 351 (defvar muse-inhibit-before-publish-hook nil
 352   "This is set to t when publishing a file rather than just a buffer.
 353 It is used by `muse-publish-markup-buffer'.")
 354 (defvar muse-publishing-styles nil
 355   "The publishing styles that Muse recognizes.
 356 This is automatically generated when loading publishing styles.")
 357 (defvar muse-publishing-current-file nil
 358   "The file that is currently being published.")
 359 (defvar muse-publishing-current-output-path nil
 360   "The path where the current file will be published to.")
 361 (defvar muse-publishing-current-style nil
 362   "The style of the file that is currently being published.")
 363 (defvar muse-publishing-directives nil
 364   "An alist of publishing directives from the top of a file.")
 365 (defvar muse-publish-generate-contents nil
 366   "Non-nil if a table of contents should be generated.
 367 If non-nil, it is a cons cell specifying (MARKER . DEPTH), to
 368 tell where the <contents> was seen, and to what depth the
 369 contents were requested.")
 370 (defvar muse-publishing-last-position nil
 371   "Last position of the point when publishing.
 372 This is used to make sure that publishing doesn't get stalled.")
 373
 374 (defvar muse-publish-inhibit-style-hooks nil
 375   "If non-nil, do not call the :before or :before-end hooks when publishing.")
 376
 377 (defvar muse-publish-use-header-footer-tags nil
 378   "If non-nil, use `muse-publish-markup-header-footer-tags' for looking up
 379 tags.  Otherwise, use `muse-publish-markup-tags'.")
 380
 381 (defvar muse-inhibit-style-tags nil
 382   "If non-nil, do not search for style-specific tags.
 383 This is used when publishing headers and footers.")
 384
 385 ;; Functions for handling style information
 386
 387 (defsubst muse-style (&optional style)
 388   "Resolve the given STYLE into a Muse style, if it is a string."
 389   (if (null style)
 390       muse-publishing-current-style
 391     (if (stringp style)
 392         (assoc style muse-publishing-styles)
 393       (muse-assert (consp style))
 394       style)))
 395
 396 (defun muse-define-style (name &rest elements)
 397   (let ((entry (assoc name muse-publishing-styles)))
 398     (if entry
 399         (setcdr entry elements)
 400       (setq muse-publishing-styles
 401             (cons (append (list name) elements)
 402                   muse-publishing-styles)))))
 403
 404 (defun muse-derive-style (new-name base-name &rest elements)
 405   (apply 'muse-define-style new-name
 406          (append elements (list :base base-name))))
 407
 408 (defsubst muse-get-keyword (keyword list &optional direct)
 409   (let ((value (cadr (memq keyword list))))
 410     (if (and (not direct) (symbolp value))
 411         (symbol-value value)
 412       value)))
 413
 414 (defun muse-style-elements-list (elem &optional style)
 415   "Return a list all references to ELEM in STYLE, including base styles.
 416 If STYLE is not specified, use current style."
 417   (let (base elements)
 418     (while style
 419       (setq style (muse-style style))
 420       (setq elements (append elements
 421                              (muse-get-keyword elem style)))
 422       (setq style (muse-get-keyword :base style)))
 423     elements))
 424
 425 (defun muse-style-element (elem &optional style direct)
 426   "Search for ELEM in STYLE, including base styles.
 427 If STYLE is not specified, use current style."
 428   (setq style (muse-style style))
 429   (let ((value (muse-get-keyword elem style direct)))
 430     (if value
 431         value
 432       (let ((base (muse-get-keyword :base style)))
 433         (if base
 434             (muse-style-element elem base direct))))))
 435
 436 (defun muse-style-derived-p-1 (base style)
 437   "Internal function used by `muse-style-derived-p'."
 438   (if (and (stringp style)
 439            (string= style base))
 440       t
 441     (setq style (muse-style style))
 442     (let ((value (muse-get-keyword :base style)))
 443       (when value
 444         (muse-style-derived-p base value)))))
 445
 446 (defun muse-style-derived-p (base &optional style)
 447   "Return non-nil if STYLE is equal to or derived from BASE,
 448 non-nil otherwise.
 449
 450 BASE should be a string."
 451   (unless style
 452     (setq style (muse-style)))
 453   (when (and (consp style)
 454              (stringp (car style)))
 455     (setq style (car style)))
 456   (muse-style-derived-p-1 base style))
 457
 458 (defun muse-find-markup-element (keyword ident style)
 459   (let ((def (assq ident (muse-style-element keyword style))))
 460     (if def
 461         (cdr def)
 462       (let ((base (muse-style-element :base style)))
 463         (if base
 464             (muse-find-markup-element keyword ident base))))))
 465
 466 (defun muse-markup-text (ident &rest args)
 467   "Insert ARGS into the text markup associated with IDENT.
 468 If the markup text has sections like %N%, this will be replaced
 469 with the N-1th argument in ARGS.  After that, `format' is applied
 470 to the text with ARGS as parameters."
 471   (let ((text (muse-find-markup-element :strings ident (muse-style))))
 472     (if (and text args)
 473         (progn
 474           (let (start repl-text)
 475             (while (setq start (string-match "%\\([1-9][0-9]*\\)%" text start))
 476               ;; escape '%' in the argument text, since we will be
 477               ;; using format on it
 478               (setq repl-text (muse-replace-regexp-in-string
 479                                "%" "%%"
 480                                (nth (1- (string-to-number
 481                                          (match-string 1 text))) args)
 482                                t t)
 483                     start (+ start (length repl-text))
 484                     text (replace-match repl-text t t text))))
 485           (apply 'format text args))
 486       (or text ""))))
 487
 488 (defun muse-insert-markup (&rest args)
 489   (let ((beg (point)))
 490     (apply 'insert args)
 491     (muse-publish-mark-read-only beg (point))))
 492
 493 (defun muse-find-markup-tag (keyword tagname style)
 494   (let ((def (assoc tagname (muse-style-element keyword style))))
 495     (or def
 496         (let ((base (muse-style-element :base style)))
 497           (if base
 498               (muse-find-markup-tag keyword tagname base))))))
 499
 500 (defun muse-markup-tag-info (tagname &rest args)
 501   (let ((tag-info (and (not muse-inhibit-style-tags)
 502                        (muse-find-markup-tag :tags tagname (muse-style)))))
 503     (or tag-info
 504         (assoc tagname
 505                (if muse-publish-use-header-footer-tags
 506                    muse-publish-markup-header-footer-tags
 507                  muse-publish-markup-tags)))))
 508
 509 (defsubst muse-markup-function (category)
 510   (let ((func (muse-find-markup-element :functions category (muse-style))))
 511     (or func
 512         (cdr (assq category muse-publish-markup-functions)))))
 513
 514 ;; Publishing routines
 515
 516 (defun muse-publish-markup (name rules)
 517   (let* ((case-fold-search nil)
 518          (inhibit-read-only t)
 519          (limit (* (length rules) (point-max)))
 520          (verbose (and muse-publish-report-threshhold
 521                        (> (point-max) muse-publish-report-threshhold)))
 522          (base 0))
 523     (while rules
 524       (goto-char (point-min))
 525       (let ((regexp (nth 1 (car rules)))
 526             (group (nth 2 (car rules)))
 527             (repl (nth 3 (car rules)))
 528             pos)
 529         (setq muse-publishing-last-position nil)
 530         (if (symbolp regexp)
 531             (setq regexp (symbol-value regexp)))
 532         (if (and verbose (not muse-batch-publishing-p))
 533             (message "Publishing %s...%d%%" name
 534                      (* (/ (float (+ (point) base)) limit) 100)))
 535         (while (and regexp (progn
 536                              (when (get-text-property (point) 'read-only)
 537                                (goto-char (or (next-single-property-change
 538                                                (point) 'read-only)
 539                                               (point-max))))
 540                              (setq pos (re-search-forward regexp nil t))))
 541           (if (and verbose (not muse-batch-publishing-p))
 542               (message "Publishing %s...%d%%" name
 543                        (* (/ (float (+ (point) base)) limit) 100)))
 544           (unless (and (> (- (match-end 0) (match-beginning 0)) 0)
 545                        (match-beginning group)
 546                        (get-text-property (match-beginning group) 'read-only))
 547             (let* (func
 548                    (text (cond
 549                           ((and (symbolp repl)
 550                                 (setq func (muse-markup-function repl)))
 551                            (funcall func))
 552                           ((functionp repl)
 553                            (funcall repl))
 554                           ((symbolp repl)
 555                            (symbol-value repl))
 556                           (t repl))))
 557               (if (stringp text)
 558                   (replace-match text t))))
 559           (if (and muse-publishing-last-position
 560                    (= pos muse-publishing-last-position))
 561               (if (eobp)
 562                   (setq regexp nil)
 563                 (forward-char 1)))
 564           (setq muse-publishing-last-position pos)))
 565       (setq rules (cdr rules)
 566             base (+ base (point-max))))
 567     (if (and verbose (not muse-batch-publishing-p))
 568         (message "Publishing %s...done" name))))
 569
 570 (defun muse-insert-file-or-string (file-or-string &optional title)
 571   (let ((beg (point)) end)
 572     (if (and (not (string-equal file-or-string ""))
 573              (not (string-match "\n" file-or-string))
 574              (file-readable-p file-or-string))
 575         (setq end (+ beg
 576                      (cadr (muse-insert-file-contents file-or-string))))
 577       (insert file-or-string)
 578       (setq end (point)))
 579     (save-restriction
 580       (narrow-to-region beg end)
 581       (remove-text-properties (point-min) (point-max)
 582                               '(read-only nil rear-nonsticky nil))
 583       (goto-char (point-min))
 584       (let ((muse-inhibit-style-tags t)
 585             (muse-publish-use-header-footer-tags t))
 586         (muse-publish-markup (or title "")
 587                              '((100 muse-tag-regexp 0
 588                                     muse-publish-markup-tag)))))))
 589
 590 (defun muse-style-run-hooks (keyword style &rest args)
 591   (catch 'handled
 592     (let ((cache nil))
 593       (while (and style
 594                   (setq style (muse-style style)))
 595         (let ((func (muse-style-element keyword style t)))
 596           (when (and func
 597                      (not (member func cache)))
 598             (setq cache (cons func cache))
 599             (when (apply func args)
 600               (throw 'handled t))))
 601         (setq style (muse-style-element :base style))))))
 602
 603 (defun muse-publish-markup-region (beg end &optional title style)
 604   "Apply the given STYLE's markup rules to the given region.
 605 TITLE is used when indicating the publishing progress; it may be nil.
 606
 607 The point is guaranteed to be at END if the routine terminates
 608 normally."
 609   (unless title (setq title ""))
 610   (unless style
 611     (or (setq style muse-publishing-current-style)
 612         (error "Cannot find any publishing styles to use")))
 613   (save-restriction
 614     (narrow-to-region beg end)
 615     (let ((muse-publish-generate-contents nil))
 616       (unless muse-publish-inhibit-style-hooks
 617         (muse-style-run-hooks :before style))
 618       (muse-publish-markup
 619        title
 620        (sort (copy-alist (append muse-publish-markup-regexps
 621                                  (muse-style-elements-list :regexps style)))
 622              (function
 623               (lambda (l r)
 624                 (< (car l) (car r))))))
 625       (unless muse-publish-inhibit-style-hooks
 626         (muse-style-run-hooks :before-end style))
 627       (muse-publish-escape-specials (point-min) (point-max) nil 'document))
 628     (goto-char (point-max))))
 629
 630 (defun muse-publish-markup-buffer (title style)
 631   "Apply the given STYLE's markup rules to the current buffer."
 632   (setq style (muse-style style))
 633   (let ((style-header (muse-style-element :header style))
 634         (style-footer (muse-style-element :footer style))
 635         (muse-publishing-current-style style)
 636         (muse-publishing-directives
 637          (list (cons "title" title)
 638                (cons "author" (user-full-name))
 639                (cons "date" (format-time-string
 640                              muse-publish-date-format
 641                              (if muse-publishing-current-file
 642                                  (nth 5 (file-attributes
 643                                          muse-publishing-current-file))
 644                                (current-time))))))
 645         (muse-publishing-p t)
 646         (inhibit-read-only t))
 647     (run-hooks 'muse-update-values-hook)
 648     (unless muse-inhibit-before-publish-hook
 649       (run-hooks 'muse-before-publish-hook))
 650     (muse-publish-markup-region (point-min) (point-max) title style)
 651     (goto-char (point-min))
 652     (when style-header
 653       (muse-insert-file-or-string style-header title))
 654     (goto-char (point-max))
 655     (when style-footer
 656       (muse-insert-file-or-string style-footer title))
 657     (muse-style-run-hooks :after style)
 658     (run-hooks 'muse-after-publish-hook)))
 659
 660 (defun muse-publish-markup-string (string &optional style)
 661   "Markup STRING using the given STYLE's markup rules."
 662   (setq style (muse-style style))
 663   (muse-with-temp-buffer
 664     (insert string)
 665     (let ((muse-publishing-current-style style)
 666           (muse-publishing-p t))
 667       (muse-publish-markup "*string*" (muse-style-element :rules style)))
 668     (buffer-string)))
 669
 670 ;; Commands for publishing files
 671
 672 (defun muse-publish-get-style (&optional styles)
 673   (unless styles (setq styles muse-publishing-styles))
 674   (if (= 1 (length styles))
 675       (car styles)
 676     (when (catch 'different
 677             (let ((first (car (car styles))))
 678               (dolist (style (cdr styles))
 679                 (unless (equal first (car style))
 680                   (throw 'different t)))))
 681       (setq styles (muse-collect-alist
 682                     styles
 683                     (funcall muse-completing-read-function
 684                              "Publish with style: " styles nil t))))
 685     (if (or (= 1 (length styles))
 686             (not (muse-get-keyword :path (car styles))))
 687         (car styles)
 688       (setq styles (mapcar (lambda (style)
 689                              (cons (muse-get-keyword :path style)
 690                                    style))
 691                            styles))
 692       (cdr (assoc (funcall muse-completing-read-function
 693                            "Publish to directory: " styles nil t)
 694                   styles)))))
 695
 696 (defsubst muse-publish-get-output-dir (style)
 697   (let ((default-directory (or (muse-style-element :path style)
 698                                default-directory)))
 699     (muse-read-directory-name "Publish to directory: " nil default-directory)))
 700
 701 (defsubst muse-publish-get-info ()
 702   (let ((style (muse-publish-get-style)))
 703     (list style (muse-publish-get-output-dir style)
 704           current-prefix-arg)))
 705
 706 (defsubst muse-publish-output-name (&optional file style)
 707   (setq style (muse-style style))
 708   (concat (muse-style-element :prefix style)
 709           (muse-page-name file)
 710           (muse-style-element :suffix style)))
 711
 712 (defsubst muse-publish-output-file (file &optional output-dir style)
 713   (setq style (muse-style style))
 714   (if output-dir
 715       (expand-file-name (muse-publish-output-name file style) output-dir)
 716     (concat (file-name-directory file)
 717             (muse-publish-output-name file style))))
 718
 719 (defsubst muse-publish-link-name (&optional file style)
 720   "Take FILE and add :prefix and either :link-suffix or :suffix from STYLE.
 721 We assume that FILE is a Muse file.
 722
 723 We call `muse-page-name' on FILE to remove the directory part of
 724 FILE and any extensions that are in `muse-ignored-extensions'."
 725   (setq style (muse-style style))
 726   (concat (muse-style-element :prefix style)
 727           (muse-page-name file)
 728           (or (muse-style-element :link-suffix style)
 729               (muse-style-element :suffix style))))
 730
 731 (defsubst muse-publish-link-file (file &optional style)
 732   "Turn FILE into a URL.
 733
 734 If FILE exists on the system as-is, return it without
 735 modification.  In the case of wanting to link to Muse files when
 736 `muse-file-extension' is nil, you should load muse-project.el.
 737
 738 Otherwise, assume that it is a Muse file and call
 739 `muse-publish-link-name' to add :prefix, :link-suffix, :suffix,
 740 and removing ignored file extensions, but preserving the
 741 directory part of FILE."
 742   (setq style (muse-style style))
 743   (if (file-exists-p file)
 744       file
 745     (concat (file-name-directory file)
 746             (muse-publish-link-name file style))))
 747
 748 (defsubst muse-publish-link-page (page)
 749   "Turn PAGE into a URL.
 750
 751 This is called by `muse-publish-classify-url' to figure out what
 752 a link to another file or Muse page should look like.
 753
 754 If muse-project.el is loaded, call `muse-project-link-page' for this.
 755 Otherwise, call `muse-publish-link-file'."
 756   (if (fboundp 'muse-project-link-page)
 757       (muse-project-link-page page)
 758     (muse-publish-link-file page)))
 759
 760 (defmacro muse-publish-ensure-block (beg &optional end)
 761   "Ensure that block-level markup at BEG is published with at least one
 762 preceding blank line.  BEG must be an unquoted symbol that contains a
 763 position or marker.  BEG is modified to be the new position.
 764 The point is left at the new value of BEG.
 765
 766 Additionally, make sure that BEG is placed on a blank line.
 767
 768 If END is given, make sure that it is placed on a blank line.  In
 769 order to achieve this, END must be an unquoted symbol that
 770 contains a marker.  This is the case with Muse tag functions."
 771   `(progn
 772      (goto-char ,beg)
 773      (cond ((not (bolp)) (insert "\n\n"))
 774            ((eq (point) (point-min)) nil)
 775            ((prog2 (backward-char) (bolp) (forward-char)) nil)
 776            (t (insert "\n")))
 777      (unless (and (bolp) (eolp))
 778        (insert "\n")
 779        (backward-char))
 780      (setq ,beg (point))
 781      (when (markerp ,end)
 782        (goto-char ,end)
 783        (unless (and (bolp) (eolp))
 784          (insert-before-markers "\n")))
 785      (goto-char ,beg)))
 786
 787 ;;;###autoload
 788 (defun muse-publish-region (beg end &optional title style)
 789   "Apply the given STYLE's markup rules to the given region.
 790 The result is placed in a new buffer that includes TITLE in its name."
 791   (interactive "r")
 792   (when (interactive-p)
 793     (unless title (setq title (read-string "Title: ")))
 794     (unless style (setq style (muse-publish-get-style))))
 795   (let ((muse-publishing-current-style style)
 796         (muse-publishing-p t)
 797         (text (buffer-substring beg end))
 798         (buf (generate-new-buffer (concat "*Muse: " title "*"))))
 799     (with-current-buffer buf
 800       (insert text)
 801       (muse-publish-markup-buffer title style)
 802       (goto-char (point-min))
 803       (let ((inhibit-read-only t))
 804         (remove-text-properties (point-min) (point-max)
 805                                 '(rear-nonsticky nil read-only nil))))
 806     (pop-to-buffer buf)))
 807
 808 ;;;###autoload
 809 (defun muse-publish-file (file style &optional output-dir force)
 810   "Publish the given FILE in a particular STYLE to OUTPUT-DIR.
 811 If the argument FORCE is nil, each file is only published if it is
 812 newer than the published version.  If the argument FORCE is non-nil,
 813 the file is published no matter what."
 814   (interactive (cons (read-file-name "Publish file: ")
 815                      (muse-publish-get-info)))
 816   (let ((style-name style))
 817     (setq style (muse-style style))
 818     (unless style
 819       (error "There is no style '%s' defined" style-name)))
 820   (let* ((output-path (muse-publish-output-file file output-dir style))
 821          (output-suffix (muse-style-element :osuffix style))
 822          (muse-publishing-current-file file)
 823          (muse-publishing-current-output-path output-path)
 824          (target (if output-suffix
 825                      (concat (muse-path-sans-extension output-path)
 826                              output-suffix)
 827                    output-path))
 828          (threshhold (nth 7 (file-attributes file))))
 829     (if (not threshhold)
 830         (message "Please save %s before publishing" file)
 831       (when (or force (file-newer-than-file-p file target))
 832         (if (and muse-publish-report-threshhold
 833                  (> threshhold
 834                     muse-publish-report-threshhold))
 835             (message "Publishing %s ..." file))
 836         (muse-with-temp-buffer
 837           (muse-insert-file-contents file)
 838           (run-hooks 'muse-before-publish-hook)
 839           (when muse-publish-enable-local-variables
 840             (hack-local-variables))
 841           (let ((muse-inhibit-before-publish-hook t))
 842             (muse-publish-markup-buffer (muse-page-name file) style))
 843           (when (muse-write-file output-path)
 844             (muse-style-run-hooks :final style file output-path target)))
 845         t))))
 846
 847 ;;;###autoload
 848 (defun muse-publish-this-file (style output-dir &optional force)
 849   "Publish the currently-visited file.
 850 Prompt for both the STYLE and OUTPUT-DIR if they are not
 851 supplied."
 852   (interactive (muse-publish-get-info))
 853   (if buffer-file-name
 854       (let ((muse-current-output-style (list :base (car style)
 855                                              :path output-dir)))
 856         (unless (muse-publish-file buffer-file-name style output-dir force)
 857           (message (concat "The published version is up-to-date; use"
 858                            " C-u C-c C-T to force an update."))))
 859     (message "This buffer is not associated with any file")))
 860
 861 (defun muse-batch-publish-files ()
 862   "Publish Muse files in batch mode."
 863   (let ((muse-batch-publishing-p t)
 864         muse-current-output-style
 865         style output-dir)
 866     ;; don't activate VC when publishing files
 867     (setq vc-handled-backends nil)
 868     (setq style (car command-line-args-left)
 869           command-line-args-left (cdr command-line-args-left)
 870           output-dir (car command-line-args-left)
 871           output-dir
 872           (if (string-match "\\`--output-dir=" output-dir)
 873               (prog1
 874                   (substring output-dir (match-end 0))
 875                 (setq command-line-args-left (cdr command-line-args-left))))
 876           muse-current-output-style (list :base style :path output-dir))
 877     (setq auto-mode-alist
 878           (delete (cons (concat "\\." muse-file-extension "\\'")
 879                         'muse-mode-choose-mode)
 880                   auto-mode-alist))
 881     (dolist (file command-line-args-left)
 882       (muse-publish-file file style output-dir t))))
 883
 884 ;; Default publishing rules
 885
 886 (defun muse-publish-section-close (depth)
 887   "Seach forward for the closing tag of given DEPTH."
 888   (let (not-end)
 889     (save-excursion
 890       (while (and (setq not-end (re-search-forward
 891                                  (concat "^\\*\\{1," (number-to-string depth)
 892                                          "\\}\\s-+")
 893                                  nil t))
 894                   (get-text-property (match-beginning 0) 'read-only)))
 895       (if not-end
 896           (forward-line 0)
 897         (goto-char (point-max)))
 898       (cond ((not (eq (char-before) ?\n))
 899              (insert "\n\n"))
 900             ((not (eq (char-before (1- (point))) ?\n))
 901              (insert "\n")))
 902       (muse-insert-markup (muse-markup-text 'section-close depth))
 903       (insert "\n"))))
 904
 905 (defun muse-publish-markup-directive (&optional name value)
 906   (unless name (setq name (match-string 1)))
 907   (unless value (setq value (match-string 2)))
 908   (let ((elem (assoc name muse-publishing-directives)))
 909     (if elem
 910         (setcdr elem value)
 911       (setq muse-publishing-directives
 912             (cons (cons name value)
 913                   muse-publishing-directives))))
 914   ;; Make sure we don't ever try to move the point forward (past the
 915   ;; beginning of buffer) while we're still searching for directives.
 916   (setq muse-publishing-last-position nil)
 917   (delete-region (match-beginning 0) (match-end 0)))
 918
 919 (defsubst muse-publishing-directive (name)
 920   (cdr (assoc name muse-publishing-directives)))
 921
 922 (defmacro muse-publish-get-and-delete-attr (attr attrs)
 923   "Delete attribute ATTR from ATTRS only once, destructively.
 924
 925 This function returns the matching attribute value, if found."
 926   (let ((last (make-symbol "last"))
 927         (found (make-symbol "found"))
 928         (vals (make-symbol "vals")))
 929     `(let ((,vals ,attrs))
 930        (if (string= (caar ,vals) ,attr)
 931            (prog1 (cdar ,vals)
 932              (setq ,attrs (cdr ,vals)))
 933          (let ((,last ,vals)
 934                (,found nil))
 935            (while ,vals
 936              (setq ,vals (cdr ,vals))
 937              (when (string= (caar ,vals) ,attr)
 938                (setq ,found (cdar ,vals))
 939                (setcdr ,last (cdr ,vals))
 940                (setq ,vals nil))
 941              (setq ,last ,vals))
 942            ,found)))))
 943
 944 (defun muse-publish-markup-anchor ()
 945   (unless (get-text-property (match-end 1) 'muse-link)
 946     (let ((text (muse-markup-text 'anchor (match-string 2))))
 947       (unless (string= text "")
 948         (save-match-data
 949           (skip-chars-forward (concat muse-regexp-blank "\n"))
 950           (muse-insert-markup text)))
 951       (match-string 1))))
 952
 953 (defun muse-publish-markup-comment ()
 954   (if (null muse-publish-comments-p)
 955       ""
 956     (goto-char (match-end 0))
 957     (muse-insert-markup (muse-markup-text 'comment-end))
 958     (if (match-beginning 1)
 959         (progn
 960           (muse-publish-mark-read-only (match-beginning 1) (match-end 1))
 961           (delete-region (match-beginning 0) (match-beginning 1)))
 962       (delete-region (match-beginning 0) (match-end 0)))
 963     (goto-char (match-beginning 0))
 964     (muse-insert-markup (muse-markup-text 'comment-begin))))
 965
 966 (defun muse-publish-markup-tag ()
 967   (let ((tag-info (muse-markup-tag-info (match-string 1))))
 968     (when (and tag-info
 969                (not (get-text-property (match-beginning 0) 'read-only))
 970                (nth 4 tag-info)
 971                (or muse-publish-enable-dangerous-tags
 972                    (not (get (nth 4 tag-info) 'muse-dangerous-tag))))
 973       (let ((closed-tag (match-string 3))
 974             (start (match-beginning 0))
 975             (beg (point))
 976             end attrs)
 977         (when (nth 2 tag-info)
 978           (let ((attrstr (match-string 2)))
 979             (while (and attrstr
 980                         (string-match (concat "\\([^"
 981                                               muse-regexp-blank
 982                                               "=\n]+\\)\\(=\"\\"
 983                                               "([^\"]+\\)\"\\)?")
 984                                       attrstr))
 985               (let ((attr (cons (downcase
 986                                  (muse-match-string-no-properties 1 attrstr))
 987                                 (muse-match-string-no-properties 3 attrstr))))
 988                 (setq attrstr (replace-match "" t t attrstr))
 989                 (if attrs
 990                     (nconc attrs (list attr))
 991                   (setq attrs (list attr)))))))
 992         (if (and (cadr tag-info) (not closed-tag))
 993             (if (muse-goto-tag-end (car tag-info) (nth 3 tag-info))
 994                 (delete-region (match-beginning 0) (point))
 995               (setq tag-info nil)))
 996         (when tag-info
 997           (setq end (point-marker))
 998           (delete-region start beg)
 999           (goto-char start)
1000           (let ((args (list start end)))
1001             (if (nth 2 tag-info)
1002                 (nconc args (list attrs)))
1003             (let ((muse-inhibit-style-tags nil))
1004               ;; remove the inhibition
1005               (apply (nth 4 tag-info) args)))
1006           (set-marker end nil)))))
1007   nil)
1008
1009 (defun muse-publish-escape-specials (beg end &optional ignore-read-only context)
1010   "Escape specials from BEG to END using style-specific :specials.
1011 If IGNORE-READ-ONLY is non-nil, ignore the read-only property.
1012 CONTEXT is used to figure out what kind of specials to escape.
1013
1014 The following contexts exist in Muse.
1015 'underline  _underlined text_
1016 'literal    =monospaced text= or <code> region (monospaced, escaped)
1017 'emphasis   *emphasized text*
1018 'email      email@example.com
1019 'url        http://example.com
1020 'url-desc   [[...][description of an explicit link]]
1021 'image      [[image.png]]
1022 'example    <example> region (monospaced, block context, escaped)
1023 'verbatim   <verbatim> region (escaped)
1024 'footnote   footnote text
1025 'document   normal text"
1026   (let ((specials (muse-style-element :specials nil t)))
1027     (cond ((functionp specials)
1028            (setq specials (funcall specials context)))
1029           ((symbolp specials)
1030            (setq specials (symbol-value specials))))
1031     (if (functionp specials)
1032         (funcall specials beg end ignore-read-only)
1033       (save-excursion
1034         (save-restriction
1035         (narrow-to-region beg end)
1036         (goto-char (point-min))
1037         (while (< (point) (point-max))
1038           (if (and (not ignore-read-only)
1039                    (get-text-property (point) 'read-only))
1040               (goto-char (or (next-single-property-change (point) 'read-only)
1041                              (point-max)))
1042             (let ((repl (or (assoc (char-after) specials)
1043                             (assoc (char-after)
1044                                    muse-publish-markup-specials))))
1045               (if (null repl)
1046                   (forward-char 1)
1047                 (delete-char 1)
1048                 (insert-before-markers (cdr repl)))))))))))
1049
1050 (defun muse-publish-markup-word ()
1051   (let* ((beg (match-beginning 2))
1052          (end (1- (match-end 2)))
1053          (leader (buffer-substring-no-properties beg end))
1054          open-tag close-tag mark-read-only loc context)
1055     (cond
1056      ((string= leader "_")
1057       (setq context 'underline
1058             open-tag (muse-markup-text 'begin-underline)
1059             close-tag (muse-markup-text 'end-underline)))
1060      ((string= leader "=")
1061       (setq context 'literal
1062             open-tag (muse-markup-text 'begin-literal)
1063             close-tag (muse-markup-text 'end-literal))
1064       (setq mark-read-only t))
1065      (t
1066       (let ((l (length leader)))
1067         (setq context 'emphasis)
1068         (cond
1069          ((= l 1) (setq open-tag (muse-markup-text 'begin-emph)
1070                         close-tag (muse-markup-text 'end-emph)))
1071          ((= l 2) (setq open-tag (muse-markup-text 'begin-more-emph)
1072                         close-tag (muse-markup-text 'end-more-emph)))
1073          ((= l 3) (setq open-tag (muse-markup-text 'begin-most-emph)
1074                         close-tag (muse-markup-text 'end-most-emph)))
1075          (t (setq context nil))))))
1076     (if (and context
1077              (not (get-text-property beg 'muse-link))
1078              (setq loc (search-forward leader nil t))
1079              (or (eobp) (not (eq (char-syntax (char-after loc)) ?w)))
1080              (not (eq (char-syntax (char-before (point))) ?\ ))
1081              (not (get-text-property (point) 'muse-link)))
1082         (progn
1083           (replace-match "")
1084           (delete-region beg end)
1085           (setq end (point-marker))
1086           (muse-insert-markup close-tag)
1087           (goto-char beg)
1088           (muse-insert-markup open-tag)
1089           (setq beg (point))
1090           (when mark-read-only
1091             (muse-publish-escape-specials beg end t context)
1092             (muse-publish-mark-read-only beg end))
1093           (set-marker end nil))
1094       (backward-char))
1095     nil))
1096
1097 (defun muse-publish-markup-emdash ()
1098   (unless (get-text-property (match-beginning 0) 'muse-link)
1099     (let ((prespace (match-string 1))
1100           (postspace (match-string 2)))
1101       (delete-region (match-beginning 0) (match-end 0))
1102       (muse-insert-markup (muse-markup-text 'emdash prespace postspace))
1103       (when (eq (char-after) ?\<)
1104         (insert ?\n)))))
1105
1106 (defun muse-publish-markup-enddots ()
1107   (unless (get-text-property (match-beginning 0) 'muse-link)
1108     (delete-region (match-beginning 0) (match-end 0))
1109     (muse-insert-markup (muse-markup-text 'enddots))))
1110
1111 (defun muse-publish-markup-dots ()
1112   (unless (get-text-property (match-beginning 0) 'muse-link)
1113     (delete-region (match-beginning 0) (match-end 0))
1114     (muse-insert-markup (muse-markup-text 'dots))))
1115
1116 (defun muse-publish-markup-rule ()
1117   (unless (get-text-property (match-beginning 0) 'muse-link)
1118     (delete-region (match-beginning 0) (match-end 0))
1119     (muse-insert-markup (muse-markup-text 'rule))))
1120
1121 (defun muse-publish-markup-no-break-space ()
1122   (unless (get-text-property (match-beginning 0) 'muse-link)
1123     (delete-region (match-beginning 0) (match-end 0))
1124     (muse-insert-markup (muse-markup-text 'no-break-space))))
1125
1126 (defun muse-publish-markup-heading ()
1127   (let* ((len (length (match-string 1)))
1128          (start (muse-markup-text
1129                  (cond ((= len 1) 'section)
1130                        ((= len 2) 'subsection)
1131                        ((= len 3) 'subsubsection)
1132                        (t 'section-other))
1133                  len))
1134          (end   (muse-markup-text
1135                  (cond ((= len 1) 'section-end)
1136                        ((= len 2) 'subsection-end)
1137                        ((= len 3) 'subsubsection-end)
1138                        (t 'section-other-end))
1139                  len)))
1140     (delete-region (match-beginning 0) (match-end 0))
1141     (muse-insert-markup start)
1142     (end-of-line)
1143     (when end
1144       (muse-insert-markup end))
1145     (forward-line 1)
1146     (unless (eq (char-after) ?\n)
1147       (insert "\n"))
1148     (muse-publish-section-close len)))
1149
1150 (defvar muse-publish-footnotes nil)
1151
1152 (defun muse-publish-markup-footnote ()
1153   "Scan ahead and snarf up the footnote body."
1154   (cond
1155    ((get-text-property (match-beginning 0) 'muse-link)
1156     nil)
1157    ((= (muse-line-beginning-position) (match-beginning 0))
1158     "")
1159    (t
1160     (let ((footnote (save-match-data
1161                       (string-to-number (match-string 1))))
1162           (oldtext (match-string 0))
1163           footnotemark)
1164       (delete-region (match-beginning 0) (match-end 0))
1165       (save-excursion
1166         (when (re-search-forward (format "^\\[%d\\]\\s-+" footnote) nil t)
1167           (let* ((start (match-beginning 0))
1168                  (beg (goto-char (match-end 0)))
1169                  (end (save-excursion
1170                         (if (search-forward "\n\n" nil t)
1171                             (copy-marker (match-beginning 0))
1172                           (goto-char (point-max))
1173                           (skip-chars-backward "\n")
1174                           (point-marker)))))
1175             (while (re-search-forward
1176                     (concat "^[" muse-regexp-blank "]+\\([^\n]\\)")
1177                     end t)
1178               (replace-match "\\1" t))
1179             (let ((footnotemark-cmd (muse-markup-text 'footnotemark))
1180                   (footnotemark-end-cmd (muse-markup-text 'footnotemark-end)))
1181               (if (string= "" footnotemark-cmd)
1182                   (setq footnotemark
1183                         (concat (muse-markup-text 'footnote)
1184                                 (muse-publish-escape-specials-in-string
1185                                  (buffer-substring-no-properties beg end)
1186                                  'footnote)
1187                                 (muse-markup-text 'footnote-end)))
1188                 (setq footnotemark (format footnotemark-cmd footnote
1189                                            footnotemark-end-cmd))
1190                 (unless muse-publish-footnotes
1191                   (set (make-local-variable 'muse-publish-footnotes)
1192                        (make-vector 256 nil)))
1193                 (unless (aref muse-publish-footnotes footnote)
1194                   (setq footnotemark
1195                         (concat
1196                          footnotemark
1197                          (concat (format (muse-markup-text 'footnotetext)
1198                                          footnote)
1199                                  (buffer-substring-no-properties beg end)
1200                                  (muse-markup-text 'footnotetext-end))))
1201                   (aset muse-publish-footnotes footnote footnotemark))))
1202             (goto-char end)
1203             (skip-chars-forward "\n")
1204             (delete-region start (point))
1205             (set-marker end nil))))
1206       (if footnotemark
1207           (muse-insert-markup footnotemark)
1208         (insert oldtext))))))
1209
1210 (defun muse-publish-markup-fn-sep ()
1211   (delete-region (match-beginning 0) (match-end 0))
1212   (muse-insert-markup (muse-markup-text 'fn-sep)))
1213
1214 (defun muse-insert-markup-end-list (&rest args)
1215   (let ((beg (point)))
1216     (apply 'insert args)
1217     (add-text-properties beg (point) '(end-list t))
1218     (muse-publish-mark-read-only beg (point))))
1219
1220 (defun muse-publish-determine-dl-indent (continue indent-sym determine-sym)
1221   ;; If the caller doesn't know how much indentation to use, figure it
1222   ;; out ourselves.  It is assumed that `muse-forward-list-item' has
1223   ;; been called just before this to set the match data.
1224   (when (and continue
1225              (symbol-value determine-sym))
1226     (save-match-data
1227       ;; snarf all leading whitespace
1228       (let ((indent (and (match-beginning 2)
1229                          (buffer-substring (match-beginning 1)
1230                                            (match-beginning 2)))))
1231         (when (and indent
1232                    (not (string= indent "")))
1233           (set indent-sym indent)
1234           (set determine-sym nil))))))
1235
1236 (defun muse-publish-surround-dl (indent post-indent)
1237   (let* ((beg-item (muse-markup-text 'begin-dl-item))
1238          (end-item (muse-markup-text 'end-dl-item))
1239          (beg-ddt (muse-markup-text 'begin-ddt)) ;; term
1240          (end-ddt (muse-markup-text 'end-ddt))
1241          (beg-dde (muse-markup-text 'begin-dde)) ;; definition
1242          (end-dde (muse-markup-text 'end-dde))
1243          (continue t)
1244          (no-terms t)
1245          beg)
1246     (while continue
1247       ;; envelope this as one term+definitions unit -- HTML does not
1248       ;; need this, but DocBook and Muse's custom XML format do
1249       (muse-insert-markup beg-item)
1250       (when (looking-at muse-dl-term-regexp)
1251         ;; find the term and wrap it with published markup
1252         (setq beg (point)
1253               no-terms nil)
1254         (goto-char (match-end 1))
1255         (delete-region (point) (match-end 0))
1256         (muse-insert-markup-end-list end-ddt)
1257         ;; if definition is immediately after term, move to next line
1258         (unless (eq (char-after) ?\n)
1259           (insert ?\n))
1260         (save-excursion
1261           (goto-char beg)
1262           (delete-region (point) (match-beginning 1))
1263           (muse-insert-markup beg-ddt)))
1264       ;; handle pathological edge case where there is no term -- I
1265       ;; would prefer to just disallow this, but people seem to want
1266       ;; this behavior
1267       (when (and no-terms
1268                  (looking-at (concat "[" muse-regexp-blank "]*::"
1269                                      "[" muse-regexp-blank "]*")))
1270         (delete-region (point) (match-end 0))
1271         ;; but only do this once
1272         (setq no-terms nil))
1273       (setq beg (point)
1274             ;; move past current item
1275             continue (muse-forward-list-item 'dl-term indent))
1276       (save-restriction
1277         (narrow-to-region beg (point))
1278         (goto-char (point-min))
1279         ;; publish each definition that we find, defaulting to an
1280         ;; empty definition if none are found
1281         (muse-publish-surround-text beg-dde end-dde
1282          (lambda (indent)
1283            (muse-forward-list-item 'dl-entry indent))
1284          indent post-indent
1285          #'muse-publish-determine-dl-indent)
1286         (goto-char (point-max))
1287         (skip-chars-backward (concat muse-regexp-blank "\n"))
1288         (muse-insert-markup-end-list end-item)
1289         (when continue
1290           (goto-char (point-max)))))))
1291
1292 (defun muse-publish-strip-list-indentation (list-item empty-line indent post-indent)
1293   (let ((list-nested nil)
1294         (indent-found nil))
1295     (while (< (point) (point-max))
1296       (when (and (looking-at list-item)
1297                  (not (or (get-text-property
1298                            (muse-list-item-critical-point) 'read-only)
1299                           (get-text-property
1300                            (muse-list-item-critical-point) 'muse-link))))
1301         ;; if we encounter a list item, allow no post-indent space
1302         (setq list-nested t))
1303       (when (and (not (looking-at empty-line))
1304                  (looking-at (concat indent "\\("
1305                                      (or (and list-nested "")
1306                                          post-indent)
1307                                      "\\)")))
1308         ;; if list is not nested, remove indentation
1309         (unless indent-found
1310           (setq post-indent (match-string 1)
1311                 indent-found t))
1312         (replace-match ""))
1313       (forward-line 1))))
1314
1315 (defun muse-publish-surround-text (beg-tag end-tag move-func &optional indent post-indent determine-indent-func list-item)
1316   (unless list-item
1317     (setq list-item (format muse-list-item-regexp
1318                             (concat "[" muse-regexp-blank "]*"))))
1319   (let ((continue t)
1320         (empty-line (concat "^[" muse-regexp-blank "]*\n"))
1321         (determine-indent (if determine-indent-func t nil))
1322         (new-indent indent)
1323         (first t)
1324         beg)
1325     (unless indent
1326       (setq indent (concat "[" muse-regexp-blank "]+")))
1327     (if post-indent
1328         (setq post-indent (concat " \\{0," (number-to-string post-indent)
1329                                   "\\}"))
1330       (setq post-indent ""))
1331     (while continue
1332       (if (or (not end-tag) (string= end-tag ""))
1333           ;; if no end of list item markup exists, treat the beginning
1334           ;; of list item markup as it if it were the end -- this
1335           ;; prevents multiple-level lists from being confused
1336           (muse-insert-markup-end-list beg-tag)
1337         (muse-insert-markup beg-tag))
1338       (setq beg (point)
1339             ;; move past current item; continue is non-nil if there
1340             ;; are more like items to be processed
1341             continue (if (and determine-indent-func first)
1342                          (funcall move-func (concat indent post-indent))
1343                        (funcall move-func indent)))
1344       (when determine-indent-func
1345         (funcall determine-indent-func continue 'new-indent 'determine-indent))
1346       (when continue
1347           ;; remove list markup if we encountered another item of the
1348           ;; same type
1349           (replace-match "" t t nil 1))
1350       (save-restriction
1351         ;; narrow to current item
1352         (narrow-to-region beg (point))
1353         (goto-char (point-min))
1354         (if (looking-at empty-line)
1355             ;; if initial line is blank, move to first non-blank line
1356             (while (progn (forward-line 1)
1357                           (and (< (point) (point-max))
1358                                (looking-at empty-line))))
1359           ;; otherwise, move to second line of text
1360           (forward-line 1))
1361         ;; strip list indentation
1362         (muse-publish-strip-list-indentation list-item empty-line
1363                                              indent post-indent)
1364         (skip-chars-backward (concat muse-regexp-blank "\n"))
1365         (muse-insert-markup-end-list end-tag)
1366         (when determine-indent-func
1367           (setq indent new-indent))
1368         (when first
1369           (setq first nil))
1370         (when continue
1371           (goto-char (point-max)))))))
1372
1373 (defun muse-publish-ensure-blank-line ()
1374   "Make sure that a blank line exists on the line before point."
1375   (let ((pt (point-marker)))
1376     (beginning-of-line)
1377     (cond ((eq (point) (point-min)) nil)
1378           ((prog2 (backward-char) (bolp) (forward-char)) nil)
1379           (t (insert-before-markers "\n")))
1380     (goto-char pt)
1381     (set-marker pt nil)))
1382
1383 (defun muse-publish-markup-list ()
1384   "Markup a list entry.
1385 This function works by marking up items of the same list level
1386 and type, respecting the end-of-list property."
1387   (let* ((str (match-string 1))
1388          (type (muse-list-item-type str))
1389          (indent (buffer-substring (muse-line-beginning-position)
1390                                    (match-beginning 1)))
1391          (post-indent (length str)))
1392     (cond
1393      ((or (get-text-property (muse-list-item-critical-point) 'read-only)
1394           (get-text-property (muse-list-item-critical-point) 'muse-link))
1395       nil)
1396      ((eq type 'ul)
1397       (unless (eq (char-after (match-end 1)) ?-)
1398         (delete-region (match-beginning 0) (match-end 0))
1399         (muse-publish-ensure-blank-line)
1400         (muse-insert-markup (muse-markup-text 'begin-uli))
1401         (save-excursion
1402           (muse-publish-surround-text
1403            (muse-markup-text 'begin-uli-item)
1404            (muse-markup-text 'end-uli-item)
1405            (lambda (indent)
1406              (muse-forward-list-item 'ul indent))
1407            indent post-indent)
1408           (muse-insert-markup-end-list (muse-markup-text 'end-uli)))
1409         (forward-line 1)))
1410      ((eq type 'ol)
1411       (delete-region (match-beginning 0) (match-end 0))
1412       (muse-publish-ensure-blank-line)
1413       (muse-insert-markup (muse-markup-text 'begin-oli))
1414       (save-excursion
1415         (muse-publish-surround-text
1416          (muse-markup-text 'begin-oli-item)
1417          (muse-markup-text 'end-oli-item)
1418          (lambda (indent)
1419            (muse-forward-list-item 'ol indent))
1420          indent post-indent)
1421         (muse-insert-markup-end-list (muse-markup-text 'end-oli)))
1422       (forward-line 1))
1423      (t
1424       (goto-char (match-beginning 0))
1425       (muse-publish-ensure-blank-line)
1426       (muse-insert-markup (muse-markup-text 'begin-dl))
1427       (save-excursion
1428         (muse-publish-surround-dl indent post-indent)
1429         (muse-insert-markup-end-list (muse-markup-text 'end-dl)))
1430       (forward-line 1))))
1431   nil)
1432
1433 (defun muse-publish-markup-quote ()
1434   "Markup a quoted paragraph.
1435 The reason this function is so funky, is to prevent text properties
1436 like read-only from being inadvertently deleted."
1437   (let* ((ws (match-string 1))
1438          (centered (>= (string-width ws) 6))
1439          (begin-elem (if centered 'begin-center 'begin-quote-item))
1440          (end-elem (if centered 'end-center 'end-quote-item)))
1441     (replace-match "" t t nil 1)
1442     (unless centered
1443       (muse-insert-markup (muse-markup-text 'begin-quote)))
1444     (muse-publish-surround-text (muse-markup-text begin-elem)
1445                                 (muse-markup-text end-elem)
1446                                 (function (lambda (indent)
1447                                             (muse-forward-paragraph)
1448                                             nil)))
1449     (unless centered
1450       (muse-insert-markup (muse-markup-text 'end-quote)))))
1451
1452 (defun muse-publish-markup-leading-space (markup-space multiple)
1453   (let (count)
1454     (when (and markup-space
1455                (>= (setq count (skip-chars-forward " ")) 0))
1456       (delete-region (muse-line-beginning-position) (point))
1457       (while (> count 0)
1458         (muse-insert-markup markup-space)
1459         (setq count (- count multiple))))))
1460
1461 (defun muse-publish-markup-verse ()
1462   (let ((leader (match-string 0)))
1463     (goto-char (match-beginning 0))
1464     (muse-insert-markup (muse-markup-text 'begin-verse))
1465     (while (looking-at leader)
1466       (replace-match "")
1467       (muse-publish-markup-leading-space (muse-markup-text 'verse-space) 2)
1468       (let ((beg (point)))
1469         (end-of-line)
1470         (cond
1471          ((bolp)
1472           (let ((text (muse-markup-text 'empty-verse-line)))
1473             (when text (muse-insert-markup text))))
1474          ((save-excursion
1475             (save-match-data
1476               (forward-line 1)
1477               (or (looking-at (concat leader "["
1478                                       muse-regexp-blank
1479                                       "]*$"))
1480                   (not (looking-at leader)))))
1481           (let ((begin-text (muse-markup-text 'begin-last-stanza-line))
1482                 (end-text (muse-markup-text 'end-last-stanza-line)))
1483             (when end-text (muse-insert-markup end-text))
1484             (goto-char beg)
1485             (when begin-text (muse-insert-markup begin-text))
1486             (end-of-line)))
1487          (t
1488           (let ((begin-text (muse-markup-text 'begin-verse-line))
1489                 (end-text (muse-markup-text 'end-verse-line)))
1490             (when end-text (muse-insert-markup end-text))
1491             (goto-char beg)
1492             (when begin-text (muse-insert-markup begin-text))
1493             (end-of-line))))
1494         (forward-line 1))))
1495   (muse-insert-markup (muse-markup-text 'end-verse))
1496   (insert ?\n))
1497
1498 (defun muse-publish-trim-table (table)
1499   "Remove completely blank columns from table, if at start or end of row."
1500   ;; remove first
1501   (catch 'found
1502     (dolist (row (cdr table))
1503       (let ((el (cadr row)))
1504         (when (and (stringp el) (not (string= el "")))
1505           (throw 'found t))))
1506     (dolist (row (cdr table))
1507       (setcdr row (cddr row)))
1508     (setcar table (1- (car table))))
1509   ;; remove last
1510   (catch 'found
1511     (dolist (row (cdr table))
1512       (let ((el (car (last row))))
1513         (when (and (stringp el) (not (string= el "")))
1514           (throw 'found t))))
1515     (dolist (row (cdr table))
1516       (setcdr (last row 2) nil))
1517     (setcar table (1- (car table))))
1518   table)
1519
1520 (defun muse-publish-table-fields (beg end)
1521   "Parse given region as a table, returning a cons cell.
1522 The car is the length of the longest row.
1523
1524 The cdr is a list of the fields of the table, with the first
1525 element indicating the type of the row:
1526   1: body, 2: header, 3: footer, hline: separator.
1527
1528 The existing region will be removed, except for initial blank lines."
1529   (unless (muse-publishing-directive "disable-tables")
1530     (let ((longest 0)
1531           (left 0)
1532           (seen-hline nil)
1533           fields field-list)
1534       (save-restriction
1535         (narrow-to-region beg end)
1536         (goto-char (point-min))
1537         (while (looking-at (concat "^[" muse-regexp-blank "]*$"))
1538           (forward-line 1))
1539         (setq beg (point))
1540         (while (= left 0)
1541           (cond
1542            ((looking-at muse-table-hline-regexp)
1543             (when field-list  ; skip if at the beginning of table
1544               (if seen-hline
1545                   (setq field-list (cons (cons 'hline nil) field-list))
1546                 (dolist (field field-list)
1547                   ;; the preceding fields are header lines
1548                   (setcar field 2))
1549                 (setq seen-hline t))))
1550            ((looking-at muse-table-line-regexp)
1551             (setq fields (cons (length (match-string 1))
1552                                (mapcar #'muse-trim-whitespace
1553                                        (split-string (match-string 0)
1554                                                      muse-table-field-regexp)))
1555                   field-list (cons fields field-list)
1556                   longest (max (length fields) longest))
1557             ;; strip initial bars, if they exist
1558             (let ((first (cadr fields)))
1559               (when (and first (string-match "\\`|+\\s-*" first))
1560                 (setcar (cdr fields) (replace-match "" t t first))))))
1561           (setq left (forward-line 1))))
1562       (delete-region beg end)
1563       (if (= longest 0)
1564           (cons 0 nil)
1565         ;; if the last line was an hline, remove it
1566         (when (eq (caar field-list) 'hline)
1567           (setq field-list (cdr field-list)))
1568         (muse-publish-trim-table (cons (1- longest) (nreverse field-list)))))))
1569
1570 (defun muse-publish-markup-table ()
1571   "Style does not support tables.\n")
1572
1573 (defun muse-publish-table-el-table (variant)
1574   "Publish table.el-style tables in the format given by VARIANT."
1575   (when (condition-case nil
1576             (progn (require 'table)
1577                    t)
1578           (error nil))
1579     (let ((muse-buf (current-buffer)))
1580       (save-restriction
1581         (narrow-to-region (match-beginning 0) (match-end 0))
1582         (goto-char (point-min))
1583         (forward-line 1)
1584         (when (search-forward "|" nil t)
1585           (with-temp-buffer
1586             (let ((temp-buf (current-buffer)))
1587               (with-current-buffer muse-buf
1588                 (table-generate-source variant temp-buf))
1589               (with-current-buffer muse-buf
1590                 (delete-region (point-min) (point-max))
1591                 (insert-buffer-substring temp-buf)
1592                 (muse-publish-mark-read-only (point-min) (point-max))))))))))
1593
1594 (defun muse-publish-markup-table-el ()
1595   "Mark up table.el-style tables."
1596   (cond ((muse-style-derived-p 'html)
1597          (muse-publish-table-el-table 'html))
1598         ((muse-style-derived-p 'latex)
1599          (muse-publish-table-el-table 'latex))
1600         ((muse-style-derived-p 'docbook)
1601          (muse-publish-table-el-table 'cals))
1602         (t "Style does not support table.el tables.\n")))
1603
1604 (defun muse-publish-escape-specials-in-string (string &optional context)
1605   "Escape specials in STRING using style-specific :specials.
1606 CONTEXT is used to figure out what kind of specials to escape.
1607
1608 See the documentation of the `muse-publish-escape-specials'
1609 function for the list of available contexts."
1610   (unless string
1611     (setq string ""))
1612   (let ((specials (muse-style-element :specials nil t)))
1613     (cond ((functionp specials)
1614            (setq specials (funcall specials context)))
1615           ((symbolp specials)
1616            (setq specials (symbol-value specials))))
1617     (if (functionp specials)
1618         (funcall specials string)
1619       (apply (function concat)
1620              (mapcar
1621               (lambda (ch)
1622                 (let ((repl (or (assoc ch specials)
1623                                 (assoc ch muse-publish-markup-specials))))
1624                   (if (null repl)
1625                       (char-to-string ch)
1626                     (cdr repl))))
1627               (append string nil))))))
1628
1629 (defun muse-publish-markup-email ()
1630   (let* ((beg (match-end 1))
1631          (addr (buffer-substring-no-properties beg (match-end 0))))
1632     (setq addr (muse-publish-escape-specials-in-string addr 'email))
1633     (goto-char beg)
1634     (delete-region beg (match-end 0))
1635     (if (or (eq (char-before (match-beginning 0)) ?\")
1636             (eq (char-after (match-end 0)) ?\"))
1637         (insert addr)
1638       (insert (format (muse-markup-text 'email-addr) addr addr)))
1639     (muse-publish-mark-read-only beg (point))))
1640
1641 (defun muse-publish-classify-url (target)
1642   "Transform anchors and get published name, if TARGET is a page.
1643 The return value is two linked cons cells.  The car is the type
1644 of link, the cadr is the page name, and the cddr is the anchor."
1645   (save-match-data
1646     (cond ((or (null target) (string= target ""))
1647            nil)
1648           ((string-match "\\`[uU][rR][lL]:\\(.+\\)\\'" target)
1649            (cons 'url (cons (match-string 1 target) nil)))
1650           ((string-match muse-image-regexp target)
1651            (cons 'image (cons target nil)))
1652           ((string-match muse-url-regexp target)
1653            (cons 'url (cons target nil)))
1654           ((string-match muse-file-regexp target)
1655            (cons 'file (cons target nil)))
1656           ((string-match "#" target)
1657            (if (eq (aref target 0) ?\#)
1658               (cons 'anchor-ref (cons nil (substring target 1)))
1659              (cons 'link-and-anchor
1660                    ;; match-data is changed by
1661                    ;; `muse-publish-link-page' or descendants.
1662                    (cons (save-match-data
1663                            (muse-publish-link-page
1664                             (substring target 0 (match-beginning 0))))
1665                          (substring target (match-end 0))))))
1666           (t
1667            (cons 'link (cons (muse-publish-link-page target) nil))))))
1668
1669 (defun muse-publish-url-desc (desc explicit)
1670   (when desc
1671     (dolist (transform muse-publish-desc-transforms)
1672       (setq desc (save-match-data
1673                    (when desc (funcall transform desc explicit)))))
1674     (setq desc (muse-link-unescape desc))
1675     (muse-publish-escape-specials-in-string desc 'url-desc)))
1676
1677 (defun muse-publish-url (url &optional desc orig-url explicit)
1678   "Resolve a URL into its final <a href> form."
1679   (let ((unesc-url url)
1680         (unesc-orig-url orig-url)
1681         (unesc-desc desc)
1682         type anchor)
1683     ;; Transform URL
1684     (dolist (transform muse-publish-url-transforms)
1685       (setq url (save-match-data (when url (funcall transform url explicit)))))
1686     ;; Classify URL
1687     (let ((target (muse-publish-classify-url url)))
1688       (setq type (car target)
1689             url (if (eq type 'image)
1690                     (muse-publish-escape-specials-in-string (cadr target)
1691                                                             'image)
1692                   (muse-publish-escape-specials-in-string (cadr target) 'url))
1693             anchor (muse-publish-escape-specials-in-string
1694                     (cddr target) 'url)))
1695     ;; Transform description
1696     (if desc
1697         (setq desc (muse-publish-url-desc desc explicit))
1698       (when orig-url
1699         (setq orig-url (muse-publish-url-desc orig-url explicit))))
1700     ;; Act on URL classification
1701     (cond ((eq type 'anchor-ref)
1702            (muse-markup-text 'anchor-ref anchor (or desc orig-url)))
1703           ((and unesc-desc (string-match muse-image-regexp unesc-desc))
1704            (let ((ext (or (file-name-extension desc) "")))
1705              (setq desc (muse-publish-escape-specials-in-string unesc-desc
1706                                                                 'image))
1707              (setq desc (muse-path-sans-extension desc))
1708              (muse-markup-text 'image-link url desc ext)))
1709           ((string= url "")
1710            desc)
1711           ((eq type 'image)
1712            (let ((ext (or (file-name-extension url) "")))
1713              (setq url (muse-path-sans-extension url))
1714              (if desc
1715                  (muse-markup-text 'image-with-desc url ext desc)
1716                (muse-markup-text 'image url ext))))
1717           ((eq type 'link-and-anchor)
1718            (muse-markup-text 'link-and-anchor url anchor
1719                              (or desc orig-url)
1720                              (muse-path-sans-extension url)))
1721           ((eq type 'link)
1722            (muse-markup-text 'link url (or desc orig-url)))
1723           (t
1724            (or (and (or desc
1725                         ;; compare the not-escaped versions of url and
1726                         ;; orig-url
1727                         (not (string= unesc-url unesc-orig-url)))
1728                     (let ((text (muse-markup-text 'url-and-desc url
1729                                                   (or desc orig-url))))
1730                       (and (not (string= text ""))
1731                            text)))
1732                (muse-markup-text 'url url (or desc orig-url)))))))
1733
1734 (defun muse-publish-insert-url (url &optional desc orig-url explicit)
1735   "Resolve a URL into its final <a href> form."
1736   (delete-region (match-beginning 0) (match-end 0))
1737   (let ((text (muse-publish-url url desc orig-url explicit)))
1738     (when text
1739       (muse-insert-markup text))))
1740
1741 (defun muse-publish-markup-link ()
1742   (let (desc explicit orig-link link)
1743     (setq explicit (save-match-data
1744                      (if (string-match muse-explicit-link-regexp
1745                                        (match-string 0))
1746                          t nil)))
1747     (setq orig-link (if explicit (match-string 1) (match-string 0)))
1748     (setq desc (when explicit (match-string 2)))
1749     (setq link (if explicit
1750                    (muse-handle-explicit-link orig-link)
1751                  (muse-handle-implicit-link orig-link)))
1752     (when (and link
1753                (or explicit
1754                    (not (or (eq (char-before (match-beginning 0)) ?\")
1755                             (eq (char-after (match-end 0)) ?\")))))
1756       ;; if explicit link has no user-provided description, treat it
1757       ;; as if it were an implicit link
1758       (when (and explicit (not desc))
1759         (setq explicit nil))
1760       (muse-publish-insert-url link desc orig-link explicit))))
1761
1762 (defun muse-publish-markup-url ()
1763   (unless (or (eq (char-before (match-beginning 0)) ?\")
1764               (eq (char-after (match-end 0)) ?\"))
1765     (let ((url (match-string 0)))
1766       (muse-publish-insert-url url nil url))))
1767
1768 ;; Default publishing tags
1769
1770 (defcustom muse-publish-contents-depth 2
1771   "The number of heading levels to include with <contents> tags."
1772   :type 'integer
1773   :group 'muse-publish)
1774
1775 (defun muse-publish-contents-tag (beg end attrs)
1776   (set (make-local-variable 'muse-publish-generate-contents)
1777        (cons (copy-marker (point) t)
1778              (let ((depth (cdr (assoc "depth" attrs))))
1779                (or (and depth (string-to-number depth))
1780                    muse-publish-contents-depth)))))
1781
1782 (defun muse-publish-verse-tag (beg end)
1783   (muse-publish-ensure-block beg end)
1784   (save-excursion
1785     (save-restriction
1786       (narrow-to-region beg end)
1787       (goto-char (point-min))
1788       (delete-char 1)
1789       (while (< (point) (point-max))
1790         (insert "> ")
1791         (forward-line))
1792       (if (eq ?\  (char-syntax (char-before)))
1793           (delete-char -1)))))
1794
1795 (defun muse-publish-mark-read-only (beg end)
1796   "Add read-only properties to the given region."
1797   (add-text-properties beg end '(rear-nonsticky (read-only) read-only t))
1798   nil)
1799
1800 (defun muse-publish-mark-link (&optional beg end)
1801   "Indicate that the given region is a Muse link, so that other
1802 markup elements respect it.  If a region is not specified, use
1803 the 0th match data to determine it.
1804
1805 This is usually applied to explicit links."
1806   (unless beg (setq beg (match-beginning 0)))
1807   (unless end (setq end (match-end 0)))
1808   (add-text-properties beg end '(muse-link t))
1809   nil)
1810
1811 (defun muse-publish-quote-tag (beg end)
1812   (muse-publish-ensure-block beg)
1813   (save-excursion
1814     (save-restriction
1815       (narrow-to-region beg end)
1816       (let ((quote-regexp "^\\(<\\(/?\\)quote>\\)"))
1817         (muse-insert-markup (muse-markup-text 'begin-quote))
1818         (while (progn
1819                  (unless (looking-at (concat "[" muse-regexp-blank "\n]*"
1820                                              "<quote>"))
1821                    (muse-publish-surround-text
1822                     (muse-markup-text 'begin-quote-item)
1823                     (muse-markup-text 'end-quote-item)
1824                     (function
1825                      (lambda (indent)
1826                        (muse-forward-paragraph)
1827                        (goto-char (match-end 0))
1828                        (and (< (point) (point-max))
1829                             (not (looking-at quote-regexp)))))
1830                     nil nil nil
1831                     quote-regexp))
1832                  (if (>= (point) (point-max))
1833                      t
1834                    (and (search-forward "<quote>" nil t)
1835                         (muse-goto-tag-end "quote" t)
1836                         (progn (forward-line 1) t)
1837                         (< (point) (point-max))))))
1838         (goto-char (point-max))
1839         (muse-insert-markup (muse-markup-text 'end-quote))))))
1840
1841 (defun muse-publish-code-tag (beg end)
1842   (muse-publish-escape-specials beg end nil 'literal)
1843   (goto-char beg)
1844   (insert (muse-markup-text 'begin-literal))
1845   (goto-char end)
1846   (insert (muse-markup-text 'end-literal))
1847   (muse-publish-mark-read-only beg (point)))
1848
1849 (defun muse-publish-cite-tag (beg end attrs)
1850   (let* ((type (muse-publish-get-and-delete-attr "type" attrs))
1851          (citetag (cond ((string-equal type "author")
1852                          'begin-cite-author)
1853                         ((string-equal type "year")
1854                          'begin-cite-year)
1855                         (t
1856                          'begin-cite))))
1857     (goto-char beg)
1858     (insert (muse-markup-text citetag (muse-publishing-directive "bibsource")))
1859     (goto-char end)
1860     (insert (muse-markup-text 'end-cite))
1861     (muse-publish-mark-read-only beg (point))))
1862
1863 (defun muse-publish-src-tag (beg end attrs)
1864   (muse-publish-example-tag beg end))
1865
1866 (defun muse-publish-example-tag (beg end)
1867   (muse-publish-ensure-block beg end)
1868   (muse-publish-escape-specials beg end nil 'example)
1869   (goto-char beg)
1870   (insert (muse-markup-text 'begin-example))
1871   (goto-char end)
1872   (insert (muse-markup-text 'end-example))
1873   (muse-publish-mark-read-only beg (point)))
1874
1875 (defun muse-publish-literal-tag (beg end attrs)
1876   "Ensure that the text between BEG and END is not interpreted later on.
1877
1878 ATTRS is an alist of attributes.
1879
1880 If it contains a \"style\" element, delete the region if the
1881 current style is neither derived from nor equal to this style.
1882
1883 If it contains both a \"style\" element and an \"exact\" element
1884 with the value \"t\", delete the region only if the current style
1885 is exactly this style."
1886   (let* ((style (cdr (assoc "style" attrs)))
1887          (exact (cdr (assoc "exact" attrs)))
1888          (exactp (and (stringp exact) (string= exact "t"))))
1889     (if (or (not style)
1890             (and exactp (equal (muse-style style)
1891                                muse-publishing-current-style))
1892             (and (not exactp) (muse-style-derived-p style)))
1893         (muse-publish-mark-read-only beg end)
1894       (delete-region beg end)
1895       (when (and (bolp) (eolp) (not (eobp)))
1896         (delete-char 1)))))
1897
1898 (put 'muse-publish-literal-tag 'muse-dangerous-tag t)
1899
1900 (defun muse-publish-verbatim-tag (beg end)
1901   (muse-publish-escape-specials beg end nil 'verbatim)
1902   (muse-publish-mark-read-only beg end))
1903
1904 (defun muse-publish-br-tag (beg end)
1905   "Insert a line break."
1906   (delete-region beg end)
1907   (muse-insert-markup (muse-markup-text 'line-break)))
1908
1909 (defalias 'muse-publish-class-tag 'ignore)
1910
1911 (defun muse-publish-call-tag-on-buffer (tag &optional attrs)
1912   "Transform the current buffer as if it were surrounded by the tag TAG.
1913 If attributes ATTRS are given, pass them to the tag function."
1914   (let ((tag-info (muse-markup-tag-info tag)))
1915     (when tag-info
1916       (let* ((end (progn (goto-char (point-max)) (point-marker)))
1917              (args (list (point-min) end))
1918              (muse-inhibit-style-tags nil))
1919         (when (nth 2 tag-info)
1920           (nconc args (list attrs)))
1921         (apply (nth 4 tag-info) args)
1922         (set-marker end nil)))))
1923
1924 (defun muse-publish-examplify-buffer (&optional attrs)
1925   "Transform the current buffer as if it were an <example> region."
1926   (muse-publish-call-tag-on-buffer "example" attrs))
1927
1928 (defun muse-publish-srcify-buffer (&optional attrs)
1929   "Transform the current buffer as if it were a <src> region."
1930   (muse-publish-call-tag-on-buffer "src" attrs))
1931
1932 (defun muse-publish-versify-buffer (&optional attrs)
1933   "Transform the current buffer as if it were a <verse> region."
1934   (muse-publish-call-tag-on-buffer "verse" attrs)
1935   (muse-publish-markup ""
1936                        `((100 ,(concat "^[" muse-regexp-blank "]*> ") 0
1937                               muse-publish-markup-verse)))
1938   (goto-char (point-min)))
1939
1940 (defmacro muse-publish-markup-attribute (beg end attrs reinterp &rest body)
1941   "Evaluate BODY within the bounds of BEG and END.
1942 ATTRS is an alist.  Only the \"markup\" element of ATTRS is acted
1943 on.
1944
1945 If it is omitted, publish the region with the normal Muse rules.
1946 If RE-INTERP is specified, this is done immediately in a new
1947 publishing process.  Currently, RE-INTERP is specified only by
1948 the <include> tag.
1949
1950 If \"nil\", do not mark up the region at all, but prevent it from
1951 being further interpreted by Muse.
1952
1953 If \"example\", treat the region as if it was surrounded by the
1954 <example> tag.
1955
1956 If \"src\", treat the region as if it was surrounded by the
1957 <src> tag.
1958
1959 If \"verse\", treat the region as if it was surrounded by the
1960 <verse> tag, to preserve newlines.
1961
1962 Otherwise, it should be the name of a function to call in the
1963 narrowed region after evaluating BODY.  The function should
1964 take the ATTRS parameter.
1965
1966 BEG is modified to be the start of the published markup."
1967   (let ((attrs-sym (make-symbol "attrs"))
1968         (markup (make-symbol "markup"))
1969         (markup-function (make-symbol "markup-function")))
1970     `(let* ((,attrs-sym ,attrs)
1971             (,markup (muse-publish-get-and-delete-attr "markup" ,attrs-sym)))
1972        (save-restriction
1973          (narrow-to-region ,beg ,end)
1974          (goto-char (point-min))
1975          ,@body
1976          (if (not ,markup)
1977              (when ,reinterp
1978                (muse-publish-markup-region (point-min) (point-max))
1979                (muse-publish-mark-read-only (point-min) (point-max))
1980                (goto-char (point-max)))
1981            (let ((,markup-function (read ,markup)))
1982              (cond ((eq ,markup-function 'example)
1983                     (setq ,markup-function #'muse-publish-examplify-buffer))
1984                    ((eq ,markup-function 'src)
1985                     (setq ,markup-function #'muse-publish-srcify-buffer))
1986                    ((eq ,markup-function 'verse)
1987                     (setq ,markup-function #'muse-publish-versify-buffer))
1988                    ((and ,markup-function (not (functionp ,markup-function)))
1989                     (error "Invalid markup function `%s'" ,markup))
1990                    (t nil))
1991              (if ,markup-function
1992                  (funcall ,markup-function ,attrs-sym)
1993                (muse-publish-mark-read-only (point-min) (point-max))
1994                (goto-char (point-max)))))))))
1995
1996 (put 'muse-publish-markup-attribute 'lisp-indent-function 4)
1997 (put 'muse-publish-markup-attribute 'edebug-form-spec
1998      '(sexp sexp sexp sexp body))
1999
2000 (defun muse-publish-lisp-tag (beg end attrs)
2001   (muse-publish-markup-attribute beg end attrs nil
2002     (save-excursion
2003       (save-restriction
2004         (let ((str (muse-eval-lisp
2005                     (prog1
2006                         (concat "(progn "
2007                                 (buffer-substring-no-properties (point-min)
2008                                                                 (point-max))
2009                                 ")")
2010                       (delete-region (point-min) (point-max))
2011                       (widen)))))
2012           (set-text-properties 0 (length str) nil str)
2013           (insert str))))))
2014
2015 (put 'muse-publish-lisp-tag 'muse-dangerous-tag t)
2016
2017 (defun muse-publish-command-tag (beg end attrs)
2018   (muse-publish-markup-attribute beg end attrs nil
2019     (while (looking-at "\\s-*$")
2020       (forward-line))
2021     (let ((interp (muse-publish-get-and-delete-attr "interp" attrs)))
2022       (if interp
2023           (shell-command-on-region (point) (point-max) interp t t)
2024         (shell-command
2025          (prog1
2026              (buffer-substring-no-properties (point) (point-max))
2027            (delete-region (point-min) (point-max)))
2028          t)))
2029     ;; make sure there is a newline at end
2030     (goto-char (point-max))
2031     (forward-line 0)
2032     (unless (looking-at "\\s-*$")
2033       (goto-char (point-max))
2034       (insert ?\n))
2035     (goto-char (point-min))))
2036
2037 (put 'muse-publish-command-tag 'muse-dangerous-tag t)
2038
2039 (defun muse-publish-perl-tag (beg end attrs)
2040   (muse-publish-command-tag beg end
2041                             (cons (cons "interp" (executable-find "perl"))
2042                                   attrs)))
2043
2044 (put 'muse-publish-perl-tag 'muse-dangerous-tag t)
2045
2046 (defun muse-publish-php-tag (beg end attrs)
2047   (muse-publish-command-tag beg end
2048                             (cons (cons "interp" (executable-find "php"))
2049                                   attrs)))
2050
2051 (put 'muse-publish-php-tag 'muse-dangerous-tag t)
2052
2053 (defun muse-publish-python-tag (beg end attrs)
2054   (muse-publish-command-tag beg end
2055                             (cons (cons "interp" (executable-find "python"))
2056                                   attrs)))
2057
2058 (put 'muse-publish-python-tag 'muse-dangerous-tag t)
2059
2060 (defun muse-publish-ruby-tag (beg end attrs)
2061   (muse-publish-command-tag beg end
2062                             (cons (cons "interp" (executable-find "ruby"))
2063                                   attrs)))
2064
2065 (put 'muse-publish-ruby-tag 'muse-dangerous-tag t)
2066
2067 (defun muse-publish-comment-tag (beg end)
2068   (if (null muse-publish-comments-p)
2069       (delete-region beg end)
2070     (goto-char end)
2071     (muse-insert-markup (muse-markup-text 'comment-end))
2072     (muse-publish-mark-read-only beg end)
2073     (goto-char beg)
2074     (muse-insert-markup (muse-markup-text 'comment-begin))))
2075
2076 (defun muse-publish-include-tag (beg end attrs)
2077   "Include the named file at the current location during publishing.
2078
2079 <include file=\"...\" markup=\"...\">
2080
2081 The `markup' attribute controls how this file is marked up after
2082 being inserted.  See `muse-publish-markup-attribute' for an
2083 explanation of how it works."
2084   (let ((filename (muse-publish-get-and-delete-attr "file" attrs))
2085         (muse-publishing-directives (copy-alist muse-publishing-directives)))
2086     (if filename
2087         (setq filename (expand-file-name
2088                         filename
2089                         (file-name-directory muse-publishing-current-file)))
2090       (error "No file attribute specified in <include> tag"))
2091     (muse-publish-markup-attribute beg end attrs t
2092       (muse-insert-file-contents filename))))
2093
2094 (put 'muse-publish-include-tag 'muse-dangerous-tag t)
2095
2096 (defun muse-publish-mark-up-tag (beg end attrs)
2097   "Run an Emacs Lisp function on the region delimted by this tag.
2098
2099 <markup function=\"...\" style=\"...\" exact=\"...\">
2100
2101 The optional \"function\" attribute controls how this section is
2102 marked up.  If used, it should be the name of a function to call
2103 with the buffer narrowed to the delimited region.  Note that no
2104 further marking-up will be performed on this region.
2105
2106 If \"function\" is omitted, use the standard Muse markup function.
2107 This is useful for marking up content in headers and footers.
2108
2109 The optional \"style\" attribute causes the region to be deleted
2110 if the current style is neither derived from nor equal to this
2111 style.
2112
2113 If both a \"style\" attribute and an \"exact\" attribute are
2114 provided, and \"exact\" is \"t\", delete the region only if the
2115 current style is exactly this style."
2116   (let* ((style (cdr (assoc "style" attrs)))
2117          (exact (cdr (assoc "exact" attrs)))
2118          (exactp (and (stringp exact) (string= exact "t"))))
2119     (if (or (not style)
2120             (and exactp (equal (muse-style style)
2121                                muse-publishing-current-style))
2122             (and (not exactp) (muse-style-derived-p style)))
2123         (let* ((function (cdr (assoc "function" attrs)))
2124                (muse-publish-use-header-footer-tags nil)
2125                (markup-function (and function (intern-soft function))))
2126           (if (and markup-function (functionp markup-function))
2127               (save-restriction
2128                 (narrow-to-region beg end)
2129                 (funcall markup-function)
2130                 (goto-char (point-max)))
2131             (let ((muse-publish-inhibit-style-hooks t))
2132               (muse-publish-markup-region beg end)))
2133           (muse-publish-mark-read-only beg (point)))
2134       (delete-region beg end))))
2135
2136 (put 'muse-publish-mark-up-tag 'muse-dangerous-tag t)
2137
2138 ;; Miscellaneous helper functions
2139
2140 (defun muse-publish-strip-URL (string &rest ignored)
2141   "If the text \"URL:\" exists at the beginning of STRING, remove it.
2142 The text is removed regardless of whether and part of it is uppercase."
2143   (save-match-data
2144     (if (string-match "\\`[uU][rR][lL]:\\(.+\\)\\'" string)
2145         (match-string 1 string)
2146       string)))
2147
2148 (defun muse-publish-markup-type (category default-func)
2149   (let ((rule (muse-find-markup-element :overrides category (muse-style))))
2150     (funcall (or rule default-func))))
2151
2152 (defun muse-published-buffer-contents (buffer)
2153   (with-current-buffer buffer
2154     (goto-char (point-min))
2155     (let ((beg (and (search-forward "Emacs Muse begins here")
2156                     (muse-line-end-position)))
2157           (end (and (search-forward "Emacs Muse ends here")
2158                     (muse-line-beginning-position))))
2159       (buffer-substring-no-properties beg end))))
2160
2161 (defun muse-published-contents (file)
2162   (when (file-readable-p file)
2163     (muse-with-temp-buffer
2164       (muse-insert-file-contents file)
2165       (muse-published-buffer-contents (current-buffer)))))
2166
2167 (defun muse-publish-transform-output
2168   (file temp-file output-path name gen-func &rest cleanup-exts)
2169   "Transform the given TEMP-FILE into the OUTPUT-PATH, using GEN-FUNC."
2170   (setq file (muse-page-name file))
2171   (message "Generating %s output for %s..." name file)
2172   (if (not (funcall gen-func temp-file output-path))
2173       (message "Generating %s from %s...failed" name file)
2174     (message "Generating %s output for %s...done" name file)
2175     (muse-delete-file-if-exists temp-file)
2176     (dolist (ext cleanup-exts)
2177       (muse-delete-file-if-exists
2178        (expand-file-name (concat file ext)
2179                          (file-name-directory output-path))))
2180     (message "Wrote %s" output-path)))
2181
2182 (defun muse-publish-read-only (string)
2183   (let ((end (1- (length string))))
2184     (add-text-properties 0 end
2185                          '(rear-nonsticky (read-only) read-only t)
2186                          string)
2187     string))
2188
2189 ;;; muse-publish.el ends here