muse-publish.el

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