muse-html.el

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;
   3 ;; Muse HTML Publishing
   4 ;;
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6
   7 (require 'muse-publish)
   8 (require 'muse-regexps)
   9
  10 (defgroup muse-html nil
  11   "Options controlling the behaviour of Muse HTML publishing.
  12 See `muse-html' for more information."
  13   :group 'muse-publish)
  14
  15 (defcustom muse-html-extension ".html"
  16   "Default file extension for publishing HTML files."
  17   :type 'string
  18   :group 'muse-html)
  19
  20 (defcustom muse-html-style-sheet
  21   "body {
  22   background: white; color: black;
  23   margin-left: 3%; margin-right: 7%;
  24 }
  25
  26 p { margin-top: 1% }
  27 p.verse { margin-left: 3% }
  28
  29 .example { margin-left: 3% }
  30
  31 h2 {
  32   margin-top: 25px;
  33   margin-bottom: 0px;
  34 }
  35 h3 { margin-bottom: 0px; }"
  36   "Text to prepend to a Muse mail message being published.
  37 This text may contain <lisp> markup tags."
  38   :type 'string
  39   :group 'muse-html)
  40
  41 (defcustom muse-html-header
  42   "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0//EN\">
  43 <html>
  44   <head>
  45     <title><lisp>
  46   (concat (muse-publishing-directive \"title\")
  47           (let ((author (muse-publishing-directive \"author\")))
  48             (if (not (string= author (user-full-name)))
  49                 (concat \" (by \" author \")\"))))</lisp></title>
  50     <meta name=\"generator\" content=\"muse.el\">
  51     <meta http-equiv=\"<lisp>muse-html-meta-http-equiv</lisp>\"
  52           content=\"<lisp>muse-html-meta-content-type</lisp>\">
  53     <lisp>
  54       (let ((maintainer (muse-style-element :maintainer)))
  55         (when maintainer
  56           (concat \"<link rev=\\\"made\\\" href=\\\"\" maintainer \"\\\">\")))
  57     </lisp>
  58     <style type=\"text/css\">
  59       <lisp>muse-html-style-sheet</lisp>
  60     </style>
  61   </head>
  62   <body>
  63     <h1><lisp>
  64   (concat (muse-publishing-directive \"title\")
  65           (let ((author (muse-publishing-directive \"author\")))
  66             (if (not (string= author (user-full-name)))
  67                 (concat \" (by \" author \")\"))))</lisp></h1>
  68     <!-- Page published by Emacs Muse begins here -->\n"
  69   "Header used for publishing HTML files."
  70   :type '(choice string file)
  71   :group 'muse-html)
  72
  73 (defcustom muse-html-footer "
  74 <!-- Page published by Emacs Muse ends here -->
  75   </body>
  76 </html>\n"
  77   "Footer used for publishing HTML files."
  78   :type '(choice string file)
  79   :group 'muse-html)
  80
  81 (defcustom muse-html-anchor-on-word nil
  82   "When true, anchors surround the closest word. This allows you
  83 to select them in a browser (ie, for pasting), but has the
  84 side-effect of marking up headers in multiple colours if your
  85 header style is different from your link style."
  86   :type 'boolean
  87   :group 'muse-html)
  88
  89 (defcustom muse-html-table-attributes
  90   "class=\"muse-table\" border=\"2\" cellpadding=\"5\""
  91   "The attribute to be used with HTML <table> tags.
  92 Note that since Muse supports direct insertion of HTML tags, you
  93 can easily create any kind of table you want, as long as each
  94 line begins at column 0 (to prevent it from being blockquote'd).
  95 To make such a table, use this idiom:
  96
  97   <verbatim>
  98   <table>
  99     [... contents of my table, in raw HTML ...]
 100   </verbatim></table>
 101
 102 It may look strange to have the tags out of sequence, but this is
 103 because the Muse verbatim tag is handled during a different pass
 104 than the HTML table tag."
 105   :type 'string
 106   :group 'muse-html)
 107
 108 (defcustom muse-html-markup-regexps
 109   `(;; join together the parts of a list or table
 110     (10000 "</\\([oud]l\\)>\\s-*<\\1>\\s-*" 0 "")
 111     (10100 ,(concat "  </t\\(body\\|head\\|foot\\)>\\s-*</table>\\s-*"
 112                     "<table[^>]*>\\s-*<t\\1>\n") 0 "")
 113     (10200 "</table>\\s-*<table[^>]*>\n" 0 "")
 114
 115     ;; the beginning of the buffer begins the first paragraph
 116     (10300 "\\`\n*\\([^<-]\\|<\\(em\\|strong\\|code\\)>\\|<a \\)" 0
 117            "<p class=\"first\">\\1")
 118     ;; plain paragraph separator
 119     (10400 ,(concat "\\(\n</\\(blockquote\\|center\\)>\\)?\n"
 120                     "\\(["
 121                     muse-regexp-blank
 122                     "]*\n\\)+\\(<\\(blockquote\\|center\\)>\n\\)?")
 123            0 muse-html-markup-paragraph)
 124     (10500 ,(concat "\\([^>"
 125                     muse-regexp-space
 126                     "]\\)\\s-*\\'")
 127            0 "\\1</p>\n"))
 128   "List of markup rules for publishing a Muse page to HTML.
 129 For more on the structure of this list, see `muse-publish-markup-regexps'."
 130   :type '(repeat (choice
 131                   (list :tag "Markup rule"
 132                         integer
 133                         (choice regexp symbol)
 134                         integer
 135                         (choice string function symbol))
 136                   function))
 137   :group 'muse-html)
 138
 139 (defcustom muse-html-markup-functions
 140   '((anchor   . muse-html-markup-anchor)
 141     (table    . muse-html-markup-table)
 142     (footnote . muse-html-markup-footnote))
 143   "An alist of style types to custom functions for that kind of text.
 144 For more on the structure of this list, see
 145 `muse-publish-markup-functions'."
 146   :type '(alist :key-type symbol :value-type function)
 147   :group 'muse-html)
 148
 149 (defcustom muse-html-markup-strings
 150   '((image-with-desc . "<img src=\"%s\" alt=\"%s\">")
 151     (image-link      . "<img src=\"%s\">")
 152     (url-with-image  . "<a class=\"image-link\" href=\"%s\"><img src=\"%s\"></a>")
 153     (url-link        . "<a href=\"%s\">%s</a>")
 154     (email-addr      . "<a href=\"mailto:%s\">%s</a>")
 155     (emdash          . " &mdash; ")
 156     (rule            . "<hr>")
 157     (fn-sep          . "<hr>\n")
 158     (enddots         . "....")
 159     (dots            . "...")
 160     (section         . "<h2>")
 161     (section-end     . "</h2>")
 162     (subsection      . "<h3>")
 163     (subsection-end  . "</h3>")
 164     (subsubsection   . "<h4>")
 165     (subsubsection-end . "</h4>")
 166     (begin-underline . "<u>")
 167     (end-underline   . "</u>")
 168     (begin-literal   . "<code>")
 169     (end-literal     . "</code>")
 170     (begin-emph      . "<em>")
 171     (end-emph        . "</em>")
 172     (begin-more-emph . "<strong>")
 173     (end-more-emph   . "</strong>")
 174     (begin-most-emph . "<strong><em>")
 175     (end-most-emph   . "</em></strong>")
 176     (begin-verse     . "<p class=\"verse\">\n")
 177     (verse-space     . "&nbsp;&nbsp;")
 178     (end-verse-line  . "<br>")
 179     (last-stanza-end . "<br>")
 180     (empty-verse-line . "<br>")
 181     (end-verse       . "</p>")
 182     (begin-example   . "<pre class=\"example\">")
 183     (end-example     . "</pre>")
 184     (begin-center    . "<center>\n")
 185     (end-center      . "\n</center>")
 186     (begin-quote     . "<blockquote>\n")
 187     (end-quote       . "\n</blockquote>")
 188     (begin-uli       . "<ul>\n<li>")
 189     (end-uli         . "</li>\n</ul>")
 190     (begin-oli       . "<ol>\n<li>")
 191     (end-oli         . "</li>\n</ol>")
 192     (begin-ddt       . "<dl>\n<dt><strong>")
 193     (start-dde       . "</strong></dt>\n<dd>")
 194     (end-ddt         . "</dd>\n</dl>"))
 195   "Strings used for marking up text.
 196 These cover the most basic kinds of markup, the handling of which
 197 differs little between the various styles."
 198   :type '(alist :key-type symbol :value-type string)
 199   :group 'muse-html)
 200
 201 (defcustom muse-html-markup-tags
 202   '(("class" t t muse-html-class-tag))
 203   "A list of tag specifications, for specially marking up HTML."
 204   :type '(repeat (list (string :tag "Markup tag")
 205                        (boolean :tag "Expect closing tag" :value t)
 206                        (boolean :tag "Parse attributes" :value nil)
 207                        function))
 208   :group 'muse-html)
 209
 210 (defcustom muse-html-markup-specials
 211   '((?\" . "&quot;")
 212     (?\< . "&lt;")
 213     (?\> . "&gt;")
 214     (?\& . "&amp;"))
 215   "A table of characters which must be represented specially."
 216   :type '(alist :key-type character :value-type string)
 217   :group 'muse-html)
 218
 219 (defcustom muse-html-meta-http-equiv "Content-Type"
 220   "The http-equiv attribute used for the HTML <meta> tag."
 221   :type 'string
 222   :group 'muse-html)
 223
 224 (defcustom muse-html-meta-content-type "text/html"
 225   "The content type used for the HTML <meta> tag."
 226   :type 'string
 227   :group 'muse-html)
 228
 229 (defcustom muse-html-meta-content-encoding (if (featurep 'mule)
 230                                               'detect
 231                                             "iso-8859-1")
 232   "If set to the symbol 'detect, use `muse-coding-map' to try
 233   and determine the HTML charset from emacs's coding. If set to a string, this
 234   string will be used to force a particular charset"
 235   :type '(choice string symbol)
 236   :group 'muse-html)
 237
 238 (defcustom muse-html-charset-default "iso-8859-1"
 239   "The default HTML meta charset to use if no translation is found in
 240   `muse-coding-map'"
 241   :type 'string
 242   :group 'muse-html)
 243
 244 (defcustom muse-html-encoding-default 'iso-8859-1
 245   "The default emacs coding  use if no special characters are found"
 246   :type 'symbol
 247   :group 'muse-html)
 248
 249 (defcustom muse-html-encoding-map
 250   '((iso-2022-jp        . "iso-2022-jp")
 251     (utf-8              . "utf-8")
 252     (japanese-iso-8bit  . "euc-jp")
 253     (chinese-big5       . "big5")
 254     (mule-utf-8         . "utf-8")
 255     (chinese-iso-8bit   . "gb2312")
 256     (chinese-gbk        . "gbk"))
 257   "An alist mapping emacs coding systems to appropriate HTML charsets.
 258   Use the base name of the coding system (ie, without the -unix)"
 259   :type '(alist :key-type coding-system :value-type string)
 260   :group 'muse-html)
 261
 262 (defun muse-html-transform-content-type (content-type)
 263   "Using `muse-html-encoding-map', try and resolve an emacs coding
 264 system to an associated HTML coding system. If no match is found,
 265 `muse-html-charset-default' is used instead."
 266   (let ((match (assoc (coding-system-base content-type)
 267                       muse-html-encoding-map)))
 268     (if match
 269         (cdr match)
 270       muse-html-charset-default)))
 271
 272 (defun muse-html-insert-anchor (anchor)
 273   "Insert an anchor, either around the word at point, or within a tag."
 274   (skip-chars-forward muse-regexp-space)
 275   (if (looking-at "<\\([^ />]+\\)>")
 276       (let ((tag (match-string 1)))
 277         (goto-char (match-end 0))
 278         (insert "<a name=\"" anchor "\" id=\"" anchor "\">")
 279         (when muse-html-anchor-on-word
 280           (or (and (search-forward (format "</%s>" tag)
 281                                    (line-end-position) t)
 282                    (goto-char (match-beginning 0)))
 283               (forward-word 1)))
 284         (insert "</a>"))
 285     (insert "<a name=\"" anchor "\" id=\"" anchor "\">")
 286     (when muse-html-anchor-on-word
 287       (forward-word 1))
 288     (insert "</a>")))
 289
 290 (unless (fboundp 'looking-back)
 291   (defun looking-back (regexp &optional limit)
 292     (save-excursion
 293       (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t))))
 294
 295 (defun muse-html-markup-paragraph ()
 296   (let ((end (copy-marker (match-end 0) t)))
 297     (goto-char (match-beginning 0))
 298     (unless (eq (char-before) ?\>) (insert "</p>"))
 299     (goto-char end)
 300     (unless (and (eq (char-after) ?\<)
 301                  (not (or (looking-at "<\\(em\\|strong\\|code\\)>")
 302                           (and (looking-at "<a ")
 303                                (not (looking-at "<a[^>]+><img"))))))
 304       (cond
 305        ((looking-back "\\(</h[1-4]>\\|<hr>\\)\n\n")
 306         (insert "<p class=\"first\">"))
 307        ((looking-back "<\\(blockquote\\|center\\)>\n")
 308         (insert "<p class=\"quoted\">"))
 309        (t
 310         (insert "<p>"))))))
 311
 312 (defun muse-html-markup-anchor ()
 313   (save-match-data
 314     (muse-html-insert-anchor (match-string 1))) "")
 315
 316 (defun muse-html-escape-string (str)
 317   "Convert to character entities any non-alphanumeric characters
 318 outside a few punctuation symbols, that risk being misinterpreted
 319 if not escaped."
 320   (when str
 321     (let (pos code len)
 322       (save-match-data
 323         (while (setq pos (string-match (concat "[^-"
 324                                                muse-regexp-alnum
 325                                                "/:._=@\\?~#]")
 326                                        str pos))
 327           (setq code (int-to-string (aref str pos))
 328                 len (length code)
 329                 str (replace-match (concat "&#" code ";") nil nil str)
 330                 pos (+ 3 len pos)))
 331         str))))
 332
 333 (defun muse-html-markup-footnote ()
 334   (if (/= (line-beginning-position) (match-beginning 0))
 335       "<sup><a name=\"fnr.\\1\" href=\"#fn.\\1\">\\1</a></sup>"
 336     (prog1
 337         "<p class=\"footnote\"><a name=\"fn.\\1\" href=\"#fnr.\\1\">\\1.</a>"
 338       (save-excursion
 339         (save-match-data
 340           (let* ((beg (goto-char (match-end 0)))
 341                  (end (and (search-forward "\n\n" nil t)
 342                            (prog1
 343                                (copy-marker (match-beginning 0))
 344                              (goto-char beg)))))
 345             (while (re-search-forward (concat "^["
 346                                               muse-regexp-blank
 347                                               "]+\\([^\n]\\)")
 348                                       end t)
 349               (replace-match "\\1" t))))))))
 350
 351 (defun muse-html-markup-table ()
 352   (let* ((str (prog1
 353                   (match-string 1)
 354                 (delete-region (match-beginning 0) (match-end 0))))
 355          (fields (split-string str "\\s-*|+\\s-*"))
 356          (type (and (string-match "\\s-*\\(|+\\)\\s-*" str)
 357                     (length (match-string 1 str))))
 358          (part (cond ((= type 1) "tbody")
 359                      ((= type 2) "thead")
 360                      ((= type 3) "tfoot")))
 361          (col (cond ((= type 1) "td")
 362                     ((= type 2) "th")
 363                     ((= type 3) "td")))
 364          field)
 365     (insert "<table " muse-html-table-attributes ">\n"
 366             "  <" part ">\n"
 367             "    <tr>\n")
 368     (dolist (field fields)
 369       (insert "      <" col ">" field "</" col ">\n"))
 370     (insert "    </tr>\n"
 371             "  </" part ">\n"
 372             "</table>\n")))
 373
 374 ;; Handling of tags for HTML
 375
 376 (defun muse-html-insert-contents (depth)
 377   (let ((max-depth (or depth 2))
 378         (index 1)
 379         base contents l)
 380     (save-excursion
 381       (goto-char (point-min))
 382       (search-forward "Page published by Emacs Muse begins here" nil t)
 383       (catch 'done
 384         (while (re-search-forward "^<h\\([0-9]+\\)>\\(.+?\\)</h\\1>" nil t)
 385           (unless (get-text-property (point) 'read-only)
 386             (setq l (1- (string-to-int (match-string 1))))
 387             (if (null base)
 388                 (setq base l)
 389               (if (< l base)
 390                   (throw 'done t)))
 391             (when (<= l max-depth)
 392               (setq contents (cons (cons l (match-string-no-properties 2))
 393                                    contents))
 394               (goto-char (match-beginning 2))
 395               (muse-html-insert-anchor (concat "sec" (int-to-string index)))
 396               (setq index (1+ index)))))))
 397     (setq index 1 contents (reverse contents))
 398     (let ((depth 1) (sub-open 0) (p (point)))
 399       (insert "<dl class=\"contents\">\n")
 400       (while contents
 401         (insert "<dt class=\"contents\">\n")
 402         (insert "<a href=\"#sec" (int-to-string index) "\">"
 403                 (muse-publish-strip-tags (cdar contents))
 404                 "</a>\n")
 405         (setq index (1+ index))
 406         (insert "</dt>\n")
 407         (setq depth (caar contents)
 408               contents (cdr contents))
 409         (if contents
 410             (cond
 411              ((< (caar contents) depth)
 412               (let ((idx (caar contents)))
 413                 (while (< idx depth)
 414                   (insert "</dl>\n</dd>\n")
 415                   (setq sub-open (1- sub-open)
 416                         idx (1+ idx)))))
 417              ((> (caar contents) depth) ; can't jump more than one ahead
 418               (insert "<dd>\n<dl class=\"contents\">\n")
 419               (setq sub-open (1+ sub-open))))))
 420       (while (> sub-open 0)
 421         (insert "</dl>\n</dd>\n")
 422         (setq sub-open (1- sub-open)))
 423       (insert "</dl>\n")
 424       (muse-publish-mark-read-only p (point)))))
 425
 426 (defun muse-html-class-tag (beg end attrs)
 427   (goto-char beg)
 428   (insert "<span class=\"" (cdr (assoc "name" attrs)) "\">")
 429   (goto-char end)
 430   (insert "</span>"))
 431
 432 ;; Register the Muse HTML Publisher
 433
 434 (defun muse-html-browse-file (file)
 435   (browse-url (concat "file:" file)))
 436
 437 (defun muse-html-encoding ()
 438   (if (stringp muse-html-meta-content-encoding)
 439       muse-html-meta-content-encoding
 440     (muse-html-transform-content-type
 441      (or buffer-file-coding-system
 442          muse-html-encoding-default))))
 443
 444 (defun muse-html-prepare-buffer ()
 445   (set (make-local-variable 'muse-publish-url-transforms)
 446        (cons 'muse-html-escape-string muse-publish-url-transforms))
 447   (make-local-variable 'muse-html-meta-http-equiv)
 448   (set (make-local-variable 'muse-html-meta-content-type)
 449        (concat muse-html-meta-content-type "; charset="
 450                (muse-html-encoding))))
 451
 452 (defun muse-html-finalize-buffer ()
 453   (when muse-publish-generate-contents
 454     (goto-char (car muse-publish-generate-contents))
 455     (muse-html-insert-contents (cdr muse-publish-generate-contents)))
 456   (when (memq buffer-file-coding-system '(no-conversion undecided-unix))
 457     ;; make it agree with the default charset
 458     (setq buffer-file-coding-system muse-html-encoding-default)))
 459
 460 (unless (assoc "html" muse-publishing-styles)
 461   (muse-define-style "html"
 462                      :suffix    'muse-html-extension
 463                      :regexps   'muse-html-markup-regexps
 464                      :functions 'muse-html-markup-functions
 465                      :strings   'muse-html-markup-strings
 466                      :tags      'muse-html-markup-tags
 467                      :specials  'muse-html-markup-specials
 468                      :before    'muse-html-prepare-buffer
 469                      :after     'muse-html-finalize-buffer
 470                      :header    'muse-html-header
 471                      :footer    'muse-html-footer
 472                      :browser   'muse-html-browse-file))
 473
 474 (provide 'muse-html)
 475
 476 ;;; muse-html.el ends here