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