is not allowed to be within , we cheat by inserting the
;; DTD for HTML Pro. Ha ha ha.
;; 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.
;; This code should work under XEmacs 19.14+ and GNU Emacs 19.34+.
;; Useful additions by Ron Gut incorporated.
;; Minor change made by Dean Allemang to take out
;; color scaling for use on Windows.
;;; Code:
(require 'cl)
;; 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-tags ""
"*Headers to insert."
:type 'string
:group 'htmlize)
;; We use the HTML Pro DTD by default. Note that under any other DTD
;; it is illegal to specify under .
(defcustom htmlize-doctype
""
"*Doctype of created HTMLs.
Set this to the value of `html-helper-htmldtd-version' for consistency
with psgml-html."
:type 'string
:group 'htmlize)
(defcustom 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."
:type 'hook
:group 'htmlize)
(defcustom 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 HTML
output."
:type 'hook
:group 'customize)
(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)
(mapconcat (lambda (char)
(aref htmlize-character-table char))
string ""))
;; Compatibility
(defsubst htmlize-face-color (face &optional bg-p)
(if (fboundp 'color-instance-rgb-components)
(mapcar (lambda (arg)
(/ arg 1)) ; color scale change -dta
(color-instance-rgb-components
(if bg-p
(face-background-instance face)
(face-foreground-instance face))))
(mapcar (lambda (arg)
(/ arg 1)) ; color scale change -dta
(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)
(save-excursion (set-buffer buf)
(insert str))))
;;;###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))
(let ((newbuf (get-buffer-create "*html*"))
plist next-change face color-name)
(save-excursion
(set-buffer newbuf)
(erase-buffer)
(insert
htmlize-doctype ?\n
"\n\n"
(if (stringp buffer) buffer
(buffer-name buffer))
"\n" htmlize-tags
"\n"
(format "\n"
(htmlize-face-color-string 'default t)
(htmlize-face-color-string 'default))
"\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
(and (consp face)
;; Choose the first face.
(setq face (car face)))
(setq color-name (htmlize-face-color-string face))
(htmlize-insert-string
(concat "") newbuf))
(htmlize-insert-string (htmlize-protect
(buffer-substring (point) next-change))
newbuf)
(when color-name
(htmlize-insert-string "" newbuf))
(goto-char next-change)))
(switch-to-buffer newbuf)
(insert "\n\n\n")
(goto-char (point-min))
(run-hooks 'htmlize-after-hook)))
(provide 'htmlize)
;;; htmlize.el ends here