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