(require 'htmlize)
(require 'jit-lock)
(put 'modes 'safe-local-variable 'listp)
(defun ee-kill-buffer (buffer-or-name &rest rest)
"For each BUFFER-OR-NAME in the list of arguments kills it if it exists"
(if (get-buffer buffer-or-name) (kill-buffer buffer-or-name))
(if rest (apply 'ee-kill-buffer rest)))
(defun my-replace-regexps-with-inheritance (regexp to &rest rest)
(save-excursion
(while (re-search-forward regexp nil 'no-error)
(replace-match to 'fixedcase nil)))
(if rest (apply 'my-replace-regexps-with-inheritance rest)))
(defun my-replace-strings-with-inheritance (from to &rest rest)
(save-excursion
(while (search-forward from nil 'no-error)
(delete-region (match-beginning 0) (match-end 0))
(insert-and-inherit to))))
(defun my-replace-strings (from to &rest rest)
(save-excursion
(while (search-forward from nil 'no-error)
(delete-region (match-beginning 0) (match-end 0))
(insert to))))
(defvar ee-glyph-shift
(if (fboundp 'make-glyph-code)
(round (log (/ (make-glyph-code 0 'bold)
(face-id 'bold))
2))
19)
"The offset (in bits) of the \"face\" part of a glyph.
Should be 22 in unicode-2 emacs, 19 in pre-unicode-2 emacs.")
(defun ee-glyph-char-mask ()
"The mask used to extract the \"char\" part of a glyph."
(- (ash 1 ee-glyph-shift) 1))
(defun ee-face-alist ()
(mapcar (lambda (face) (cons (face-id face) face)) (face-list)))
(defun ee-faceid-to-face (faceid &optional facealist)
(car (assq faceid (or facealist (face-alist)))))
(defun glyphs-faceglyph-to-facechar (code &optional facealist)
"Convert a character associated to a glyph to a propertized string.
CODE is an integer - the code of the character (e.g. 15 for ^O)."
(let* ((n (aref (aref standard-display-table code) 0))
(faceid (ash n (- ee-glyph-shift)))
(face (ee-faceid-to-face faceid facealist))
(char (logand n (ee-glyph-char-mask)))
(charstr (format "%c" char)))
(add-text-properties 0 1 (list 'face face) charstr)
charstr))
(defun my-replace-glyphs (&optional glyphsstr)
(or glyphsstr (setq glyphsstr " \fM*\233\253\273")) (if (> (length glyphsstr) 0)
(let* ((code (aref glyphsstr 0))
(firstchar (substring glyphsstr 0 1))
(rest (substring glyphsstr 1 nil))
(facealist (ee-face-alist))
(unglyphstr (glyphs-faceglyph-to-facechar code facealist)))
(my-replace-strings firstchar unglyphstr)
(my-replace-glyphs (substring glyphsstr 1 nil)))))
(defun ee-unglyph-0 (glyph)
"Convert GLYPH to a propertized string of length 1.
GLYPH is usually a number whose higher bits encode a face-id.
In recent versions of GNU Emacs (after 2008-02-27) GLYPH can also
be a cons."
(propertize (string (glyph-char glyph)) 'face (glyph-face glyph)))
(defun ee-unglyph-1 (glyph-code)
"Convert a vector of glyphs to a propertized string.
The vector of glyphs is read from the position GLYPH-CODE of
`standard-display-table'."
(let* ((glyphvec (aref standard-display-table glyph-code)))
(apply 'concat (mapcar 'ee-unglyph-0 glyphvec))))
(defun ee-unglyph-alist (glyphs)
"Return an alist with entries of this form: (glyph-code . propertized-string).
The returned alist is used by `ee-unglyph-replace' to speed
up (and simplify) the replacement process."
(mapcar (lambda (glyph-code)
(cons glyph-code (ee-unglyph-1 glyph-code)))
glyphs))
(defun ee-unglyph-replace (&optional glyphs)
"Replace - from point onwards - all glyphs listed in the string GLYPHS.
Return the number of substitutions made."
(setq glyphs (or glyphs " \fM*\233\253\273"))
(let ((re (format "[%s]" glyphs))
(alist (ee-unglyph-alist glyphs))
(n 0))
(while (re-search-forward re nil t)
(setq n (1+ n))
(replace-match (cdr (assoc (char-after (match-beginning 0))
alist))))
n))
(defun ee-unglyph-region (beg end &optional glyphs)
"Replace all glyphs listed in the string GLYPHS, in a region.
Return the number of substitutions made.
This function does not move point."
(interactive "r")
(save-excursion
(save-restriction
(narrow-to-region beg end)
(goto-char (point-min))
(ee-unglyph-replace glyphs))))
(defun my-replace-glyphs (&optional glyphsstr)
(ee-unglyph-region (point-min) (point-max) glyphsstr))
(defvar eeh-text "(text bar)") (defvar eeh-sexp '(sexp bar)) (defvar eeh-target "http://url/bar") (defvar eeh-html "<it>(foo bar not converted)</it>")
(defun eeh-find-anchor (fname &optional anchor &rest rest)
(concat (file-relative-name fname)
".html"
(if anchor (format "#%s" anchor) "")))
(defun eeh-find-eev (fname &optional anchor &rest rest)
(eeh-find-anchor (ee-eevfile fname) anchor))
(defun eeh-find-eevex (fname &optional anchor &rest rest)
(eeh-find-anchor (ee-eevexfile fname) anchor))
(defun eeh-find-angg (fname &optional anchor &rest rest)
(eeh-find-anchor (ee-anggfile fname) anchor))
(defun eeh-find-eevfile (fname &rest rest)
(file-relative-name (ee-eevfile fname)))
(defun eeh-find-eevexfile (fname &rest rest)
(file-relative-name (ee-eevexfile fname)))
(defun eeh-find-anggfile (fname &rest rest)
(file-relative-name (ee-anggfile fname)))
(defun eeh-find-eimage0 (fname &optional nlines nchars perc &rest ignore)
"Htmlize hyperlinks to images. Supports inlining and scaling.
NLINES and NCHARS are ignored, PERC controls whether to inline or scale.
Examples (try with \\[eeh-1flash]):\n
(find-eimage0 \"doc/shot-f3.png\")
-> just a link to the image\n
(find-eimage0 \"doc/shot-f3.png\" nil nil 'anything-not-nil-or-string)
-> \"<img src=\"doc/shot-f3.png\" border=0>\"\n
(find-eimage0 \"doc/shot-f3.png\" nil nil \"40%\")
-> <a href=\"doc/shot-f3.png\">
<img src=\"doc/shot-f3.png\" width=\"40%\" height=\"40%\" border=0>
</a>"
(cond ((null perc) fname) ((stringp perc) (setq eeh-html (format (concat
"<a href=\"%s\">"
"<img src=\"%s\" width=\"%s\" height=\"%s\" border=0>"
"</a>")
fname fname perc perc)))
(t (setq eeh-html (format "<img src=\"%s\" border=0>" fname)))))
(defun eeh-info-dash (url node)
(concat url (replace-regexp-in-string "[ &<>/]" "-" node) ".html"))
(defun eeh-info (manual-and-node)
"Htmlize some hyperlinks to info nodes.
Examples: (eeh-info \"(emacs)Lisp Eval\")
(eeh-info \"(elisp)Scope\")
(eeh-info \"(eintr)Buffer Names\")"
(if (string-match "^(\\([^()]+\\))\\(.*\\)" manual-and-node)
(let ((manual (match-string 1 manual-and-node))
(node (match-string 2 manual-and-node)))
(cond
((equal manual "emacs")
(eeh-info-dash "http://www.gnu.org/software/emacs/manual/html_node/" node))
((equal manual "elisp")
"http://www.gnu.org/software/emacs/elisp-manual/html_node/elisp_toc.html")
((member manual '("eintr" "elintro"))
(eeh-info-dash "http://www.gnu.org/software/emacs/emacs-lisp-intro/html_node/" node))))))
(defun eeh-find-node (node &rest rest)
(eeh-info node))
(defun eeh-find-enode (node &rest rest)
(eeh-info (format "(emacs)%s" node)))
(defun eeh-find-elnode (node &rest rest)
(eeh-info (format "(elisp)%s" node)))
(defun eeh-find-elinode (node &rest rest)
(eeh-info (format "(eintr)%s" node)))
(defun eeh-find-eevanim (fname width height &rest rest)
(setq eeh-html (ee-swf-html-embed fname width height)))
(defvar eeh-functions nil)
(setq eeh-functions
'((find-eimage0 . eeh-find-eimage0)
(find-eev . eeh-find-eev)
(find-eevfile . eeh-find-eevfile)
(find-eevex . eeh-find-eevex)
(find-eevexfile . eeh-find-eevexfile)
(find-angg . eeh-find-angg)
(find-anggfile . eeh-find-anggfile)
(info . eeh-info)
(find-node . eeh-find-node)
(find-enode . eeh-find-enode)
(find-elnode . eeh-find-elnode)
(find-eevanim . eeh-find-eevanim)
))
(defun eeh-sexp-to-html (sexp)
"Take a hyperlink sexp and htmlize it."
(let* ((eeh-target nil)
(eeh-html nil)
(f (car sexp))
(eeh-f (cdr (assoc f eeh-functions))))
(if eeh-f (setq eeh-target (apply eeh-f (cdr sexp))))
(or eeh-html
(if eeh-target
(format "<a href=\"%s\">%s</a>" eeh-target eeh-text)
eeh-text))))
(defun eeh-text-to-html (text)
"Take the textual representation of a hyperlink sexp and htmlize it.
This function invokes `eeh-sexp-to-html', which in its turn uses
the table `eeh-functions' to pass the control to the modified
hyperlink functions (find-node -> eeh-find-node, etc); we use
variables with dynamic scoping to make the definitions of the
modified hyperlink functions shorter."
(let ((eeh-text text)
(eeh-sexp (read text)))
(eeh-sexp-to-html eeh-sexp)))
(defvar eeh-regexp-no-space "^\\(;;\\|#\\) +\\((find-[^\n]+\\)")
(defvar eeh-regexp-space "^\\(;;\\|#\\| \\) +\\((find-[^\n]+\\)")
(defvar eeh-regexp eeh-regexp-space)
(defvar eeh-regexp-sexp-n 2)
(defvar eeh-pairs nil)
(defvar eeh-n 0)
(defun eeh-flash ()
"Show which hyperlink sexps after point will be processed"
(interactive)
(save-excursion
(while (re-search-forward eeh-regexp nil t)
(let* ((b (match-beginning eeh-regexp-sexp-n))
(e (match-end eeh-regexp-sexp-n)))
(eeflash b e)))))
(defun eeh-1flash ()
"Show the next hyperlink sexp after point and how will be htmlized"
(interactive)
(if (re-search-forward eeh-regexp nil t)
(let* ((b (match-beginning eeh-regexp-sexp-n))
(e (match-end eeh-regexp-sexp-n))
(str (buffer-substring-no-properties b e)))
(eeflash b e)
(message "%s" (eeh-text-to-html str)))))
(defun eeh-encode-sexps ()
"Transform all the htmlizable hyperlink sexps after point into \"@nn@\"s"
(interactive)
(setq eeh-pairs nil)
(setq eeh-n 0)
(while (re-search-forward eeh-regexp nil t)
(let* ((b (match-beginning eeh-regexp-sexp-n))
(e (match-end eeh-regexp-sexp-n))
(str (buffer-substring-no-properties b e))
(html (eeh-text-to-html str)))
(when (not (equal str html))
(setq eeh-n (1+ eeh-n))
(let ((newstr (format "@%d@" eeh-n)))
(delete-region b e)
(insert-and-inherit newstr)
(setq eeh-pairs `((,newstr . ,html) . ,eeh-pairs)))))))
(defun eeh-unencode-sexps ()
"Transform all the \"@nn@\"s after point into the corresponding htmlized sexps"
(interactive)
(let ((pairs-left (reverse eeh-pairs)))
(while pairs-left
(let* ((encstr (caar pairs-left))
(html (cdar pairs-left)))
(search-forward encstr)
(delete-region (match-beginning 0) (match-end 0))
(insert-and-inherit html)
(setq pairs-left (cdr pairs-left))))))
(defun my-fontify-whole-buffer ()
"Fontify the whole buffer. BTW, it took me *ages* to discover how to do this."
(interactive)
(font-lock-mode 1)
(jit-lock-fontify-now))
(defun some-extra-replacements ()
(interactive)
(my-replace-regexps-with-inheritance
(concat "\\(<span class=\"\\(function\\|variable\\)-name\">\\)"
"\\([-_A-Za-z0-9]+\\)"
"\\(</span>\\)")
"<a name=\"\\3\">\\1\\3\\4</a>"))
(defun my-htmlize-buffer (&optional bufname glyphsstr)
(interactive)
(or bufname (setq bufname (buffer-name)))
(let ((ee-buffer-name (concat bufname " (htmlized)")))
(find-estring (buffer-substring (point-min) (point-max)))
(kill-region (point-min) (point-max)) (yank))
(ee-kill-buffer (concat bufname ".html"))
(goto-char (point-min))
(my-replace-glyphs glyphsstr) (eeh-encode-sexps) (switch-to-buffer (htmlize-buffer)) (goto-char (point-min))
(some-extra-replacements) (eeh-unencode-sexps) )
(defun my-htmlize-this-file (&optional glyphsstr)
(interactive)
(let ((bufname (file-name-nondirectory (buffer-file-name))))
(my-fontify-whole-buffer)
(my-htmlize-buffer bufname glyphsstr)
(write-file (concat bufname ".html"))))
(defun my-outline-colors ()
(interactive)
(require 'outline)
(set-face-foreground 'outline-1 "OrangeRed")
(set-face-foreground 'outline-2 "Goldenrod2")
(set-face-foreground 'outline-3 "LimeGreen")
(set-face-foreground 'outline-4 "Dodger Blue"))
(defun change-log-mode-face-hack ()
"Because htmlize.el doesn't follow inherits in faces."
(require 'add-log)
(mapc (lambda (face)
(set-face-foreground
face
(face-attribute face :foreground nil 'default)))
'(change-log-date-face
change-log-email-face
change-log-file-face
change-log-function-face
change-log-list-face
change-log-name-face)))
(defun htmlize-eev-files ()
(interactive)
(my-outline-colors)
(if (not window-system)
(error "Running htmlize outside X would produce ugly colors"))
(let ((eeh-regexp "^\\(.*\\)[ \t]\\((find-[^\n]+)\\)$"))
(find-eev "EMACS") (my-htmlize-this-file)
(find-eev "NEWS") (my-htmlize-this-file)
(find-eev "README") (my-htmlize-this-file)
(find-eev "doc/keys.e") (my-htmlize-this-file))
(let ((eeh-regexp "^\\(.*;.*\\)[ \t]\\((find-[^\n]+)\\)$"))
(find-eev "eev.el") (my-htmlize-this-file)
(find-eev "eev-all.el") (my-htmlize-this-file)
(find-eev "eev-bounded.el") (my-htmlize-this-file)
(find-eev "eev-compose.el") (my-htmlize-this-file)
(find-eev "eev-glyphs.el") (my-htmlize-this-file)
(find-eev "eev-insert.el") (my-htmlize-this-file)
(find-eev "eev-langs.el") (my-htmlize-this-file)
(find-eev "eev-sshot.el") (my-htmlize-this-file)
(find-eev "eev-steps.el") (my-htmlize-this-file)
(find-eev "eev-browse-url.el") (my-htmlize-this-file)
(find-eev "eev-mini.el") (my-htmlize-this-file)
(find-eev "eev-mini-steps.el") (my-htmlize-this-file)
(find-eev "htmlize-all.el") (my-htmlize-this-file)
(find-eev "htmlize-eev.el") (my-htmlize-this-file)
(require 'eev-math-glyphs)
(eev-math-glyphs-edrx)
(let ((g " \fM*\233\253\273\336\345\306\330\360\333\317\247\256\264\266\375\316\361\250\335\242\314\376\305\277\202\251\321\245\244\270\367\356\255\243\246\257\313\320"))
(find-eev "eev-math-glyphs.el") (my-htmlize-this-file g) )
(change-log-mode-face-hack)
(find-eev "ChangeLog") (my-htmlize-this-file))
(let ((eeh-regexp "^\\(.*\\)[ \t]\\((find-[^\n]+)\\)$"))
(find-eev "anim/channels.anim") (my-htmlize-this-file)
(find-eev "anim/gdb.anim") (my-htmlize-this-file))
(let ((eeh-regexp "^\\(.*#.*\\)[ \t]\\((find-[^\n]+)\\)$"))
(find-eev "eeg") (my-htmlize-this-file)
(find-eev "eeg4") (my-htmlize-this-file)
(find-eev "eegchannel") (my-htmlize-this-file)
(find-eev "eev-rctool") (my-htmlize-this-file) ))
(defun htmlize-eev-files-then-quit ()
(interactive)
(htmlize-eev-files-then-quit)
(save-buffers-kill-emacs))
' (find-sh "cd ~/eev-current/; ls *.el")
' (find-sh0 "rm -Rv /tmp/ehtml/; mkdir /tmp/ehtml/")
' (require 'htmlize)
' (let ((default-directory (ee-expand "~/eev-current/")))
(htmlize-many-files
'("compose.el"
"eev-browse-url.el"
"eev-compose.el"
"eev-glyphs.el"
"eev-insert.el"
"eev-langs.el"
"eev-math-glyphs.el"
"eev-steps.el"
"eev.el"
"glyphs.el"
"htmlize-all.el"
"htmlize-eev.el")
"/tmp/ehtml/"))
' (find-fline "/tmp/ehtml/")
' (find-firefox (eeurl-u-to-f "/tmp/ehtml/eev.el.html"))
' (find-firefox (eeurl-u-to-f "~/eev-current/eev.el.html"))
'
(defun htmlize-file (file &optional target)
"Load FILE, fontify it, convert it to HTML, and save the result.
Contents of FILE are inserted into a temporary buffer, whose major mode
is set with `normal-mode' as appropriate for the file type. The buffer
is subsequently fontified with `font-lock' and converted to HTML. Note
that, unlike `htmlize-buffer', this function explicitly turns on
font-lock. If a form of highlighting other than font-lock is desired,
please use `htmlize-buffer' directly on buffers so highlighted.
Buffers currently visiting FILE are unaffected by this function. The
function does not change current buffer or move the point.
If TARGET is specified and names a directory, the resulting file will be
saved there instead of to FILE's directory. If TARGET is specified and
does not name a directory, it will be used as output file name."
(interactive (list (read-file-name
"HTML-ize file: "
nil nil nil (and (buffer-file-name)
(file-name-nondirectory
(buffer-file-name))))))
(let ((output-file (if (and target (not (file-directory-p target)))
target
(expand-file-name
(htmlize-make-file-name (file-name-nondirectory file))
(or target (file-name-directory file)))))
(font-lock-mode nil)
(font-lock-auto-fontify nil)
(global-font-lock-mode nil)
(font-lock-maximum-size nil)
(font-lock-support-mode nil))
(with-temp-buffer
(insert-file-contents file)
(let ((buffer-file-name file))
(normal-mode)
(font-lock-mode 1)
(unless font-lock-mode
(font-lock-fontify-buffer))
(with-current-buffer (htmlize-buffer-1)
(unwind-protect
(progn
(run-hooks 'htmlize-file-hook)
(write-region (point-min) (point-max) output-file))
(kill-buffer (current-buffer)))))))
nil)
'
(defun htmlize-many-files (files &optional target-directory)
"Convert FILES to HTML and save the corresponding HTML versions.
FILES should be a list of file names to convert. This function calls
`htmlize-file' on each file; see that function for details. When
invoked interactively, you are prompted for a list of files to convert,
terminated with RET.
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))))
(and target-directory
(not (file-directory-p target-directory))
(error "target-directory must name a directory: %s" target-directory))
(dolist (file files)
(htmlize-file file target-directory)))
(provide 'htmlize-eev)