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