lisp/muse-publish.el

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