[nongnu] elpa/htmlize 6ca4f29 003/134: Version 0.33.

[ELPA Syncer]

branch: elpa/htmlize
commit 6ca4f29c8506ae2f69181385b0e36a36a4204e50
Author: Hrvoje Niksic <hniksic@gmail.com>
Commit: Hrvoje Niksic <hniksic@gmail.com>

    Version 0.33.
---
 htmlize.el | 607 +++++++++++++++++++++++++++++++++++++++++++++++++++----------
 1 file changed, 510 insertions(+), 97 deletions(-)

diff --git a/htmlize.el b/htmlize.el
index 1ac53ae..2b26efe 100644
--- a/htmlize.el
+++ b/htmlize.el
@@ -1,12 +1,12 @@
-;;; htmlize.el -- HTML-ize font-lock buffers
+;; htmlize.el -- HTML-ize font-lock buffers
 
-;; Copyright (c) 1997 Free Software Foundation
+;; Copyright (C) 1997,1998 Free Software Foundation
 
 ;; Author: Hrvoje Niksic <hniksic@srce.hr>
 ;; Keywords: hypermedia, extensions
-;; Version: 0.7
 
-;; This file is not yet part of any Emacs.
+;; This file is not yet part of any Emacs, but it may be distributed
+;; under the XEmacs distribution terms:
 
 ;; XEmacs is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
@@ -27,30 +27,52 @@
 
 ;;; Commentary:
 
-;; This package will allow you to HTML-ize your font-lock buffers.  It
-;; takes into account only the colors.  A lot of functionality could
-;; be added.  Mail to <hniksic@srce.hr> to discuss features and
-;; additions.  All suggestions are more than welcome.
+;; This package will allow you to HTML-ize your font-lock buffers,
+;; analyzing the text properties and transforming them to HTML.  Mail
+;; to <hniksic@srce.hr> to discuss features and additions.  All
+;; suggestions are more than welcome.
 
