10:02 a.m.
My newsserver is ＠#$＠#$＠#, so I have no idea if my submissions to
gnu.emacs.sources et al. really reached anyone. Anyway, here is the
latest and greatest version of htmlize.el. I would like to hear your
comments.
;; htmlize.el -- HTML-ize font-lock buffers
;; Copyright (C) 1997,1998 Free Software Foundation
;; Author: Hrvoje Niksic <hniksic(a)srce.hr>
;; Keywords: hypermedia, extensions
;; 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
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; XEmacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Synched up with: not in FSF
;;; Commentary:
;; This package will allow you to HTML-ize your font-lock buffers,
;; analyzing the text properties and transforming them to HTML. Mail
;; to <hniksic(a)srce.hr> to discuss features and additions. All
;; suggestions are more than welcome.
;; 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.
;; 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.
;; 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.
;; Thanks go to: Ron Gut <rgut(a)aware.com> for useful additions that I
;; incorporated; to Bob Weiner <weiner(a)altrasoft.com> for neat ideas
;; (use of rgb.txt and caching face colors); to Toni Drabik
;; <tdrabik(a)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.
;;; Code:
(require 'cl)
(eval-when-compile
(if (string-match "XEmacs" emacs-version)
(byte-compiler-options
(warnings (- unresolved)))))
(defconst htmlize-version "0.31")
;; BLOB to make custom stuff work even without customize
(eval-and-compile
(condition-case ()
(require 'custom)
(error nil))
(if (and (featurep 'custom) (fboundp 'custom-declare-variable))
nil ;; We've got what we needed
;; We have the old custom-library, hack around it!
(defmacro defgroup (&rest args)
nil)
(defmacro defcustom (var value doc &rest args)
(` (defvar (, var) (, value) (, doc))))))
(defgroup htmlize nil
"HTMLize font-locked buffers."
:group 'hypermedia)
(defcustom htmlize-head-tags ""
"*Additional tags to insert within HEAD of the generated document."
:type 'string
:group 'htmlize)
(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)
(setf (aref table i) (char-to-string i)))
(setf (aref table ?&) "&"
(aref table ?<) "<"
(aref table ?>) ">"
(aref table ?\") """)
table))
(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\"
\"http://www.w3.org/TR/REC-html40/strict.dtd\">")
;; 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)
"HTML-ize BUFFER."
(interactive)
(or buffer
(setq buffer (current-buffer)))
(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)))
(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)
;;; htmlize.el ends here