Download
(require 'cl)
(eval-when-compile
(if (string-match "XEmacs" emacs-version)
(byte-compiler-options
(warnings (- unresolved))))
(defvar font-lock-auto-fontify)
(defvar global-font-lock-mode))
(defconst htmlize-version "0.59")
(eval-and-compile
(condition-case ()
(require 'custom)
(error nil))
(if (and (featurep 'custom) (fboundp 'custom-declare-variable))
nil
(defmacro defgroup (&rest args)
nil)
(defmacro defcustom (var value doc &rest args)
(` (defvar (, var) (, value) (, doc))))
(defmacro defface (face value doc &rest stuff)
`(make-face ,face))))
(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 class=\"FACE\">.
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)
(defcustom htmlize-html-major-mode nil
"The mode the newly created HTML buffer will be put in.
Set this to nil if you prefer the default (fundamental) mode."
:type '(radio (const :tag "No mode (fundamental)" nil)
(function-item html-mode)
(function :tag "User-defined major mode"))
: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.")
(defvar htmlize-file-hook nil
"Hook run after htmlizing a file, and before writing it out to disk.
This is run by the `htmlize-file'.")
(defconst htmlize-running-xemacs (string-match "XEmacs" emacs-version))
(if (fboundp 'char-int)
(defalias 'htmlize-char-int 'char-int)
(defalias 'htmlize-char-int 'identity))
(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)
(if (not (string-match "[&<>\"]" string))
string
(mapconcat (lambda (char)
(if (> (htmlize-char-int char) 255)
(char-to-string char)
(aref htmlize-character-table char)))
string "")))
(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))))))
(if (fboundp 'file-name-extension)
(defalias 'htmlize-file-name-extension 'file-name-extension)
(defun htmlize-file-name-extension (filename &optional period)
(let ((file (file-name-sans-versions (file-name-nondirectory filename))))
(and (string-match "\\.[^.]*\\'" file)
(substring file (+ (match-beginning 0) (if period 0 1)))))))
(eval-and-compile
(unless (fboundp 'save-current-buffer)
(defmacro save-current-buffer (&rest forms)
`(let ((__scb_current (current-buffer)))
(unwind-protect
(progn ,@forms)
(set-buffer __scb_current)))))
(unless (fboundp 'with-current-buffer)
(defmacro with-current-buffer (buffer &rest forms)
`(save-current-buffer (set-buffer ,buffer) ,@forms)))
(unless (fboundp 'with-temp-buffer)
(defmacro with-temp-buffer (&rest forms)
(let ((temp-buffer (gensym "tb-")))
`(let ((,temp-buffer
(get-buffer-create (generate-new-buffer-name " *temp*"))))
(unwind-protect
(with-current-buffer ,temp-buffer
,@forms)
(and (buffer-live-p ,temp-buffer)
(kill-buffer ,temp-buffer))))))))
(if htmlize-running-xemacs
(defalias 'htmlize-next-change 'next-single-property-change)
(defalias 'htmlize-next-change 'next-single-property-change))
(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 "^!")
)
((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)))
(cond ((fboundp 'face-foreground-name)
(defalias 'htmlize-face-foreground 'face-foreground-name)
(defalias 'htmlize-face-background 'face-background-name))
((fboundp 'color-instance-name)
(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)
(defun htmlize-face-foreground (face)
(or (face-foreground face)
(face-foreground 'default)
(cdr (assq 'foreground-color (frame-parameters)))
"black"))
(defun htmlize-face-background (face)
(or (face-background face)
(face-background 'default)
(cdr (assq 'background-color (frame-parameters)))
"white")))
(t
(error "WTF?!")))
(if (fboundp 'find-face)
(defalias 'htmlize-symbol-face-p 'find-face)
(defalias 'htmlize-symbol-face-p 'facep))
(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
rgb-background
boldp
italicp
underlinep
strikep
css-name
)
(defvar htmlize-face-hash (make-hash-table :test '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))))
(if htmlize-running-xemacs
(let* ((font (face-font-name face)))
(setf (htmlize-face-boldp object)
(or (equal font (face-font-name 'bold))
(and use-bi
(equal font (face-font-name 'bold-italic)))))
(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))))))
(setf (htmlize-face-strikep object) (face-strikethru-p face)))
(when (fboundp 'face-bold-p)
(setf (htmlize-face-boldp object) (face-bold-p face)))
(when (fboundp 'face-italic-p)
(setf (htmlize-face-italicp object) (face-italic-p face)))
(setf (htmlize-face-strikep object) nil))
(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)))
(when (equal name "")
(setq name "face"))
(let ((i 1))
(while (member name face-fancy-names)
(setq name (format "%s-%d" name i))
(incf i)))
(push name face-fancy-names)
name))
(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 (and (fboundp 'map-extents)
(string-match "XEmacs" emacs-version))
(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-char-property (point) 'face)
next (or (htmlize-next-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)))
(defun htmlize-css-doctype ()
nil
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0//EN\">")
(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))
(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)))
(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
"</span>")
(defun htmlize-font-doctype ()
nil
"<!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)))))
(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 (with-current-buffer buffer
(generate-new-buffer (if (buffer-file-name)
(htmlize-make-file-name
(file-name-nondirectory
(buffer-file-name)))
"*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-char-property (point) 'face)
next-change (or (htmlize-next-change (point) 'face)
(point-max)))
(and (consp face)
(setq face (car face)))
(and (eq face 'default)
(setq face nil))
(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))
(when htmlize-html-major-mode
(funcall htmlize-html-major-mode))
(run-hooks 'htmlize-after-hook)
(buffer-enable-undo)
(clrhash htmlize-face-hash)))
(defun htmlize-make-file-name (file)
"Make an HTML file name from FILE.
The HTML file name is the regular file name, with its extension
changed to `.html'. The exception are the file names which don't
have an extension, or those which are already `.html' -- in these
cases, \".html\" is simply appended.
Some examples:
(htmlize-make-file-name \"foo.c\")
==> \"foo.html\"
(htmlize-make-file-name \"foo.b.c\")
==> \"foo.b.html\"
(htmlize-make-file-name \"foo\")
==> \"foo.html\"
(htmlize-make-file-name \"foo.html\")
==> \"foo.html.html\""
(let ((extension (htmlize-file-name-extension file))
(sans-extension (file-name-sans-extension file)))
(if (or (equal extension "html")
(equal extension "htm")
(equal sans-extension ""))
(concat file ".html")
(concat sans-extension ".html"))))
(defun htmlize-make-absolute-file-name (file dir)
"Create an absolute HTML file name with the desired directory.
That means, run FILE through `htmlize-make-file-name', and
expand it to either DIR or, if DIR is nil, to its own
directory name."
(expand-file-name (htmlize-make-file-name (file-name-nondirectory file))
(or dir (file-name-directory file))))
(defun htmlize-file (file &optional target-directory)
"HTML-ize FILE, and save the result.
If TARGET-DIRECTORY is non-nil, the resulting HTML file will be saved
to that directory, instead of to the FILE's directory."
(interactive (list (read-file-name
"HTML-ize file: "
nil nil nil (and (buffer-file-name)
(file-name-nondirectory
(buffer-file-name))))))
(let* ((was-visited (get-file-buffer file))
(font-lock-auto-fontify nil)
(global-font-lock-mode nil)
(origbuf (set-buffer (find-file-noselect file t))))
(font-lock-fontify-buffer)
(htmlize-buffer)
(run-hooks 'htmlize-file-hook)
(write-region (point-min) (point-max)
(htmlize-make-absolute-file-name file target-directory))
(kill-buffer (current-buffer))
(unless was-visited
(kill-buffer origbuf))))
(defun htmlize-many-files (files &optional target-directory)
"HTML-ize files specified by FILES, and save them to `.html' files.
If TARGET-DIRECTORY is specified, the HTML files will be saved to that
directory. Normally, each HTML file is saved to the directory of the
corresponding source file."
(interactive
(list
(let (list file)
(while (not (equal (setq file (read-file-name "HTML-ize file (RET to finish): "
(and list (file-name-directory
(car list)))
"" t))
""))
(push file list))
(nreverse list))))
(dolist (file files)
(htmlize-file file target-directory)))
(defun htmlize-many-files-dired (arg &optional target-directory)
"HTMLize dired-marked files."
(interactive "P")
(htmlize-many-files (dired-get-marked-files nil arg) target-directory))
(provide 'mkhtml-htmlize)