-;; This package generates correct HTML (or a semblance of it; I
-;; haven't yet bothered to actually run it through a checker).  Since
-;; <font> is not allowed to be within <pre>, we cheat by inserting the
-;; DTD for HTML Pro.  Ha ha ha.
+;; To use, just switch to a buffer you want HTML-ized, and type `M-x
+;; htmlize-buffer'.  After that, you should find yourself in an HTML
+;; buffer, which you can save.
 
-;; To use, just go to a buffer, and invoke `M-x htmlize-buffer', and
-;; you'll be put to an HTML buffer, which you can save.  The operation
-;; can take a bit of time, if your original buffer is long -- so be
-;; patient.
+;; The code attempts to generate compliant HTML, but I can't make any
+;; guarantees; I haven't yet bothered to run the generated markup
+;; through a validator.  I tried to make the package elisp-compatible
+;; with multiple Emacsen, specifically aiming for XEmacs 19.14+ and
+;; GNU Emacs 19.34+.  Please let me know if it doesn't, and I'll try
+;; to fix it.  I relied heavily on the presence of CL extensions,
+;; especially for compatibility; please don't try to remove that
+;; dependency.
 
-;; This code should work under XEmacs 19.14+ and GNU Emacs 19.34+.
+;; When compiling under GNU Emacs, you'll likely to get oodles of
+;; warnings; ignore them all.  For any of this to work, you need to
+;; run Emacs under a window-system -- anything else will almost
+;; certainly fail.
 
-;; Useful additions by Ron Gut <rgut@aware.com> incorporated.
+;; Thanks go to: Ron Gut <rgut@aware.com> for useful additions that I
+;; incorporated; to Bob Weiner <weiner@altrasoft.com> for neat ideas
+;; (use of rgb.txt and caching face colors); to Toni Drabik
+;; <tdrabik@public.srce.hr> for a crash course to CSS1.
+
+;; TODO: Should attempt to merge faces (utilize CSS for this?).
+;; Should recognize all extents under XEmacs, not just text
+;; properties.  Should recognize overlays under FSF Emacs.  Should
+;; ignore invisible text.  Should expand TABs.
+
+;; User quotes: "You sir, are a sick, sick, _sick_ person. :)"
+;;                  -- Bill Perry, author of Emacs/W3
 
 
 ;;; Code:
 
 (require 'cl)
+(eval-when-compile
+  (if (string-match "XEmacs" emacs-version)
+      (byte-compiler-options
+       (warnings (- unresolved)))))
 
+(defconst htmlize-version "0.33")
 
 ;; BLOB to make custom stuff work even without customize
 (eval-and-compile
@@ -69,21 +91,59 @@
   "HTMLize font-locked buffers."
   :group 'hypermedia)
 
-(defcustom htmlize-tags ""
-  "*Headers to insert."
+(defcustom htmlize-head-tags ""
+  "*Additional tags to insert within HEAD of the generated document."
   :type 'string
   :group 'htmlize)
 
-;; We use the HTML Pro DTD by default.  Note that under any other DTD
-;; it is illegal to specify <font> under <pre>.
-(defcustom htmlize-dtd-version
-  "HTML PUBLIC \"+//Silmaril//DTD HTML Pro v0r11 19970101//EN\">\n"
-  "*Doctype of created HTMLs.
-Set this to the value of `html-helper-htmldtd-version' for consistency
-with psgml-html."
-  :type 'string
+(defcustom htmlize-output-type 'css
+  "*Output type of generated HTML.  Legal values are `css' and `font'.
+When set to `css' (the default), htmlize will generate a style sheet
+with description of faces, and use it in the HTML document, specifying
+the faces in the actual text with <span>.
+
+When set to `font', the properties will be set using layout tags
+<font>, <b>, <i>, <u>, and <strike>."
+  :type '(choice (const css) (const font))
+  :group 'htmlize)
+
+(defcustom htmlize-use-rgb-map t
+  "*Controls when `rgb.txt' should be looked up for color values.
+
+When set to t (the default), htmlize will, when running under an X
+display, look for the `rgb.txt' file and use it to obtain the RGB
+values for named colors.  This is useful when the values reported by
+`color-instance-rgb-components'/`x-color-values' are incorrect because
+of color approximation.
+
+When set to nil, htmlize will never look for `rgb.txt' and will always
+use the values Emacs returns.
+
+When set to `force', htmlize will try to look for `rgb.txt' even on
+non-X devices."
+  :type '(choice (const :tag "When Appropriate" t)
+                (const :tag "Never"          nil)
+                (const :tag "Always"       force))
   :group 'htmlize)
 
+(defvar htmlize-before-hook nil
+  "Hook run before htmlizing a buffer.
+The hook is run in the original buffer (not HTML buffer), so you may
+wish to add `font-lock-fontify-buffer' here.")
+
+(defvar htmlize-after-hook nil
+  "Hook run after htmlizing a buffer.
+Unlike `htmlize-before-hook', these functions are run in the HTML
+buffer.  You may use them to modify the outlook of the final HTML
+output.")
+
+;; I try to conditionalize on features rather than Emacs version, but
+;; in some cases checking against the version *is* necessary.
+(defconst htmlize-running-xemacs (string-match "XEmacs" emacs-version))
+
+
+;;; Protection of HTML strings.
+
 (defvar htmlize-character-table
   (let ((table (make-vector 256 ?\0)))
     (dotimes (i 256)
@@ -94,37 +154,378 @@ with psgml-html."
          (aref table ?\") "&quot;")
     table))
 
-(defun htmlize-protect (string)
-  (mapconcat (lambda (char)
-              (aref htmlize-character-table char))
-            string ""))
-
-(defsubst htmlize-face-color (face &optional bg-p)
-  (if (fboundp 'color-instance-rgb-components)
-      (mapcar (lambda (arg)
-               (/ arg 256))
-             (color-instance-rgb-components
-              (if bg-p
-                  (face-background-instance face)
-                (face-foreground-instance face))))
-    (mapcar (lambda (arg)
-             (/ arg 256))
-           (x-color-values
-            (or (if bg-p
-                    (face-background face)
-                  (face-foreground face))
-                (if bg-p "white"
-                  "black"))))))
-
-(defsubst htmlize-face-color-string (face &optional bg-p)
-  (apply 'format "#%02x%02x%02x" (htmlize-face-color face bg-p)))
-
-;; `insert-string' is useful in XEmacs.
-(if (string-match "XEmacs" emacs-version)
-    (defalias 'htmlize-insert-string 'insert-string)
-  (defun htmlize-insert-string (str buf)
-    (letf (((current-buffer) buf))
-      (insert str))))
+(defun htmlize-protect-string (string)
+  ;; Checking whether STRING contains dangerous stuff removes a lot of
+  ;; unnecessary consing.
+  (if (not (string-match "[&<>\"]" string))
+      string
+    (mapconcat (lambda (char)
+                (aref htmlize-character-table char))
+              string "")))
+
+;; Currently unused.
+;(defun htmlize-protect-region (start end)
+;  (goto-char start)
+;  (let (match replacement)
+;    (while (re-search-forward "[&<>\"]" end t)
+;      (setq match (char-after (1- (point)))
+;          replacement (aref htmlize-character-table match))
+;      (delete-region (1- (point)) (point))
+;      (insert replacement)
+;      (incf end (1- (length replacement)))))
+;  (goto-char end))
+
+;;; Color handling.
+
+(if (fboundp 'locate-file)
+    (defalias 'htmlize-locate-file 'locate-file)
+  (defun htmlize-locate-file (file path)
+    (dolist (dir path nil)
+      (when (file-exists-p (expand-file-name file dir))
+       (return (expand-file-name file dir))))))
+
+(unless (fboundp 'with-current-buffer)
+  (defmacro with-current-buffer (buffer &rest forms)
+    `(save-excursion (set-buffer ,buffer) ,@forms)))
+(unless (fboundp 'with-temp-buffer)
+  (defmacro with-temp-buffer (&rest forms)
+    (let ((temp-buffer (make-symbol "temp-buffer")))
+      `(let ((,temp-buffer
+             (get-buffer-create (generate-new-buffer-name " *temp*"))))
+        (unwind-protect
+            (with-current-buffer ,temp-buffer
+              ,@forms)
+          (and (buffer-name ,temp-buffer)
+               (kill-buffer ,temp-buffer)))))))
+
+(defvar htmlize-x-library-search-path
+  '("/usr/X11R6/lib/X11/"
+    "/usr/X11R5/lib/X11/"
+    "/usr/lib/X11R6/X11/"
+    "/usr/lib/X11R5/X11/"
+    "/usr/local/X11R6/lib/X11/"
+    "/usr/local/X11R5/lib/X11/"
+    "/usr/local/lib/X11R6/X11/"
+    "/usr/local/lib/X11R5/X11/"
+    "/usr/X11/lib/X11/"
+    "/usr/lib/X11/"
+    "/usr/local/lib/X11/"
+    "/usr/X386/lib/X11/"
+    "/usr/x386/lib/X11/"
+    "/usr/XFree86/lib/X11/"
+    "/usr/unsupported/lib/X11/"
+    "/usr/athena/lib/X11/"
+    "/usr/local/x11r5/lib/X11/"
+    "/usr/lpp/Xamples/lib/X11/"
+    "/usr/openwin/lib/X11/"
+    "/usr/openwin/share/lib/X11/"))
+
+(defun htmlize-get-color-rgb-hash (&optional rgb-file)
+  "Return a hash table mapping X color names to RGB values.
+The keys to the hash table are X color names as strings, and the
+values are the #rrggbb RGB specifications, extracted from `rgb.txt'.
+
+If RGB-FILE is nil, the function will try hard to find a suitable file
+in the system directories."
+  (let ((rgb-file (or rgb-file (htmlize-locate-file
+                               "rgb.txt"
+                               htmlize-x-library-search-path)))
+       (hash (make-hash-table :test 'equal)))
+    (with-temp-buffer
+      (insert-file-contents rgb-file)
+      (while (not (eobp))
+       (cond ((looking-at "^!")
+              ;; Skip comments
+              )
+             ((looking-at "[ \t]*\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ 
\t]+\\([0-9]+\\)[ \t]+\\(.*\\)")
+              (setf (gethash (downcase (match-string 4)) hash)
+                    (format "#%02x%02x%02x"
+                            (string-to-number (match-string 1))
+                            (string-to-number (match-string 2))
+                            (string-to-number (match-string 3)))))
+             (t
+              (error "Unrecognized line in rgb.txt: %s"
+                     (buffer-substring (point) (progn (end-of-line) 
(point))))))
+       (forward-line 1)))
+    hash))
+
+(defvar htmlize-color-rgb-hash nil)
+(and (or (eq htmlize-use-rgb-map 'force)
+        (and (eq htmlize-use-rgb-map t)
+             (eq window-system 'x)))
+     (null htmlize-color-rgb-hash)
+     (setq htmlize-color-rgb-hash (htmlize-get-color-rgb-hash)))
+
+;;; Face handling
+
+;; (htmlize-face-foreground FACE) should return the foreground color
+;; of the face, either as color name string or as #rrggbb string.
+(cond ((fboundp 'face-foreground-name)
+       ;; New XEmacs
+       (defalias 'htmlize-face-foreground 'face-foreground-name)
+       (defalias 'htmlize-face-background 'face-background-name))
+      ((fboundp 'color-instance-name)
+       ;; XEmacs before 20.4, hopefully
+       (defun htmlize-face-foreground (face)
+        (color-instance-name (face-foreground-instance face)))
+       (defun htmlize-face-background (face)
+        (color-instance-name (face-background-instance face))))
+      ((fboundp 'x-color-values)
+       ;; FSF Emacs
+       (defun htmlize-face-foreground (face)
+        (or (face-foreground face)
+            (face-foreground 'default)
+            ;; Totally bogus, but in my FSFmacs, (face-foreground
+            ;; 'default) simply returns nil.  Is it a bug?  Is there
+            ;; a way around it?
+            "black"))
+       (defun htmlize-face-background (face)
+        (or (face-background face)
+            (face-background 'default)
+            "white")))
+      (t
+       (error "WTF?!")))
+
+(if (fboundp 'find-face)
+    (defalias 'htmlize-symbol-face-p 'find-face)
+  (defalias 'htmlize-symbol-face-p 'facep))
+
+;; Return the #rrggbb string for foreground color of FACE.  If BG-P is
+;; non-nil, background color is used.
+(defun htmlize-face-rgb-string-direct (face &optional bg-p)
+  (apply #'format "#%02x%02x%02x"
+        (if (fboundp 'color-instance-rgb-components)
+            (mapcar (lambda (arg)
+                      (/ arg 256))
+                    (color-instance-rgb-components
+                     (if bg-p
+                         (face-background-instance face)
+                       (face-foreground-instance face))))
+          (mapcar (lambda (arg)
+                    (/ arg 256))
+                  (x-color-values (if bg-p (htmlize-face-background face)
+                                    (htmlize-face-foreground face)))))))
+
+(defun htmlize-face-rgb-string (face &optional bg-p)
+  (if (and htmlize-use-rgb-map
+          htmlize-color-rgb-hash)
+      (let* ((oname (downcase (if bg-p (htmlize-face-background face)
+                               (htmlize-face-foreground face))))
+            (name (if (string-match "^#" oname)
+                      oname
+                    (gethash oname htmlize-color-rgb-hash))))
+       (unless name
+         (error "Something is rotten (face %s, color %s)" face oname))
+       name)
+    (htmlize-face-rgb-string-direct face bg-p)))
+
+(defstruct htmlize-face
+  rgb-foreground                       ; foreground color, #rrggbb
+  rgb-background                       ; background color, #rrggbb
+  boldp                                        ; whether face is bold
+  italicp                              ; whether face is italic
+  underlinep                           ; whether face is underlined
+  strikep                              ; whether face is strikethrough
+  css-name                             ; CSS name of face
+  )
+(defvar htmlize-face-hash (make-hash-table :type 'eq))
+
+(defun htmlize-make-face-hash (faces)
+  (clrhash htmlize-face-hash)
+  (let (face-fancy-names b-font i-font bi-font use-bi use-i)
+    (when htmlize-running-xemacs
+      (setq b-font (face-font-name 'bold)
+           i-font (face-font-name 'italic)
+           bi-font (face-font-name 'bold-italic)
+           use-bi (not (or (equal b-font bi-font) (equal i-font bi-font)))
+           use-i (not (equal b-font i-font))))
+    (dolist (face faces)
+      (let ((object (make-htmlize-face
+                    :rgb-foreground (htmlize-face-rgb-string face)
+                    :rgb-background (htmlize-face-rgb-string face t)
+                    :underlinep (face-underline-p face))))
+       ;; Portability junk -- there is no good way of detecting
+       ;; whether a face is bold or italic under XEmacs, so I need to
+       ;; resort to disgusting hacks.  Please close your eyes lest
+       ;; you vomit or spontaneously combust.
+       (if htmlize-running-xemacs
+           (let* ((font (face-font-name face)))
+             ;; Boldness, XEmacs
+             (setf (htmlize-face-boldp object)
+                   (or (equal font (face-font-name 'bold))
+                       (and use-bi
+                            (equal font (face-font-name 'bold-italic)))))
+             ;; Italic-ness, XEmacs
+             (setf (htmlize-face-italicp object)
+                   (and use-i
+                        (or (equal font (face-font-name 'italic))
+                            (and use-bi
+                                 (equal font (face-font-name 'bold-italic))))))
+             ;; OK, you may open them again.
+             ;; Strikethrough, XEmacs
+             (setf (htmlize-face-strikep object) (face-strikethru-p face)))
+         (setf
+          ;; Boldness, GNU Emacs
+          (htmlize-face-boldp object) (face-bold-p face)
+          ;; Italic-ness, GNU Emacs
+          (htmlize-face-italicp object) (face-italic-p face)
+          ;; Strikethrough is not supported by GNU Emacs.
+          (htmlize-face-strikep object) nil))
+
+       ;; css-name.  Emacs is lenient about face names -- virtually
+       ;; any string may name a face, even those consisting of
+       ;; characters such as ^@.  We try hard to beat the face name
+       ;; into shape, both esthetically and according to CSS1 specs.
+       (setf (htmlize-face-css-name object)
+             (let ((name (downcase (symbol-name face))))
+               (when (string-match "\\`font-lock-" name)
+                 (setq name (replace-match "" t t name)))
+               (when (string-match "-face\\'" name)
+                 (setq name (replace-match "" t t name)))
+               (while (string-match "[^-a-zA-Z0-9]" name)
+                 (setq name (replace-match "X" t t name)))
+               (when (string-match "^[-0-9]" name)
+                 (setq name (concat "X" name)))
+               (let ((i 1))
+                 (while (member name face-fancy-names)
+                   (setq name (format "%s-%d" name i))
+                   (incf i)))
+               (push name face-fancy-names)
+               name))
+       ;; Hash it away.
+       (setf (gethash face htmlize-face-hash) object)))))
+
+(defun htmlize-faces-in-buffer ()
+  "Return a list of faces used by the extents in the current buffer."
+  (let (faces)
+    (if (fboundp 'map-extents)
+       (map-extents (lambda (extent ignored)
+                      (let ((face (extent-face extent)))
+                        (when (consp face)
+                          (setq face (car face)))
+                        (when (htmlize-symbol-face-p face)
+                          (pushnew face faces)))
+                      nil)
+                    nil nil nil nil nil 'face)
+      (save-excursion
+       (goto-char (point-min))
+       (let (face next)
+         (while (not (eobp))
+           (setq face (get-text-property (point) 'face)
+                 next (or (next-single-property-change (point) 'face)
+                          (point-max)))
+           (when (consp face)
+             (setq face (car face)))
+           (when (htmlize-symbol-face-p face)
+             (pushnew face faces))
+           (goto-char next)))
+       (setq faces (delq nil faces))))
+    (delq 'default faces)))
+
+;;; CSS1 support
+
+(defun htmlize-css-doctype ()
+  nil                                  ; no doc-string
+  "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0//EN\">")
+
+;; Internal function; not a method.
+(defun htmlize-css-specs (face-object &optional default-face-object)
+  (let (result)
+    (when (or (not default-face-object)
+             (not (equal (htmlize-face-rgb-foreground face-object)
+                         (htmlize-face-rgb-foreground default-face-object))))
+      (push (format "color: %s;" (htmlize-face-rgb-foreground face-object))
+           result))
+    (when (or (not default-face-object)
+             (not (equal (htmlize-face-rgb-background face-object)
+                         (htmlize-face-rgb-background default-face-object))))
+      (push (format "background-color: %s;"
+                   (htmlize-face-rgb-background face-object)) result))
+    (when (and (htmlize-face-boldp face-object)
+              (or (not default-face-object)
+                  (not (htmlize-face-boldp default-face-object))))
+      (push "font-weight: bold;" result))
+    (when (and (htmlize-face-italicp face-object)
+              (or (not default-face-object)
+                  (not (htmlize-face-italicp default-face-object))))
+      (push "font-style: italic;" result))
+    (when (and (htmlize-face-underlinep face-object)
+              (or (not default-face-object)
+                  (not (htmlize-face-underlinep default-face-object))))
+      (push "text-decoration: underline;" result))
+    (when (and (htmlize-face-strikep face-object)
+              (or (not default-face-object)
+                  (not (htmlize-face-strikep default-face-object))))
+      (push "text-decoration: line-through;" result))
+    (nreverse result)))
+
+(defun htmlize-css-insert-head ()
+  (insert "    <style type=\"text/css\">\n    <!--\n")
+  (let ((default-face-object (gethash 'default htmlize-face-hash)))
+    (insert "      BODY {\n        "
+           (mapconcat #'identity (htmlize-css-specs default-face-object)
+                      "\n        ")
+           "\n      } /* default */\n")
+    (maphash
+     (lambda (face face-object)
+       (let ((cleaned-up-face-name (symbol-name face)))
+        ;; If face name contains `--' or `*/', we must nix them out.
+        (while (string-match "--" cleaned-up-face-name)
+          (setq cleaned-up-face-name (replace-match "-" t t
+                                                    cleaned-up-face-name)))
+        (while (string-match "*/" cleaned-up-face-name)
+          (setq cleaned-up-face-name (replace-match "XX" t t
+                                                    cleaned-up-face-name)))
+        (unless (eq face 'default)
+          (let ((specs (htmlize-css-specs face-object default-face-object)))
+            (insert "      span." (htmlize-face-css-name face-object))
+            (if (null specs)
+                (insert " {")
+              (insert " {\n        "
+                      (mapconcat #'identity specs "\n        ")))
+            (insert "\n      } /* " cleaned-up-face-name " */\n")))))
+     htmlize-face-hash))
+  (insert "    -->\n    </style>\n"))
+
+(defun htmlize-css-face-prejunk (face-object)
+  (concat "<span class=\"" (htmlize-face-css-name face-object) "\">"))
+(defun htmlize-css-face-postjunk (face-object)
+  nil                                  ; no doc-string
+  "</span>")
+
+;;; <font> support
+
+;; We use the HTML Pro DTD by default.  Note that under W3-procured
+;; DTD's it is illegal to specify <font> under <pre>.
+(defun htmlize-font-doctype ()
+  nil                                  ; no doc-string
+  "<!DOCTYPE HTML PUBLIC \"+//Silmaril//DTD HTML Pro v0r11 19970101//EN\">")
+
+(defun htmlize-font-body-tag ()
+  (let ((face-object (gethash 'default htmlize-face-hash)))
+    (format "<body text=\"%s\" bgcolor=\"%s\">"
+           (htmlize-face-rgb-foreground face-object)
+           (htmlize-face-rgb-background face-object))))
+(defun htmlize-font-face-prejunk (face-object)
+  (concat "<font color=\"" (htmlize-face-rgb-foreground face-object) "\">"
+         (and (htmlize-face-boldp      face-object) "<b>")
+         (and (htmlize-face-italicp    face-object) "<i>")
+         (and (htmlize-face-underlinep face-object) "<u>")
+         (and (htmlize-face-strikep    face-object) "<strike>")))
+(defun htmlize-font-face-postjunk (face-object)
+  (concat (and (htmlize-face-strikep    face-object) "</strike>")
+         (and (htmlize-face-underlinep face-object) "</u>")
+         (and (htmlize-face-italicp    face-object) "</i>")
+         (and (htmlize-face-boldp      face-object) "</b>")
+         "</font>"))
+
+(defmacro htmlize-method (method &rest args)
+  (let ((func (gensym "hm-")))
+    `(let ((,func (intern (format "htmlize-%s-%s" htmlize-output-type 
',method))))
+       (and (fboundp ,func)
+           (funcall ,func ,@args)))))
+
+;; The one and only entry level function.
 
 ;;;###autoload
 (defun htmlize-buffer (&optional buffer)
@@ -132,47 +533,59 @@ with psgml-html."
   (interactive)
   (or buffer
       (setq buffer (current-buffer)))
-  (let ((newbuf (get-buffer-create "*html*"))
-       plist next-change face color-name)
-    (save-excursion
-      (set-buffer newbuf)
-      (erase-buffer)
-      (insert
-       "<!DOCTYPE "
-       "HTML PUBLIC \"+//Silmaril//DTD HTML Pro v0r11 19970101//EN\">\n"
-       "<html>\n<head>\n<title>"
-       (if (stringp buffer) buffer
-        (buffer-name buffer))
-       "</title>\n" htmlize-tags
-       "</head>\n"
-       (format "<body bgcolor=\"%s\" text=\"%s\">\n"
-              (htmlize-face-color-string 'default t)
-              (htmlize-face-color-string 'default))
-       "<pre>\n")
-      (set-buffer buffer)
-      (goto-char (point-min))
-      (while (not (eobp))
-       (setq plist (text-properties-at (point))
-             next-change (or (next-property-change (point) (current-buffer))
-                             (point-max)))
-       (setq color-name nil)
-       (setq face (plist-get plist 'face))
-       (when face
+  (save-excursion
+    (set-buffer buffer)
+    (run-hooks 'htmlize-before-hook)
+    (htmlize-make-face-hash (cons 'default (htmlize-faces-in-buffer))))
+  (let* ((newbuf (generate-new-buffer "*html*"))
+        next-change face face-object)
+    (switch-to-buffer newbuf)
+    (buffer-disable-undo)
+    (insert (htmlize-method doctype) ?\n
+           (format "<!-- Created by htmlize-%s in %s mode. -->\n"
+                   htmlize-version htmlize-output-type))
+    (insert "<html>\n  <head>\n    <title>"
+           (htmlize-protect-string (if (stringp buffer) buffer
+                                     (buffer-name buffer)))
+           "</title>\n" htmlize-head-tags)
+    (htmlize-method insert-head)
+    (insert "  </head>")
+    (insert "\n  "
+           (or (htmlize-method body-tag)
+               "<body>")
+           "\n    <pre>\n")
+    (with-current-buffer buffer
+      (save-excursion
+       (goto-char (point-min))
+       (while (not (eobp))
+         (setq face (get-text-property (point) 'face)
+               next-change (or (next-single-property-change (point) 'face)
+                               (point-max)))
          (and (consp face)
               ;; Choose the first face.
               (setq face (car face)))
-         (setq color-name (htmlize-face-color-string face))
-         (htmlize-insert-string
-          (concat "<font color=\"" color-name "\">") newbuf))
-       (htmlize-insert-string (htmlize-protect
-                               (buffer-substring (point) next-change))
-                              newbuf)
-       (when color-name
-         (htmlize-insert-string "</font>" newbuf))
-       (goto-char next-change)))
-    (switch-to-buffer newbuf)
-    (insert "</pre>\n</body>\n</html>\n")
-    (goto-char (point-min))))
+         (and (eq face 'default)
+              (setq face nil))
+         ;; FSF Emacs allows `face' property to contain arbitrary
+         ;; stuff.
+         (or (htmlize-symbol-face-p face)
+             (setq face nil))
+         (when face
+           (setq face-object (gethash face htmlize-face-hash))
+           (princ (htmlize-method face-prejunk face-object) newbuf))
+         (princ (htmlize-protect-string
+                 (buffer-substring-no-properties (point) next-change))
+                newbuf)
+         (when face
+           (princ (htmlize-method face-postjunk face-object) newbuf))
+         (goto-char next-change))))
+    (insert "</pre>\n  </body>\n</html>\n")
+    (goto-char (point-min))
+    (run-hooks 'htmlize-after-hook)
+    (buffer-enable-undo)
+    ;; We won't be needing the stored data anymore, so allow next gc
+    ;; to free up the used conses.
+    (clrhash htmlize-face-hash)))
 
 (provide 'htmlize)