lisp/muse-publish.el

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