1 ;;; htmlfontify.el --- htmlise a buffer/source tree with optional hyperlinks
3 ;; Copyright (C) 2002, 2003, 2009 Free Software Foundation, Inc.
5 ;; Emacs Lisp Archive Entry
6 ;; Package: htmlfontify
7 ;; Filename: htmlfontify.el
9 ;; Keywords: html, hypermedia, markup, etags
10 ;; Author: Vivek Dasmohapatra <vivek@etla.org>
11 ;; Maintainer: Vivek Dasmohapatra <vivek@etla.org>
12 ;; Created: 2002-01-05
13 ;; Description: htmlise a buffer/source tree with optional hyperlinks
14 ;; URL: http://rtfm.etla.org/emacs/htmlfontify/
15 ;; Compatibility: Emacs23, Emacs22
16 ;; Incompatibility: Emacs19, Emacs20, Emacs21
17 ;; Last Updated: Thu 2009-11-19 01:31:21 +0000
19 ;; This file is part of GNU Emacs.
21 ;; GNU Emacs is free software: you can redistribute it and/or modify
22 ;; it under the terms of the GNU General Public License as published by
23 ;; the Free Software Foundation, either version 3 of the License, or
24 ;; (at your option) any later version.
26 ;; GNU Emacs is distributed in the hope that it will be useful,
27 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
28 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
29 ;; GNU General Public License for more details.
31 ;; You should have received a copy of the GNU General Public License
32 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
35 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
36 ;; I have made some changes to make it work for Emacs 22. A lot of
37 ;; small bug fixes related to the format of text and overlay
38 ;; properties (which might have changed since the beginning of 2003
39 ;; when this file was originally written).
41 ;; The function `hfy-face-at' currently carries much of the burden of
42 ;; my lacking understanding of the formats mentioned above and should
43 ;; need some knowledgeable help.
45 ;; Another thing that maybe could be fixed is that overlay background
46 ;; colors which are now only seen where there is text (in the XHTML
47 ;; output). A bit of CSS tweaking is necessary there.
49 ;; The face 'default has a value :background "SystemWindow" for the
50 ;; background color. There is no explicit notion that this should be
51 ;; considered transparent, but I have assumed that it could be handled
52 ;; like if it was here. (I am unsure that background and foreground
53 ;; priorities are handled ok, but it looks ok in my tests now.)
55 ;; 2007-12-27 Lennart Borgman
56 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
58 ;; Here's some elisp code to html-pretty-print an Emacs buffer, preserving
59 ;; the Emacs syntax/whatever highlighting. It also knows how to drive etags
60 ;; (exuberant-ctags or Emacs etags) and hyperlink the code according
61 ;; to its (etags') output.
63 ;; NOTE: Currently the hyperlinking code only knows how to drive GNU find
64 ;; and the exuberant and GNU variants of etags : I do not know of any other
65 ;; etags variants, but mechanisms have been provided to allow htmlfontify
66 ;; to be taught how to drive them. As long as your version of find has
67 ;; the -path test and is reasonably sane, you should be fine.
69 ;; A sample of the htmlfontified / hyperlinked output of this module can be
70 ;; found at http://rtfm.etla.org/sql/dbishell/src/ - it's not perfect, but
71 ;; it's a hell of a lot faster and more thorough than I could hope to be
72 ;; doing this by hand.
74 ;; some user / horrified onlooker comments:
75 ;; What? No! There's something deeply wrong here... (R. Shufflebotham)
76 ;; You're a freak. (D. Silverstone)
77 ;; Aren't we giving you enough to do? (J. Busuttil)
78 ;; You're almost as messed up as Lexx is! (N. Graves-Morris)
81 ;; Changes: moved to changelog (CHANGES) file.
84 (eval-when-compile (require 'cl
))
86 ;; (`facep' `face-attr-construct' `x-color-values' `color-values' `face-name')
88 ;; (`defgroup' `defcustom')
90 ;; (`font-lock-fontify-region')
94 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
95 ;; I want these - can't be bothered requiring all of cl though.
96 (if (not (fboundp 'caddr
))
98 "Return the `car' of the `cddr' of LIST."
101 (if (not (fboundp 'cadddr
))
103 "Return the `cadr' of the `cddr' of LIST."
105 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
108 'htmlfontify-load-rgb-file
110 "Load an rgb.txt file for colour name -> rgb translation purposes."
114 'htmlfontify-unload-rgb-file
116 "Unload the current colour name -> rgb translation map."
120 'hfy-fallback-colour-values
122 "Use a fallback method for obtaining the rgb values for a colour."
126 (defconst htmlfontify-version
0.21)
128 (defconst hfy-meta-tags
129 (format "<meta name=\"generator\" content=\"emacs %s; htmlfontify %0.2f\" />"
130 emacs-version htmlfontify-version
)
131 "The generator meta tag for this version of htmlfontify.")
133 (defconst htmlfontify-manual
"Htmlfontify Manual"
134 "Copy and convert buffers and files to html, adding hyperlinks between files
135 \(driven by etags\) if requested.
136 \nInteractive functions:
138 `htmlfontify-run-etags'
139 `htmlfontify-copy-and-link-dir'
140 `htmlfontify-load-rgb-file'
141 `htmlfontify-unload-rgb-file'\n
143 fontify a file you have open: M-x htmlfontify-buffer
144 prepare the etags map for a directory: M-x htmlfontify-run-etags
145 copy a directory, fontifying as you go: M-x htmlfontify-copy-and-link-dir\n
146 The following might be useful when running non-windowed or in batch mode:
147 \(note that they shouldn't be necessary - we have a built in map\)\n
148 load an X11 style rgb.txt file: M-x htmlfontify-load-rgb-file
149 unload the current rgb.txt file: M-x htmlfontify-unload-rgb-file\n
150 And here's a programmatic example:\n
151 \(defun rtfm-build-page-header \(file style\)
152 \(format \"#define TEMPLATE red+black.html
154 #include <build/menu-dirlist|>\\n
155 html-css-url := /css/red+black.css
156 title := rtfm.etla.org \( %s / src/%s \)
158 head <=STYLESHEET;\\n
161 main-title := rtfm / %s / src/%s\\n
162 main-content <=MAIN_CONTENT;\\n\" rtfm-section file style rtfm-section file\)\)
164 \(defun rtfm-build-page-footer \(file\) \"\\nMAIN_CONTENT\\n\"\)
166 \(defun rtfm-build-source-docs \(section srcdir destdir\)
168 \"s section[eg- emacs / p4-blame]:\\nD source-dir: \\nD output-dir: \"\)
169 \(require 'htmlfontify\)
170 \(hfy-load-tags-cache srcdir\)
171 \(let \(\(hfy-page-header 'rtfm-build-page-header\)
172 \(hfy-page-footer 'rtfm-build-page-footer\)
173 \(rtfm-section section\)
174 \(hfy-index-file \"index\"\)\)
175 \(htmlfontify-run-etags srcdir\)
176 \(htmlfontify-copy-and-link-dir srcdir destdir \".src\" \".html\"\)\)\)")
178 (defgroup htmlfontify nil
179 "Copy and convert buffers and files to html, adding hyperlinks between
180 files \(driven by etags\) if requested.\n
181 See: `htmlfontify-manual'"
185 (defcustom hfy-page-header
'hfy-default-header
186 "Function called with two arguments \(the filename relative to the top
187 level source directory being etag\'d and fontified), and a string containing
188 the <style>...</style> text to embed in the document- the string returned will
189 be used as the header for the htmlfontified version of the source file.\n
190 See also: `hfy-page-footer'"
192 ;; FIXME: Why place such a :tag everywhere? Isn't it imposing your
193 ;; own Custom preference on your users? --Stef
197 (defcustom hfy-split-index nil
198 "Whether or not to split the index `hfy-index-file' alphabetically
199 on the first letter of each tag. Useful when the index would otherwise
200 be large and take a long time to render or be difficult to navigate."
205 (defcustom hfy-page-footer
'hfy-default-footer
206 "As `hfy-page-header', but generates the output footer
207 \(and takes only 1 argument, the filename\)."
212 (defcustom hfy-extn
".html"
213 "File extension used for output files."
218 (defcustom hfy-src-doc-link-style
"text-decoration: underline;"
219 "String to add to the \'<style> a\' variant of an htmlfontify css class."
221 :tag
"src-doc-link-style"
224 (defcustom hfy-src-doc-link-unstyle
" text-decoration: none;"
225 "Regex to remove from the <style> a variant of an htmlfontify css class."
227 :tag
"src-doc-link-unstyle"
230 (defcustom hfy-link-extn nil
231 "File extension used for href links - Useful where the htmlfontify
232 output files are going to be processed again, with a resulting change
233 in file extension. If nil, then any code using this should fall back
236 :tag
"link-extension"
237 :type
'(choice string
(const nil
)))
239 (defcustom hfy-link-style-fun
'hfy-link-style-string
240 "Set this to a function, which will be called with one argument
241 \(a \"{ foo: bar; ...}\" css style-string\) - it should return a copy of
242 its argument, altered so as to make any changes you want made for text which
243 is a hyperlink, in addition to being in the class to which that style would
244 normally be applied."
246 :tag
"link-style-function"
249 (defcustom hfy-index-file
"hfy-index"
250 "Name \(sans extension\) of the tag definition index file produced during
251 fontification-and-hyperlinking."
256 (defcustom hfy-instance-file
"hfy-instance"
257 "Name \(sans extension\) of the tag usage index file produced during
258 fontification-and-hyperlinking."
263 (defcustom hfy-html-quote-regex
"\\(<\\|\"\\|&\\|>\\)"
264 "Regex to match \(with a single back-reference per match\) strings in HTML
265 which should be quoted with `hfy-html-quote' \(and `hfy-html-quote-map'\)
268 :tag
"html-quote-regex"
271 (define-obsolete-variable-alias 'hfy-init-kludge-hooks
'hfy-init-kludge-hook
273 (defcustom hfy-init-kludge-hook
'(hfy-kludge-cperl-mode)
274 "List of functions to call when starting htmlfontify-buffer to do any
275 kludging necessary to get highlighting modes to bahave as you want, even
276 when not running under a window system."
278 :tag
"init-kludge-hooks"
281 (defcustom hfy-post-html-hooks nil
282 "List of functions to call after creating and filling the html buffer.
283 These functions will be called with the html buffer as the current buffer"
285 :tag
"post-html-hooks"
286 :options
'(set-auto-mode)
289 (defcustom hfy-default-face-def nil
290 "Fallback `defface' specification for the face \'default, used when
291 `hfy-display-class' has been set \(the normal htmlfontify way of extracting
292 potentially non-current face information doesn\'t necessarily work for
294 Example: I customise this to:\n
295 \(\(t :background \"black\" :foreground \"white\" :family \"misc-fixed\"\)\)"
297 :tag
"default-face-definition"
300 (defcustom hfy-etag-regex
(concat ".*"
301 "\x7f" "\\([^\x01\n]+\\)"
302 "\x01" "\\([0-9]+\\)"
304 "\\|" ".*\x7f[0-9]+,[0-9]+$")
305 "Regex used to parse an etags entry: must have 3 subexps, corresponding,
309 3 - The char \(point\) at which the tag occurs."
314 (defcustom hfy-html-quote-map
'(("\"" """)
318 "Alist of char -> entity mappings used to make the text html-safe."
320 :tag
"html-quote-map"
321 :type
'(alist :key-type
(string)))
323 (defconst hfy-e2x-etags-cmd
"for src in `find . -type f`;
327 *.ad[absm]|*.[CFHMSacfhlmpsty]|*.def|*.in[cs]|*.s[as]|*.src|*.cc|\\
328 *.hh|*.[chy]++|*.[ch]pp|*.[chy]xx|*.pdb|*.[ch]s|*.[Cc][Oo][Bb]|\\
329 *.[eh]rl|*.f90|*.for|*.java|*.[cem]l|*.clisp|*.lisp|*.[Ll][Ss][Pp]|\\
330 [Mm]akefile*|*.pas|*.[Pp][LlMm]|*.psw|*.lm|*.pc|*.prolog|*.oak|\\
331 *.p[sy]|*.sch|*.scheme|*.[Ss][Cc][Mm]|*.[Ss][Mm]|*.bib|*.cl[os]|\\
332 *.ltx|*.sty|*.TeX|*.tex|*.texi|*.texinfo|*.txi|*.x[bp]m|*.yy|\\
343 SHEBANG=`head -n1 ${src} | grep '#!' -c`;
344 if [ ${SHEBANG} -eq 1 ];
354 (defconst hfy-etags-cmd-alist-default
355 `(("emacs etags" .
,hfy-e2x-etags-cmd
)
356 ("exuberant ctags" .
"%s -R -f -" )))
358 (defcustom hfy-etags-cmd-alist
359 hfy-etags-cmd-alist-default
360 "Alist of possible shell commands that will generate etags output that
361 `htmlfontify' can use. \'%s\' will be replaced by `hfy-etags-bin'."
363 :tag
"etags-cmd-alist"
364 :type
'(alist :key-type
(string) :value-type
(string)) ))
366 (defcustom hfy-etags-bin
"etags"
367 "Location of etags binary (we begin by assuming it\'s in your path).\n
368 Note that if etags is not in your path, you will need to alter the shell
369 commands in `hfy-etags-cmd-alist'."
374 (defcustom hfy-shell-file-name
"/bin/sh"
375 "Shell (bourne or compatible) to invoke for complex shell operations."
377 :tag
"shell-file-name"
380 (defun hfy-which-etags ()
381 "Return a string indicating which flavour of etags we are using."
382 (let ((v (shell-command-to-string (concat hfy-etags-bin
" --version"))))
383 (cond ((string-match "exube" v
) "exuberant ctags")
384 ((string-match "GNU E" v
) "emacs etags" )) ))
386 (defcustom hfy-etags-cmd
387 (eval-and-compile (cdr (assoc (hfy-which-etags) hfy-etags-cmd-alist
)))
388 "The etags equivalent command to run in a source directory to generate a tags
389 file for the whole source tree from there on down. The command should emit
390 the etags output on stdout.\n
391 Two canned commands are provided - they drive Emacs\' etags and
392 exuberant-ctags\' etags respectively."
395 :type
(eval-and-compile
396 (let ((clist (list '(string))))
397 (dolist (C hfy-etags-cmd-alist
)
398 (push (list 'const
:tag
(car C
) (cdr C
)) clist
))
399 (cons 'choice clist
)) ))
401 (defcustom hfy-istext-command
"file %s | sed -e 's@^[^:]*:[ \t]*@@'"
402 "Command to run with the name of a file, to see whether it is a text file
403 or not. The command should emit a string containing the word \'text\' if
404 the file is a text file, and a string not containing \'text\' otherwise."
406 :tag
"istext-command"
409 (defcustom hfy-find-cmd
410 "find . -type f \\! -name \\*~ \\! -name \\*.flc \\! -path \\*/CVS/\\*"
411 "Find command used to harvest a list of files to attempt to fontify."
416 (defcustom hfy-display-class nil
417 "Display class to use to determine which display class to use when
418 calculating a face\'s attributes. This is useful when, for example, you
419 are running Emacs on a tty or in batch mode, and want htmlfontify to have
420 access to the face spec you would use if you were connected to an X display.\n
421 Some valid class specification elements are:\n
423 \'\(class grayscale\)
424 \'\(background dark\)
425 \'\(background light\)
430 Multiple values for a tag may be combined, to indicate that any one or more
431 of these values in the specification key constitutes a match, eg:\n
432 \'\(\(class color grayscale\) \(type tty\)\) would match any of:\n
433 \'\(\(class color\)\)
434 \'\(\(class grayscale\)\)
435 \'\(\(class color grayscale\)\)\)
436 \'\(\(class color foo\)\)
438 \'\(\(type tty\) \(class color\)\)\n
440 :type
'(alist :key-type
(symbol) :value-type
(symbol))
443 :options
'((type (choice (const :tag
"X11" x-toolkit
)
444 (const :tag
"Terminal" tty
)
445 (const :tag
"Lucid Toolkit" lucid
)
446 (const :tag
"Motif Toolkit" motif
)))
448 (class (choice (const :tag
"Colour" color
)
449 (const :tag
"Greyscale" grayscale
)))
451 (background (choice (const :tag
"Dark" dark
)
452 (const :tag
"Bright" light
))) ))
454 (defcustom hfy-optimisations
(list 'keep-overlays
)
455 "Optimisations to turn on: So far, the following have been implemented:\n
456 merge-adjacent-tags: If two (or more) span tags are adjacent, identical and
457 separated by nothing more than whitespace, they will
458 be merged into one span.
459 zap-comment-links : Suppress hyperlinking of tags found in comments.
460 zap-string-links : Suppress hyperlinking of tags found in strings.
461 div-wrapper : Add <div class=\"default\"> </div> tags around the
463 keep-overlays : More of a bell \(or possibly whistle\) than an
464 optimisation - If on, preserve overlay highlighting
465 \(cf ediff or goo-font-lock\) as well as basic faces\n
466 And the following are planned but not yet available:\n
467 kill-context-leak : Suppress hyperlinking between files highlighted by
469 Note: like compiler optimisations, these optimise the _output_ of the code,
470 not the processing of the source itself, and are therefore likely to slow
471 htmlfontify down, at least a little. Except for skip-refontification,
472 which can never slow you down, but may result in incomplete fontification."
473 :type
'(set (const :tag
"merge-adjacent-tags" merge-adjacent-tags
)
474 (const :tag
"zap-comment-links" zap-comment-links
)
475 (const :tag
"zap-string-links" zap-string-links
)
476 (const :tag
"skip-refontification" skip-refontification
)
477 (const :tag
"kill-context-leak" kill-context-leak
)
478 (const :tag
"div-wrapper" div-wrapper
)
479 (const :tag
"keep-overlays" keep-overlays
))
481 :tag
"optimisations")
483 (defvar hfy-tags-cache nil
484 "Alist of the form:\n
485 \(\(\"/src/dir/0\" . tag-hash0\) \(\"/src/dir/1\" tag-hash1\) ...\)\n
486 Each tag hash entry then contains entries of the form:\n
487 \"tag_string\" => ((\"file/name.ext\" line char) ... )\n
488 ie an alist mapping \(relative\) file paths to line and character offsets.\n
489 See `hfy-load-tags-cache'.")
491 (defvar hfy-tags-sortl nil
492 "Alist of the form \(\(\"/src/dir\" . (tag0 tag1 tag2)\) ... \)\n
493 Where the tags are stored in descending order of length.\n
494 See `hfy-load-tags-cache'.")
496 (defvar hfy-tags-rmap nil
497 "Alist of the form \(\(\"/src/dir\" . tag-rmap-hash\)\)\n
498 Where tag-rmap-hash has entries of the form:
499 \"tag_string\" => ( \"file/name.ext\" line char )
500 Unlike `hfy-tags-cache' these are the locations of occurrences of
501 tagged items, not the locations of their definitions.")
503 (defvar hfy-style-assoc
'please-ignore-this-line
504 "An assoc representing/describing an Emacs face.
505 Properties may be repeated, In which case later properties should be
506 treated as if they were inherited from a \'parent\' font.
507 \(For some properties, only the first encountered value is of any importance,
508 for others the values might be cumulative, and for others they might be
509 cumulative in a complex way).\n
511 \(hfy-face-to-style 'default\) =>
512 \(\(\"background\" . \"rgb\(0, 0, 0\)\"\)
513 \(\"color\" . \"rgb\(255, 255, 255\)\"\)
514 \(\"font-style\" . \"normal\"\)
515 \(\"font-weight\" . \"500\"\)
516 \(\"font-stretch\" . \"normal\"\)
517 \(\"font-family\" . \"misc-fixed\"\)
518 \(\"font-size\" . \"13pt\"\)
519 \(\"text-decoration\" . \"none\"\)\)\n
520 \(hfy-face-to-style 'Info-title-3-face\) =>
521 \(\(\"font-weight\" . \"700\"\)
522 \(\"font-family\" . \"helv\"\)
523 \(\"font-size\" . \"120%\"\)
524 \(\"text-decoration\" . \"none\"\)\)\n")
526 (defvar hfy-sheet-assoc
'please-ignore-this-line
527 "An assoc with elements of the form (face-name style-name . stlye-string):\n
528 '\(\(default \"default\" . \"{background: black;color: white}\"\)
529 \(font-lock-string-face \"string\" . \"{color: rgb\(64,224,208\)}\"\)\)" )
531 (defvar hfy-facemap-assoc
'please-ignore-this-line
532 "An assoc of \(point . FACE-SYMBOL\) or \(point . DEFFACE-LIST\)
533 and (point . 'end) elements, in descending order of point value
534 \(ie from the file's end to its beginning\).\n
535 The map is in reverse order because inserting a <style> tag \(or any other
536 string) at POINT invalidates the map for all entries with a greater value of
537 point. By traversing the map from greatest to least POINT, we still invalidate
538 the map as we go, but only those points we have already dealt with \( and
539 therefore no longer care about \) will be invalid at any time.\n
541 \(64744 . font-lock-comment-face\)
543 \(64722 . font-lock-string-face\)
545 \(64623 . font-lock-string-face\)
547 \(64446 . font-lock-keyword-face\)
549 \(64395 . font-lock-constant-face\)
551 \(64386 . font-lock-keyword-face\)
553 ;; big similar section elided. You get the idea.
554 \(4285 . font-lock-constant-face\)
556 \(4221 . font-lock-comment-face\)
558 \(4197 . font-lock-constant-face\)
560 \(1 . font-lock-comment-face\)\)")
562 (defvar hfy-tmpfont-stack nil
563 "An alist of derived fonts resulting from overlays.")
565 (defconst hfy-hex-regex
"[0-9A-Fa-f]")
567 (defconst hfy-triplet-regex
569 "\\(" hfy-hex-regex hfy-hex-regex
"\\)"
570 "\\(" hfy-hex-regex hfy-hex-regex
"\\)"
571 "\\(" hfy-hex-regex hfy-hex-regex
"\\)"))
573 (defun hfy-interq (set-a set-b
)
574 "Return the intersection \(using `eq'\) of 2 lists SET-A and SET-B."
575 (let ((sa set-a
) (interq nil
) (elt nil
))
579 (if (memq elt set-b
) (setq interq
(cons elt interq
)))) interq
))
581 (defun hfy-colour-vals (colour)
582 "Where COLOUR is a colour name or #XXXXXX style triplet, return a
583 list of 3 (16 bit) rgb values for said colour.\n
584 If a window system is unavailable, calls `hfy-fallback-colour-values'."
585 (if (string-match hfy-triplet-regex colour
)
587 (lambda (x) (* (string-to-number (match-string x colour
) 16) 257))
589 ;;(message ">> %s" colour)
591 (if (fboundp 'color-values
)
592 (color-values colour
)
593 ;;(message "[%S]" window-system)
594 (x-color-values colour
))
595 ;; blarg - tty colours are no good - go fetch some X colours:
596 (hfy-fallback-colour-values colour
))))
598 (defvar hfy-cperl-mode-kludged-p nil
)
600 (defun hfy-kludge-cperl-mode ()
601 "CPerl mode does its damndest not to do some of its fontification when not
602 in a windowing system - try to trick it..."
603 (if (not hfy-cperl-mode-kludged-p
)
604 (progn (if (not window-system
)
605 (let ((window-system 'htmlfontify
))
606 (eval-and-compile (require 'cperl-mode
))
607 (setq cperl-syntaxify-by-font-lock t
)))
608 (setq hfy-cperl-mode-kludged-p t
))) )
610 (defun hfy-opt (symbol) "Is option SYMBOL set." (memq symbol hfy-optimisations
))
612 (defun hfy-default-header (file style
)
613 "Default value for `hfy-page-header'.
614 FILE is the name of the file.
615 STYLE is the inline CSS stylesheet (or tag referring to an external sheet)."
616 ;; (format "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
617 ;; <html>\n <head>\n <title>%s</title>\n %s\n </head>\n <body>\n" file style))
618 (format "<?xml version=\"1.0\" encoding=\"utf-8\"?>
619 <!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\"
620 \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">
621 <html xmlns=\"http://www.w3.org/1999/xhtml\">
625 <script type=\"text/javascript\"><!--
626 // this function is needed to work around
627 // a bug in IE related to element attributes
628 function hasClass(obj)
631 if (obj.getAttributeNode(\"class\") != null)
633 result = obj.getAttributeNode(\"class\").value;
640 // the flag we'll use to keep track of
641 // whether the current row is odd or even
644 // if arguments are provided to specify the colours
645 // of the even & odd rows, then use the them;
646 // otherwise use the following defaults:
647 var evenColor = arguments[1] ? arguments[1] : \"#fff\";
648 var oddColor = arguments[2] ? arguments[2] : \"#ddd\";
650 // obtain a reference to the desired table
651 // if no such table exists, abort
652 var table = document.getElementById(id);
653 if (! table) { return; }
655 // by definition, tables can have more than one tbody
656 // element, so we'll have to get the list of child
658 var tbodies = table.getElementsByTagName(\"tbody\");
660 // and iterate through them...
661 for (var h = 0; h < tbodies.length; h++)
663 // find all the <tr> elements...
664 var trs = tbodies[h].getElementsByTagName(\"tr\");
666 // ... and iterate through them
667 for (var i = 0; i < trs.length; i++)
669 // avoid rows that have a class attribute
670 // or backgroundColor style
671 if (! hasClass(trs[i]) &&
672 ! trs[i].style.backgroundColor)
674 // get all the cells in this row...
675 var tds = trs[i].getElementsByTagName(\"td\");
677 // and iterate through them...
678 for (var j = 0; j < tds.length; j++)
682 // avoid cells that have a class attribute
683 // or backgroundColor style
684 if (! hasClass(mytd) &&
685 ! mytd.style.backgroundColor)
687 mytd.style.backgroundColor =
688 even ? evenColor : oddColor;
692 // flip from odd to even, or vice-versa
698 function toggle_invis( name )
703 { var classname = node.id;
705 { var classbase = classname.substr( 0, name.length );
706 if( classbase == name ) { return NodeFilter.FILTER_ACCEPT; } }
707 return NodeFilter.FILTER_SKIP; } };
708 var walker = document.createTreeWalker( document.body ,
709 NodeFilter.SHOW_ELEMENT ,
712 while( walker.nextNode() )
714 var e = walker.currentNode;
715 if( e.style.display == \"none\" ) { e.style.display = \"inline\"; }
716 else { e.style.display = \"none\"; }
721 <body onload=\"stripe('index'); return true;\">\n"
724 (defun hfy-default-footer (file)
725 "Default value for `hfy-page-footer'.
726 FILE is the name of the file being rendered, in case it is needed."
727 "\n </body>\n</html>\n")
729 (defun hfy-link-style-string (style-string)
730 "Replace the end of a css style declaration STYLE-STRING with the contents
731 of the variable `hfy-src-doc-link-style', removing text matching the regex
732 `hfy-src-doc-link-unstyle' first, if necessary."
733 ;;(message "hfy-colour-vals");;DBUG
734 (if (string-match hfy-src-doc-link-unstyle style-string
)
735 (setq style-string
(replace-match "" 'fixed-case
'literal style-string
)))
736 (if (and (not (string-match hfy-src-doc-link-style style-string
))
737 (string-match "} *$" style-string
))
738 (concat (replace-match hfy-src-doc-link-style
741 style-string
) " }") style-string
))
743 ;; utility functions - cast emacs style specification values into their
745 (defun hfy-triplet (colour)
746 "Takes a COLOUR name \(string\) and return a CSS rgb(R, G, B) triplet string.
747 Uses the definition of \"white\" to map the numbers to the 0-255 range, so
748 if you\'ve redefined white, \(esp if you've redefined it to have a triplet
749 member lower than that of the colour you are processing, strange things
751 ;;(message "hfy-colour-vals");;DBUG
752 (let ((white (mapcar (lambda (I) (float (1+ I
))) (hfy-colour-vals "white")))
753 (rgb16 (mapcar (lambda (I) (float (1+ I
))) (hfy-colour-vals colour
))))
755 ;;(apply 'format "rgb(%d, %d, %d)"
756 ;; Use #rrggbb instead, it is smaller
757 (apply 'format
"#%02x%02x%02x"
763 (defun hfy-family (family) (list (cons "font-family" family
)))
764 (defun hfy-bgcol (colour) (list (cons "background" (hfy-triplet colour
))))
765 (defun hfy-colour (colour) (list (cons "color" (hfy-triplet colour
))))
766 (defun hfy-width (width) (list (cons "font-stretch" (symbol-name width
))))
768 (defcustom hfy-font-zoom
1.05
769 "Font scaling from Emacs to HTML."
773 (defun hfy-size (height)
774 "Derive a CSS font-size specifier from an Emacs font :height attribute HEIGHT.
775 Does not cope with the case where height is a function to be applied to
776 the height of the underlying font."
779 ;;(t (cons "font-size" ": 1em"))
781 (cons "font-size" (format "%d%%" (* (* hfy-font-zoom height
) 100))))
783 (cons "font-size" (format "%dpt" (/ (* hfy-font-zoom height
) 10 )))) )) )
785 (defun hfy-slant (slant)
786 "Derive a font-style css specifier from the Emacs :slant attribute SLANT:
787 CSS does not define the reverse-* styles, so just maps those to the
789 (list (cons "font-style"
790 (or (cdr (assq slant
'((italic .
"italic")
791 (reverse-italic .
"italic" )
792 (oblique .
"oblique")
793 (reverse-oblique .
"oblique"))))
796 (defun hfy-weight (weight)
797 "Derive a font-weight css specifier from an Emacs weight spec symbol WEIGHT."
798 (list (cons "font-weight" (cdr (assq weight
'((ultra-bold .
"900")
805 (extra-light .
"200")
806 (ultra-light .
"100")))))))
808 (defun hfy-box-to-border-assoc (spec)
810 (let ((tag (car spec
))
813 (:color
(cons "colour" val
))
814 (:width
(cons "width" val
))
815 (:style
(cons "style" val
)))
816 (hfy-box-to-border-assoc (cddr spec
))))))
818 (defun hfy-box-to-style (spec)
819 (let* ((css (hfy-box-to-border-assoc spec
))
820 (col (cdr (assoc "colour" css
)))
821 (s (cdr (assoc "style" css
))))
823 (if col
(cons "border-color" (cdr (assoc "colour" css
))))
824 (cons "border-width" (format "%dpx" (or (cdr (assoc "width" css
)) 1)))
825 (cons "border-style" (case s
826 (released-button "outset")
827 (pressed-button "inset" )
831 "Derive CSS border-* attributes from the Emacs :box attribute BOX."
834 ((integerp box
) (list (cons "border-width" (format "%dpx" box
))))
835 ((stringp box
) (list (cons "border" (format "solid %s 1px" box
))))
836 ((listp box
) (hfy-box-to-style box
) ))) )
838 (defun hfy-decor (tag val
)
839 "Derive CSS text-decoration specifiers from various Emacs font attributes.
840 TAG is an Emacs font attribute key (eg :underline).
843 ;; FIXME: Why not '("text-decoration" . "underline")? --Stef
845 (:underline
(cons "text-decoration" "underline" ))
846 (:overline
(cons "text-decoration" "overline" ))
847 (:strike-through
(cons "text-decoration" "line-through")))))
849 (defun hfy-invisible (&optional val
)
850 "This text should be invisible.
851 Do something in CSS to make that happen.
852 VAL is ignored here."
853 '(("display" .
"none")))
855 (defun hfy-combined-face-spec (face)
856 "Return a `defface' style alist of possible specifications for FACE.
857 Entries resulting from customisation \(`custom-set-faces'\) will take
860 (setq spec
(append (or (get face
'saved-face
) (list))
861 (or (get face
'face-defface-spec
) (list))))
862 (if (and hfy-display-class hfy-default-face-def
(eq face
'default
))
863 (setq spec
(append hfy-default-face-def spec
))) spec
))
865 (defun hfy-face-attr-for-class (face &optional class
)
866 "Return the face attributes for FACE.
867 If CLASS is set, it must be a `defface' alist key \[see below\],
868 in which case the first face specification returned by `hfy-combined-face-spec'
869 which *doesn\'t* clash with CLASS is returned.\n
870 \(A specification with a class of t is considered to match any class you
871 specify - this matches Emacs\' behaviour when deciding on which face attributes
872 to use, to the best of my understanding\).\n
873 If CLASS is nil, then you just get get whatever `face-attr-construct' returns,
874 ie the current specification in effect for FACE.\n
875 *NOTE* This function forces any face that is not \'default and which has
876 no :inherit property to inherit from \'default \( this is because \'default
877 is magical in that Emacs' fonts behave as if they inherit implicitly from
878 \'default, but no such behaviour exists in HTML/CSS \).\n
879 See `hfy-display-class' for details of valid values for CLASS."
882 (let ((face-props (hfy-combined-face-spec face
))
889 (setq face-specn
(car face-props
)
890 face-class
(car face-specn
)
891 face-attrs
(cdr face-specn
)
892 face-props
(cdr face-props
))
893 ;; if the current element CEL of CLASS is t we match
894 ;; if the current face-class is t, we match
895 ;; if the cdr of CEL has a non-nil
896 ;; intersection with the cdr of the first member of
897 ;; the current face-class with the same car as CEL, we match
898 ;; if we actually clash, then we can't match
906 (while (and cbuf
(not next
))
911 val
(if (listp val
) val
(list val
)))
914 (memq face-class
'(t default
))) ;Default match.
915 (setq score
0) (ignore "t match"))
916 ((not (cdr (assq key face-class
))) ;Neither good nor bad.
917 nil
(ignore "non match, non collision"))
918 ((setq x
(hfy-interq val
(cdr (assq key face-class
))))
919 (setq score
(+ score
(length x
)))
920 (ignore "intersection"))
922 (setq next t score -
10) (ignore "collision")) ))
923 (if (> score face-score
)
925 (setq face-match face-attrs
927 (ignore "%d << %S/%S" score face-class class
))
928 (ignore "--- %d ---- (insufficient)" score
)) ))
929 ;; matched ? last attrs : nil
931 (if (listp (car face-match
)) (car face-match
) face-match
)
933 ;; Unfortunately the default face returns a
934 ;; :background. Fortunately we can remove it, but how do we do
935 ;; that in a non-system specific way?
936 (let ((spec (face-attr-construct face
))
938 (if (not (memq :background spec
))
941 (let ((a (nth 0 spec
))
943 (unless (and (eq a
:background
)
945 (string= b
"SystemWindow"))
946 (setq new-spec
(cons a
(cons b new-spec
)))))
947 (setq spec
(cddr spec
)))
949 (if (or (memq :inherit face-spec
) (eq 'default face
))
951 (nconc face-spec
(list :inherit
'default
))) ))
953 ;; construct an assoc of (css-tag-name . css-tag-value) pairs
954 ;; from a face or assoc of face attributes:
957 ;; (mumamo-message-with-face "testing face" 'highlight)
958 ;; (mumamo-message-with-face "testing face" '(:foreground "red" :background "yellow"))
959 ;; (hfy-face-to-style-i '(:inherit default foreground-color "red"))
960 ;; default face=(:stipple nil :background "SystemWindow" :foreground
961 ;; "SystemWindowText" :inverse-video nil :box nil :strike-through
962 ;; nil :overline nil :underline nil :slant normal :weight normal
963 ;; :height 98 :width normal :family "outline-courier new")
964 (defun hfy-face-to-style-i (fn)
965 "The guts of `hfy-face-to-style': FN should be a `defface' font spec,
966 as returned by `face-attr-construct' or `hfy-face-attr-for-class'. Note
967 that this function does not get font-sizes right if they are based on
968 inherited modifiers \(via the :inherit\) attribute, and any other
969 modifiers that are cumulative if they appear multiple times need to be
970 merged by the user - `hfy-flatten-style' should do this."
971 ;;(message "hfy-face-to-style-i");;DBUG
973 ;; fn's value could be something like
975 ;; ((foreground-color . "blue"))
976 ;; (foreground-color . "blue")
986 (if (eq key
:inherit
)
987 (let ((vs (if (listp val
) val
(list val
))))
988 ;; (let ((x '(a b))) (setq x (append '(c d) x)))
989 ;; (let ((x '(a b))) (setq x (append '(c d) x)))
995 (hfy-face-attr-for-class v hfy-display-class
)) ))))
998 (:family
(hfy-family val
))
999 (:width
(hfy-width val
))
1000 (:weight
(hfy-weight val
))
1001 (:slant
(hfy-slant val
))
1002 (:foreground
(hfy-colour val
))
1003 (:background
(hfy-bgcol val
))
1004 (:box
(hfy-box val
))
1005 (:height
(hfy-size val
))
1006 (:underline
(hfy-decor key val
))
1007 (:overline
(hfy-decor key val
))
1008 (:strike-through
(hfy-decor key val
))
1009 (:invisible
(hfy-invisible val
))
1010 (:bold
(hfy-weight 'bold
))
1011 (:italic
(hfy-slant 'italic
))))))
1012 (setq that
(hfy-face-to-style-i next
))
1013 ;;(lwarn t :warning "%S => %S" fn (nconc this that parent))
1014 (nconc this that parent
))) )
1016 (defun hfy-size-to-int (spec)
1017 "Convert SPEC, a css font-size specifier, back to an Emacs :height attribute
1018 value. Used while merging multiple font-size attributes."
1019 ;;(message "hfy-size-to-int");;DBUG
1021 (if (string-match "\\([0-9]+\\)\\(%\\|pt\\)" spec
)
1022 (cond ((string= "%" (match-string 2 spec
))
1023 (/ (string-to-number (match-string 1 spec
)) 100.0))
1024 ((string= "pt" (match-string 2 spec
))
1025 (* (string-to-number (match-string 1 spec
)) 10)))
1026 (string-to-number spec
))) )
1028 ;; size is different, in that in order to get it right at all,
1029 ;; we have to trawl the inheritance path, accumulating modifiers,
1030 ;; _until_ we get to an absolute (pt) specifier, then combine the lot
1031 (defun hfy-flatten-style (style)
1032 "Take STYLE (see `hfy-face-to-style-i', `hfy-face-to-style') and merge
1033 any multiple attributes appropriately. Currently only font-size is merged
1034 down to a single occurrence - others may need special handling, but I
1035 haven\'t encountered them yet. Returns a `hfy-style-assoc'."
1036 ;;(message "(hfy-flatten-style %S)" style) ;;DBUG
1042 (if (string= (car css
) "font-size")
1044 (when (not x
) (setq m
(nconc m
(hfy-size-to-int (cdr css
)))))
1045 (when (string-match "pt" (cdr css
)) (setq x t
)))
1046 (setq r
(nconc r
(list css
)))))
1047 ;;(message "r: %S" r)
1048 (setq n
(apply '* m
))
1049 (nconc r
(hfy-size (if x
(round n
) (* n
1.0)))) ))
1051 (defun hfy-face-to-style (fn)
1052 "Take FN, a font or `defface' style font specification,
1053 \(as returned by `face-attr-construct' or `hfy-face-attr-for-class'\)
1054 and return a `hfy-style-assoc'.\n
1055 See also: `hfy-face-to-style-i', `hfy-flatten-style'."
1056 ;;(message "hfy-face-to-style");;DBUG
1057 (let ((face-def (if (facep fn
)
1058 (hfy-face-attr-for-class fn hfy-display-class
) fn
))
1061 (setq final-style
(hfy-flatten-style (hfy-face-to-style-i face-def
)))
1062 ;;(message "%S" final-style)
1063 (if (not (assoc "text-decoration" final-style
))
1064 (progn (setq final-style
1065 ;; Fix-me: there is no need for this since
1066 ;; text-decoration is not inherited.
1067 ;; but it's not wrong and if this ever changes it will
1068 ;; be needed, so I think it's better to leave it in? -- v
1069 (nconc final-style
'(("text-decoration".
"none"))))))
1072 ;; strip redundant bits from a name. Technically, this could result in
1073 ;; a collision, but it is pretty unlikely - will fix later...
1074 ;; also handle ephemeral fonts created by overlays, which don't actually
1076 (defun hfy-face-or-def-to-name (fn)
1077 "Render a font symbol or `defface' font spec FN into a name \(string\)."
1078 ;;(message "generating name for %s" fn)
1079 (if (not (listp fn
))
1081 (let* ((key (format "%s" fn
))
1082 (entry (assoc key hfy-tmpfont-stack
))
1083 (base (cadr (memq :inherit fn
)))
1085 ;;(message "checking for key «%s» in font stack [%d]"
1086 ;; key (if entry 1 0))
1087 (if entry nil
;; noop
1088 (setq tag
(format "%04d" (length hfy-tmpfont-stack
))
1089 entry
(cons key tag
)
1090 hfy-tmpfont-stack
(cons entry hfy-tmpfont-stack
)))
1091 ;;(message " -> name: %s-%s" (or base 'default) tag)
1092 (format "%s-%s" (or base
'default
) tag
)) ))
1094 (defun hfy-css-name (fn)
1095 "Strip the boring bits from a font-name FN and return a CSS style name."
1096 ;;(message "hfy-css-name");;DBUG
1097 (let ((face-name (hfy-face-or-def-to-name fn
)))
1098 (if (or (string-match "font-lock-\\(.*\\)" face-name
)
1099 (string-match "cperl-\\(.*\\)" face-name
)
1100 (string-match "^[Ii]nfo-\\(.*\\)" face-name
))
1102 (setq face-name
(match-string 1 face-name
))
1103 (if (string-match "\\(.*\\)-face$" face-name
)
1104 (setq face-name
(match-string 1 face-name
))) face-name
)
1107 ;; construct an assoc of (stripped-name . "{ css-stuff-here }") pairs
1109 (defun hfy-face-to-css (fn)
1110 "Take FN, a font or `defface' specification \(cf `face-attr-construct'\)
1111 and return a CSS style specification.\n
1112 See also: `hfy-face-to-style'"
1113 ;;(message "hfy-face-to-css");;DBUG
1114 (let ((css-list nil
)
1117 ;;(message "(hfy-face-to-style %S)" fn)
1118 (setq css-list
(hfy-face-to-style fn
))
1123 (unless (member (car E
) seen
)
1125 (format " %s: %s; " (car E
) (cdr E
)))))
1127 (cons (hfy-css-name fn
) (format "{%s}" (apply 'concat css-text
)))) )
1129 ;; extract a face from a list of char properties, if there is one:
1130 (defun hfy-p-to-face (props)
1131 "Given PROPS, a list of text-properties, return the value of the face
1134 (if (string= (car props
) "face")
1135 (let ((propval (cadr props
)))
1136 (if (and (listp propval
) (not (cdr propval
)))
1139 (hfy-p-to-face (cddr props
)))
1142 (defun hfy-p-to-face-lennart (props)
1143 "Given PROPS, a list of text-properties, return the value of the face
1146 (let ((face (plist-get props
'face
))
1147 (font-lock-face (plist-get props
'font-lock-face
))
1148 (button (plist-get props
'button
))
1149 ;;(face-rec (memq 'face props))
1150 ;;(button-rec (memq 'button props)))
1153 (let* ((category (plist-get props
'category
))
1154 (face (when category
(plist-get (symbol-plist category
) 'face
))))
1159 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1160 ;; (defun hfy-get-face-at (pos)
1161 ;; ;; (let ((face (get-char-property-and-overlay pos 'face)))
1162 ;; ;; (when (and face (listp face)) (setq face (car face)))
1163 ;; ;; (unless (listp face)
1165 ;; ;;(get-char-property pos 'face)
1166 ;; ;; Overlays are handled later
1167 ;; (if (or (not show-trailing-whitespace)
1168 ;; (not (get-text-property pos 'hfy-show-trailing-whitespace)))
1169 ;; (get-text-property pos 'face)
1170 ;; (list 'trailing-whitespace (get-text-property pos 'face)))
1173 (defun hfy-prop-invisible-p (prop)
1174 "Is text property PROP an active invisibility property?"
1175 (or (and (eq buffer-invisibility-spec t
) prop
)
1176 (or (memq prop buffer-invisibility-spec
)
1177 (assq prop buffer-invisibility-spec
))))
1179 (defun hfy-find-invisible-ranges ()
1180 "Return a list of (start-point . end-point) cons cells of invisible regions."
1181 (let (invisible p i e s
) ;; return-value pos invisible end start
1183 (setq p
(goto-char (point-min)))
1184 (when (invisible-p p
) (setq s p i t
))
1185 (while (< p
(point-max))
1186 (if i
;; currently invisible
1187 (when (not (invisible-p p
)) ;; but became visible
1190 invisible
(cons (cons s e
) invisible
)))
1191 ;; currently visible:
1192 (when (invisible-p p
) ;; but have become invisible
1194 (setq p
(next-char-property-change p
)))
1195 ;; still invisible at buffer end?
1198 invisible
(cons (cons s e
) invisible
))) ) invisible
))
1200 (defun hfy-invisible-name (point map
)
1201 "Generate a CSS style name for an invisible section of the buffer.
1202 POINT is the point inside the invisible region.
1203 MAP is the invisibility map as returned by `hfy-find-invisible-ranges'."
1204 ;;(message "(hfy-invisible-name %S %S)" point map)
1207 (when (and (>= point
(car range
))
1208 (< point
(cdr range
)))
1209 (setq name
(format "invisible-%S-%S" (car range
) (cdr range
)))))
1212 ;; Fix-me: This function needs some cleanup by someone who understand
1213 ;; all the formats that face properties can have.
1215 ;; overlay handling should be fine. haven't tested multiple stacked overlapping
1216 ;; overlays recently, but the common case of a text property face + an overlay
1217 ;; face produces the correct merged css style (or as close to it as css can get)
1219 (defun hfy-face-at (p)
1220 "Find face in effect at point P.
1221 If overlays are to be considered \(see `hfy-optimisations'\) then this may
1222 return a defface style list of face properties instead of a face symbol."
1223 ;;(message "hfy-face-at");;DBUG
1224 ;; Fix-me: clean up, remove face-name etc
1225 ;; not sure why we'd want to remove face-name? -- v
1226 (let ((overlay-data nil
)
1228 ;; restored hfy-p-to-face as it handles faces like (bold) as
1229 ;; well as face like 'bold - hfy-get-face-at doesn't dtrt -- v
1230 (face-name (hfy-p-to-face (text-properties-at p
)))
1231 ;; (face-name (hfy-get-face-at p))
1234 (text-props (text-properties-at p
)))
1235 ;;(message "face-name: %S" face-name)
1236 (when (and face-name
(listp face-name
) (facep (car face-name
)))
1237 ;;(message "face-name is a list %S" face-name)
1238 ;;(setq text-props (cons 'face face-name))
1239 (dolist (f face-name
)
1240 (setq extra-props
(if (listp f
)
1241 ;; for things like (variable-pitch
1242 ;; (:foreground "red"))
1243 (cons f extra-props
)
1244 (cons :inherit
(cons f extra-props
)))))
1245 (setq base-face
(car face-name
)
1247 ;; text-properties-at => (face (:foreground "red" ...))
1248 ;; or => (face (compilation-info underline)) list of faces
1249 ;; overlay-properties
1250 ;; format= (evaporate t face ((foreground-color . "red")))
1252 ;; SO: if we have turned overlays off,
1253 ;; or if there's no overlay data
1254 ;; just bail out and return whatever face data we've accumulated so far
1255 (if (or (not (hfy-opt 'keep-overlays
))
1256 (not (setq overlay-data
(hfy-overlay-props-at p
))))
1258 ;;(message "· %d: %s; %S; %s"
1259 ;; p face-name extra-props text-props)
1260 (or face-name base-face
)) ;; no overlays or extra properties
1261 ;; collect any face data and any overlay data for processing:
1263 (push text-props overlay-data
))
1264 (setq overlay-data
(nreverse overlay-data
))
1265 ;;(message "- %d: %s; %S; %s; %s"
1266 ;; p face-name extra-props text-props overlay-data)
1267 ;; remember the basic face name so we don't keep repeating its specs:
1268 (when face-name
(setq base-face face-name
))
1269 (dolist (P overlay-data
)
1270 (let ((iprops (cadr (memq 'invisible P
)))) ;FIXME: plist-get?
1271 ;;(message "(hfy-prop-invisible-p %S)" iprops)
1272 (when (and iprops
(hfy-prop-invisible-p iprops
))
1274 (cons :invisible
(cons t extra-props
))) ))
1275 (let ((fprops (cadr (or (memq 'face P
)
1276 (memq 'font-lock-face P
)))))
1277 ;;(message "overlay face: %s" fprops)
1278 (if (not (listp fprops
))
1279 (let ((this-face (if (stringp fprops
) (intern fprops
) fprops
)))
1280 (when (not (eq this-face base-face
))
1283 (cons this-face extra-props
))) ))
1285 (if (facep (car fprops
))
1286 (let ((face (car fprops
)))
1287 (when (stringp face
) (setq face
(intern fprops
)))
1292 (setq fprops
(cdr fprops
)))
1295 (if (listp (car fprops
))
1296 (if (nlistp (cdr (car fprops
)))
1299 (setq p
(caar fprops
))
1300 (setq v
(cdar fprops
))
1301 (setq fprops
(cdr fprops
)))
1303 (setq p
(caar fprops
))
1304 (setq v
(cadar fprops
))
1305 (setq fprops
(cdr fprops
)))
1306 (if (listp (cdr fprops
))
1308 ;; (:prop val :prop val ...)
1309 (setq p
(car fprops
))
1310 (setq v
(cadr fprops
))
1311 (setq fprops
(cddr fprops
)))
1312 (if (and (listp fprops
)
1313 (not (listp (cdr fprops
))))
1314 ;;(and (consp x) (cdr (last x)))
1317 (setq p
(car fprops
))
1318 (setq v
(cdr fprops
))
1320 (error "Eh... another format! fprops=%s" fprops
) )))
1322 ;; These are all the properties handled
1323 ;; in `hfy-face-to-style-i'.
1325 ;; Are these translations right?
1326 ;; yes, they are -- v
1332 (underline :underline
)
1333 (overline :overline
)
1334 (strike-through :strike-through
)
1336 (foreground-color :foreground
)
1337 (background-color :background
)
1341 (if (memq p prop-seen
) nil
;; noop
1342 (setq prop-seen
(cons p prop-seen
)
1343 extra-props
(cons p
(cons v extra-props
))))))))))
1344 ;;(message "+ %d: %s; %S" p face-name extra-props)
1346 (if (listp face-name
)
1347 (nconc extra-props face-name
)
1348 (nconc extra-props
(face-attr-construct face-name
)))
1351 (defun hfy-overlay-props-at (p)
1352 "Grab overlay properties at point P.
1353 The plists are returned in descending priority order."
1354 (sort (mapcar #'overlay-properties
(overlays-at p
))
1355 (lambda (A B
) (> (or (cadr (memq 'priority A
)) 0) ;FIXME: plist-get?
1356 (or (cadr (memq 'priority B
)) 0)))))
1358 ;; construct an assoc of (face-name . (css-name . "{ css-style }")) elements:
1359 (defun hfy-compile-stylesheet ()
1360 "Trawl the current buffer, construct and return a `hfy-sheet-assoc'."
1361 ;;(message "hfy-compile-stylesheet");;DBUG
1362 (let ((pt (point-min))
1363 ;; Make the font stack stay:
1364 ;;(hfy-tmpfont-stack nil)
1369 (while (< pt
(point-max))
1370 (if (and (setq fn
(hfy-face-at pt
)) (not (assoc fn style
)))
1371 (push (cons fn
(hfy-face-to-css fn
)) style
))
1372 (setq pt
(next-char-property-change pt
))) )
1373 (push (cons 'default
(hfy-face-to-css 'default
)) style
)))
1375 (defun hfy-fontified-p ()
1376 "`font-lock' doesn't like to say it\'s been fontified when in batch
1377 mode, but we want to know if we should fontify or raw copy, so in batch
1378 mode we check for non-default face properties. Otherwise we test
1379 variable `font-lock-mode' and variable `font-lock-fontified' for truth."
1380 ;;(message "font-lock-fontified: %S" font-lock-fontified)
1381 ;;(message "noninteractive : %S" noninteractive)
1382 ;;(message "font-lock-mode : %S" font-lock-mode)
1383 (and font-lock-fontified
1385 (let ((pt (point-min))
1389 (while (and (< pt
(point-max)) (not face-name
))
1390 (setq face-name
(hfy-face-at pt
))
1391 (setq pt
(next-char-property-change pt
)))) face-name
)
1394 ;; remember, the map is in reverse point order:
1395 ;; I wrote this while suffering the effects of a cold, and maybe a
1396 ;; mild fever - I think it's correct, but it might be a little warped
1397 ;; as my minfd keeps ... where was I? Oh yes, the bunnies...
1398 (defun hfy-merge-adjacent-spans (face-map)
1399 "Where FACE-MAP is a `hfy-facemap-assoc' for the current buffer,
1400 this function merges adjacent style blocks which are of the same value
1401 and are separated by nothing more interesting than whitespace.\n
1402 <span class=\"foo\">narf</span> <span class=\"foo\">brain</span>\n
1403 \(as interpreted from FACE-MAP\) would become:\n
1404 <span class=\"foo\">narf brain</span>\n
1405 Returns a modified copy of FACE-MAP."
1406 (let ((tmp-map face-map
)
1415 ;;(push (car tmp-map) reduced-map)
1416 ;;(push (cadr tmp-map) reduced-map)
1418 (setq first-start
(cadddr tmp-map
)
1419 first-stop
(caddr tmp-map
)
1420 last-start
(cadr tmp-map
)
1421 last-stop
(car tmp-map
)
1423 span-start last-start
1424 span-stop last-stop
)
1425 (while (and (equal (cdr first-start
)
1428 (goto-char (car first-stop
))
1429 (not (re-search-forward "[^ \t\n\r]" (car last-start
) t
))))
1430 (setq map-buf
(cddr map-buf
)
1431 span-start first-start
1432 first-start
(cadddr map-buf
)
1433 first-stop
(caddr map-buf
)
1434 last-start
(cadr map-buf
)
1435 last-stop
(car map-buf
)))
1436 (push span-stop reduced-map
)
1437 (push span-start reduced-map
)
1438 (setq tmp-map
(memq last-start tmp-map
))
1439 (setq tmp-map
(cdr tmp-map
)))
1440 (setq reduced-map
(nreverse reduced-map
))))
1442 ;; remember to generate 'synthetic' </span> entries -
1443 ;; emacs copes by just having a stack of styles in effect
1444 ;; and only using the top one: html has a more simplistic approach -
1445 ;; we have to explicitly end a style, there's no way of temporarily
1446 ;; overriding it w. another one... (afaik)
1447 (defun hfy-compile-face-map ()
1448 ;; no need for special <a> version.
1449 ;; IME hyperlinks don't get underlined, esp when you htmlfontify a whole
1450 ;; source tree, so the <a> version is needed -- v
1451 ;; Fix-me: save table for multi-buffer
1452 "Compile and return a `hfy-facemap-assoc' for the current buffer."
1453 ;;(message "hfy-compile-face-map");;DBUG
1454 (let ((pt (point-min))
1458 (prev-tag nil
)) ;; t if the last tag-point was a span-start
1459 ;; nil if it was a span-stop
1462 (while (< pt
(point-max))
1463 (if (setq fn
(hfy-face-at pt
))
1464 (progn (if prev-tag
(push (cons pt-narrow
'end
) map
))
1465 (push (cons pt-narrow fn
) map
)
1467 (if prev-tag
(push (cons pt-narrow
'end
) map
))
1468 (setq prev-tag nil
))
1469 (setq pt
(next-char-property-change pt
))
1470 (setq pt-narrow
(1+ (- pt
(point-min)))))
1471 (if (and map
(not (eq 'end
(cdar map
))))
1472 (push (cons (- (point-max) (point-min)) 'end
) map
)))
1473 (if (hfy-opt 'merge-adjacent-tags
) (hfy-merge-adjacent-spans map
) map
)))
1475 (defun hfy-buffer ()
1476 "Generate a buffer to hold the html output.
1477 The filename of this buffer is derived from the source \(current\) buffer\'s
1478 variable `buffer-file-name', if it is set, plus `hfy-extn'.
1479 Otherwise a plausible filename is constructed from `default-directory',
1480 `buffer-name' and `hfy-extn'."
1481 (let* ((name (concat (buffer-name) hfy-extn
))
1482 (src (buffer-file-name))
1483 (buf (get-buffer-create name
)))
1484 (with-current-buffer buf
1485 (setq buffer-file-name
1486 (if src
(concat src hfy-extn
)
1487 (expand-file-name (if (string-match "^.*/\\([^/]*\\)$" name
)
1488 (match-string 1 name
)
1492 (defun hfy-lookup (face style
)
1493 "Get a CSS style name for FACE from STYLE."
1494 (cadr (assoc face style
)))
1496 (defun hfy-link-style (style-string)
1497 "Copy, alter and return a STYLE-STRING to make it suitable for a hyperlink.
1498 Uses `hfy-link-style-fun' to do this."
1499 (if (functionp hfy-link-style-fun
)
1500 (funcall hfy-link-style-fun style-string
)
1503 (defun hfy-sprintf-stylesheet (css file
)
1504 "Return the inline CSS style sheet for FILE as a string."
1505 (let ((stylesheet nil
))
1509 "\n<style type=\"text/css\"><!-- \n"
1510 ;; Fix-me: Add handling of page breaks here + scan for ^L
1511 ;; where appropriate.
1512 (format "body %s\n" (cddr (assq 'default css
)))
1517 "span.%s %s\nspan.%s a %s\n"
1518 (cadr style
) (cddr style
)
1519 (cadr style
) (hfy-link-style (cddr style
))))
1522 (funcall hfy-page-header file stylesheet
)))
1524 ;; tag all the dangerous characters we want to escape
1525 ;; (ie any "<> chars we _didn't_ put there explicitly for css markup)
1526 (defun hfy-html-enkludge-buffer ()
1527 "Mark dangerous [\"\<\>] characters with the \'hfy-quoteme property.\n
1528 See also `hfy-html-dekludge-buffer'."
1529 ;;(message "hfy-html-enkludge-buffer");;DBUG
1531 (goto-char (point-min))
1532 (while (re-search-forward hfy-html-quote-regex nil t
)
1533 (put-text-property (match-beginning 0) (point) 'hfy-quoteme t
))) )
1535 ;; dangerous char -> &entity;
1536 (defun hfy-html-quote (char-string)
1537 "Map CHAR-STRING to an html safe string (entity) if need be."
1538 ;;(message "hfy-html-quote");;DBUG
1539 (or (cadr (assoc char-string hfy-html-quote-map
)) char-string
) )
1541 ;; actually entity-ise dangerous chars.
1542 ;; note that we can't do this until _after_ we have inserted the css
1543 ;; markup, since we use a position-based map to insert this, and if we
1544 ;; enter any other text before we do this, we'd have to track another
1545 ;; map of offsets, which would be tedious...
1546 (defun hfy-html-dekludge-buffer ()
1547 "Transform all dangerous characters marked with the \'hfy-quoteme property
1548 using `hfy-html-quote'\n
1549 See also `hfy-html-enkludge-buffer'."
1550 ;;(message "hfy-html-dekludge-buffer");;DBUG
1552 (goto-char (point-min))
1553 (while (re-search-forward hfy-html-quote-regex nil t
)
1554 (if (get-text-property (match-beginning 0) 'hfy-quoteme
)
1555 (replace-match (hfy-html-quote (match-string 1))) )) ))
1557 ;; Borrowed from font-lock.el
1558 (defmacro hfy-save-buffer-state
(varlist &rest body
)
1559 "Bind variables according to VARLIST and eval BODY restoring buffer state.
1560 Do not record undo information during evaluation of BODY."
1561 (declare (indent 1) (debug let
))
1562 (let ((modified (make-symbol "modified")))
1563 `(let* ,(append varlist
1564 `((,modified
(buffer-modified-p))
1565 (buffer-undo-list t
)
1566 (inhibit-read-only t
)
1567 (inhibit-point-motion-hooks t
)
1568 (inhibit-modification-hooks t
)
1571 buffer-file-truename
))
1575 (restore-buffer-modified-p nil
)))))
1577 (defun hfy-mark-trailing-whitespace ()
1578 "Tag trailing whitespace with a hfy property if it is currently highlighted."
1579 (when show-trailing-whitespace
1580 (let ((inhibit-read-only t
))
1582 (goto-char (point-min))
1583 (hfy-save-buffer-state nil
1584 (while (re-search-forward "[ \t]+$" nil t
)
1585 (put-text-property (match-beginning 0) (match-end 0)
1586 'hfy-show-trailing-whitespace t
)))))))
1588 (defun hfy-unmark-trailing-whitespace ()
1589 "Undo the effect of `hfy-mark-trailing-whitespace'."
1590 (when show-trailing-whitespace
1591 (hfy-save-buffer-state nil
1592 (remove-text-properties (point-min) (point-max)
1593 '(hfy-show-trailing-whitespace)))))
1595 (defun hfy-fontify-buffer (&optional srcdir file
)
1596 "Implement the guts of `htmlfontify-buffer'.
1597 SRCDIR, if set, is the directory being htmlfontified.
1598 FILE, if set, is the file name."
1599 (if srcdir
(setq srcdir
(directory-file-name srcdir
)))
1600 (let* ( (html-buffer (hfy-buffer))
1605 (orig-ovls (overlays-in (point-min) (point-max)))
1606 (rmin (when mark-active
(region-beginning)))
1607 (rmax (when mark-active
(region-end ))) )
1608 (when (and mark-active
1609 transient-mark-mode
)
1610 (unless (and (= rmin
(point-min))
1611 (= rmax
(point-max)))
1612 (setq rovl
(make-overlay rmin rmax
))
1613 (overlay-put rovl
'priority
1000)
1614 (overlay-put rovl
'face
'region
)))
1615 ;; copy the buffer, including fontification, and switch to it:
1616 (hfy-mark-trailing-whitespace)
1617 (setq css-sheet
(hfy-compile-stylesheet )
1618 css-map
(hfy-compile-face-map )
1619 invis-ranges
(hfy-find-invisible-ranges))
1620 (hfy-unmark-trailing-whitespace)
1622 (delete-overlay rovl
))
1623 (copy-to-buffer html-buffer
(point-min) (point-max))
1624 (set-buffer html-buffer
)
1625 ;; Apply overlay invisible spec
1629 (> (or (cadr (memq 'priority
(overlay-properties A
))) 0)
1630 (or (cadr (memq 'priority
(overlay-properties B
))) 0)))))
1631 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1632 ;; at this point, html-buffer retains the fontification of the parent:
1633 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1634 ;; we don't really need or want text in the html buffer to be invisible, as
1635 ;; that can make it look like we've rendered invalid xhtml when all that's
1636 ;; happened is some tags are in the invisible portions of the buffer:
1637 (setq buffer-invisibility-spec nil
)
1638 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1639 ;; #####################################################################
1640 ;; if we are in etags mode, add properties to mark the anchors and links
1641 (if (and srcdir file
)
1643 (hfy-mark-tag-names srcdir file
) ;; mark anchors
1644 (hfy-mark-tag-hrefs srcdir file
))) ;; mark links
1645 ;; #####################################################################
1646 ;; mark the 'dangerous' characters
1647 ;;(message "marking dangerous characters")
1648 (hfy-html-enkludge-buffer)
1649 ;; trawl the position-based face-map, inserting span tags as we go
1650 ;; note that we cannot change any character positions before this point
1651 ;; or we will invalidate the map:
1652 ;; NB: This also means we have to trawl the map in descending file-offset
1653 ;; order, obviously.
1654 ;; ---------------------------------------------------------------------
1655 ;; Remember, inserting pushes properties to the right, which we don't
1656 ;; actually want to happen for link properties, so we have to flag
1657 ;; them and move them by hand - if you don't, you end up with
1659 ;; <span class="foo"><a href="bar">texta</span><span class="bletch"></a>...
1663 ;; <span class="foo"><a href="bar">texta</a></span><span class="bletch">...
1665 ;; If my analysis of the problem is correct, we can detect link-ness by
1666 ;; either hfy-linkp or hfy-endl properties at the insertion point, but I
1667 ;; think we only need to relocate the hfy-endl property, as the hfy-linkp
1668 ;; property has already served its main purpose by this point.
1669 ;;(message "mapcar over the CSS-MAP")
1670 (message "invis-ranges:\n%S" invis-ranges
)
1671 (dolist (point-face css-map
)
1672 (let ((pt (car point-face
))
1673 (fn (cdr point-face
))
1677 (or (get-text-property pt
'hfy-linkp
)
1678 (get-text-property pt
'hfy-endl
)))
1681 (if (not (and srcdir file
))
1684 (remove-text-properties (point) (1+ (point)) '(hfy-endl nil
))
1685 (put-text-property pt
(1+ pt
) 'hfy-endl t
) ))
1686 ;; if we have invisible blocks, we need to do some extra magic:
1688 (let ((iname (hfy-invisible-name pt invis-ranges
))
1689 (fname (hfy-lookup fn css-sheet
)))
1690 (when (assq pt invis-ranges
)
1692 (format "<span onclick=\"toggle_invis('%s');\">" iname
))
1693 (insert "…</span>"))
1695 (format "<span class=\"%s\" id=\"%s-%d\">" fname iname pt
)))
1696 (insert (format "<span class=\"%s\">" (hfy-lookup fn css-sheet
))))
1697 (if (not move-link
) nil
1698 ;;(message "removing prop2 @ %d" (point))
1699 (if (remove-text-properties (point) (1+ (point)) '(hfy-endl nil
))
1700 (put-text-property pt
(1+ pt
) 'hfy-endl t
))))))
1701 ;; #####################################################################
1703 ;; Maybe just make the text invisible in XHTML?
1704 ;; DONE -- big block of obsolete invisibility code elided here -- v
1705 ;; #####################################################################
1706 ;; (message "checking to see whether we should link...")
1707 (if (and srcdir file
)
1708 (let ((lp 'hfy-link
)
1712 ;; (message " yes we should.")
1713 ;; translate 'hfy-anchor properties to anchors
1714 (setq pt
(point-min))
1715 (while (setq pt
(next-single-property-change pt
'hfy-anchor
))
1716 (if (setq pr
(get-text-property pt
'hfy-anchor
))
1717 (progn (goto-char pt
)
1718 (remove-text-properties pt
(1+ pt
) '(hfy-anchor nil
))
1719 (insert (concat "<a name=\"" pr
"\"></a>")))))
1720 ;; translate alternate 'hfy-link and 'hfy-endl props to opening
1721 ;; and closing links. (this should avoid those spurious closes
1722 ;; we sometimes get by generating only paired tags)
1723 (setq pt
(point-min))
1724 (while (setq pt
(next-single-property-change pt lp
))
1725 (if (not (setq pr
(get-text-property pt lp
))) nil
1727 (remove-text-properties pt
(1+ pt
) (list lp nil
))
1730 (if (setq rr
(get-text-property pt
'hfy-inst
))
1731 (insert (format "<a name=\"%s\"></a>" rr
)))
1732 (insert (format "<a href=\"%s\">" pr
))
1733 (setq lp
'hfy-endl
))
1735 (insert "</a>") (setq lp
'hfy-link
)) ))) ))
1737 ;; #####################################################################
1738 ;; transform the dangerous chars. This changes character positions
1739 ;; since entities have > char length.
1740 ;; note that this deletes the dangerous characters, and therefore
1741 ;; destroys any properties they may contain (such as 'hfy-endl),
1742 ;; so we have to do this after we use said properties:
1743 ;; (message "munging dangerous characters")
1744 (hfy-html-dekludge-buffer)
1745 ;; insert the stylesheet at the top:
1746 (goto-char (point-min))
1747 ;;(message "inserting stylesheet")
1748 (insert (hfy-sprintf-stylesheet css-sheet file
))
1749 (if (hfy-opt 'div-wrapper
) (insert "<div class=\"default\">"))
1751 (goto-char (point-max))
1753 (if (hfy-opt 'div-wrapper
) (insert "</div>"))
1754 ;;(message "inserting footer")
1755 (insert (funcall hfy-page-footer file
))
1756 ;; call any post html-generation hooks:
1757 (run-hooks 'hfy-post-html-hooks
)
1758 ;; return the html buffer
1759 (set-buffer-modified-p nil
)
1762 (defun hfy-force-fontification ()
1763 "Try to force font-locking even when it is optimised away."
1764 (run-hooks 'hfy-init-kludge-hook
)
1765 (eval-and-compile (require 'font-lock
))
1766 (if (boundp 'font-lock-cache-position
)
1767 (or font-lock-cache-position
1768 (set 'font-lock-cache-position
(make-marker))))
1769 (if (not noninteractive
)
1771 (message "hfy interactive mode (%S %S)" window-system major-mode
)
1772 (when (and font-lock-defaults
1774 (font-lock-fontify-region (point-min) (point-max) nil
)))
1775 (message "hfy batch mode (%s:%S)"
1776 (or (buffer-file-name) (buffer-name)) major-mode
)
1777 (when font-lock-defaults
1778 (font-lock-fontify-buffer)) ))
1780 (defun htmlfontify-buffer (&optional srcdir file
)
1781 "Create a new buffer, named for the current buffer + a .html extension,
1782 containing an inline css-stylesheet and formatted css-markup html
1783 that reproduces the look of the current Emacs buffer as closely
1786 Dangerous characters in the existing buffer are turned into html
1787 entities, so you should even be able to do html-within-html
1790 You should, however, note that random control or eight-bit
1791 characters such as ^L (\x0c) or ¤ (\xa4) won't get mapped yet.
1793 If the SRCDIR and FILE arguments are set, lookup etags derived
1794 entries in the `hfy-tags-cache' and add html anchors and
1795 hyperlinks as appropriate."
1797 ;; pick up the file name in case we didn't receive it
1799 (progn (setq file
(or (buffer-file-name) (buffer-name)))
1800 (if (string-match "/\\([^/]*\\)$" file
)
1801 (setq file
(match-string 1 file
)))) )
1803 (if (not (hfy-opt 'skip-refontification
))
1804 (save-excursion ;; Keep region
1805 (hfy-force-fontification)))
1806 (if (interactive-p) ;; display the buffer in interactive mode:
1807 (switch-to-buffer (hfy-fontify-buffer srcdir file
))
1808 (hfy-fontify-buffer srcdir file
)))
1810 ;; recursive file listing
1811 (defun hfy-list-files (directory)
1812 "Return a list of files under DIRECTORY.
1813 Strips any leading \"./\" from each filename."
1814 ;;(message "hfy-list-files");;DBUG
1815 ;; FIXME: this changes the dir of the currrent buffer. Is that right??
1817 (mapcar (lambda (F) (if (string-match "^./\\(.*\\)" F
) (match-string 1 F
) F
))
1818 (split-string (shell-command-to-string hfy-find-cmd
))) )
1820 ;; strip the filename off, return a directiry name
1821 ;; not a particularly thorough implementaion, but it will be
1822 ;; fed pretty carefully, so it should be Ok:
1823 (defun hfy-dirname (file)
1824 "Return everything preceding the last \"/\" from a relative filename FILE,
1825 on the assumption that this will produce a relative directory name. Hardly
1826 bombproof, but good enough in the context in which it is being used."
1827 ;;(message "hfy-dirname");;DBUG
1828 (let ((f (directory-file-name file
)))
1829 (and (string-match "^\\(.*\\)/" f
) (match-string 1 f
))))
1831 ;; create a directory, cf mkdir -p
1832 (defun hfy-make-directory (dir)
1833 "Approx equivalent of mkdir -p DIR."
1834 ;;(message "hfy-make-directory");;DBUG
1835 (if (file-exists-p dir
)
1836 (if (file-directory-p dir
) t
)
1837 (make-directory dir t
)))
1839 (defun hfy-text-p (srcdir file
)
1840 "Is SRCDIR/FILE text? Uses `hfy-istext-command' to determine this."
1841 (let* ((cmd (format hfy-istext-command
(expand-file-name file srcdir
)))
1842 (rsp (shell-command-to-string cmd
)))
1843 (if (string-match "text" rsp
) t nil
)))
1845 ;; open a file, check fontification, if fontified, write a fontified copy
1846 ;; to the destination directory, otherwise just copy the file:
1847 (defun hfy-copy-and-fontify-file (srcdir dstdir file
)
1848 "Open FILE in SRCDIR - if fontified, write a fontified copy to DSTDIR
1849 adding an extension of `hfy-extn'. Fontification is actually done by
1850 `htmlfontify-buffer'. If the buffer is not fontified, just copy it."
1851 ;;(message "hfy-copy-and-fontify-file");;DBUG
1852 (let (;;(fast-lock-minimum-size hfy-fast-lock-save)
1853 ;;(font-lock-support-mode 'fast-lock-mode)
1854 ;;(window-system (or window-system 'htmlfontify))
1859 (with-current-buffer (setq source
(find-file-noselect file
))
1860 ;; FIXME: Shouldn't this use expand-file-name? --Stef
1861 (setq target
(concat dstdir
"/" file
))
1862 (hfy-make-directory (hfy-dirname target
))
1863 (if (not (hfy-opt 'skip-refontification
)) (hfy-force-fontification))
1864 (if (or (hfy-fontified-p) (hfy-text-p srcdir file
))
1865 (progn (setq html
(hfy-fontify-buffer srcdir file
))
1867 (write-file (concat target hfy-extn
))
1869 ;; #o0200 == 128, but emacs20 doesn't know that
1870 (if (and (file-exists-p target
) (not (file-writable-p target
)))
1871 (set-file-modes target
(logior (file-modes target
) 128)))
1872 (copy-file (buffer-file-name source
) target
'overwrite
))
1873 (kill-buffer source
)) ))
1875 ;; list of tags in file in srcdir
1876 (defun hfy-tags-for-file (srcdir file
)
1877 "List of etags tags that have definitions in this FILE.
1878 Looks up the tags cache in `hfy-tags-cache' using SRCDIR as the key."
1879 ;;(message "hfy-tags-for-file");;DBUG
1880 (let ((cache-entry (assoc srcdir hfy-tags-cache
))
1883 (if (setq cache-hash
(cadr cache-entry
))
1887 (setq tag-list
(cons K tag-list
)))) cache-hash
))
1890 ;; mark the tags native to this file for anchors
1891 (defun hfy-mark-tag-names (srcdir file
)
1892 "Mark tags in FILE (lookup SRCDIR in `hfy-tags-cache') with the \'hfy-anchor
1893 property, with a value of \"tag.line-number\"."
1894 ;;(message "(hfy-mark-tag-names %s %s)" srcdir file);;DBUG
1895 (let ((cache-entry (assoc srcdir hfy-tags-cache
))
1897 (if (setq cache-hash
(cadr cache-entry
))
1902 (if (string= file
(car TLIST
))
1903 (let* ((line (cadr TLIST
) )
1904 (chr (caddr TLIST
) )
1905 (link (format "%s.%d" TAG line
) ))
1906 (put-text-property (+ 1 chr
)
1908 'hfy-anchor link
))))
1909 (gethash TAG cache-hash
)))
1910 (hfy-tags-for-file srcdir file
)))))
1912 (defun hfy-relstub (file &optional start
)
1913 "Return a \"../\" stub of the appropriate length for the current source
1914 tree depth \(as determined from FILE \(a filename\)\).
1915 START is the offset at which to start looking for the / character in FILE."
1916 ;;(message "hfy-relstub");;DBUG
1918 (while (setq start
(string-match "/" file start
))
1919 (setq start
(1+ start
)) (setq c
(concat c
"../"))) c
))
1921 (defun hfy-href-stub (this-file def-files tag
)
1922 "Return an href stub for a tag href i THIS-FILE:
1923 If DEF-FILES \(list of files containing definitions for the tag in question\)
1924 contains only one entry, the href should link straight to that file.
1925 Otherwise, the link should be to the index file.\n
1926 We are not yet concerned with the file extensions/tag line number and so on at
1928 If `hfy-split-index' is set, and the href wil be to an index file rather than
1929 a source file, append a .X to `hfy-index-file', where X is the uppercased
1930 first character of TAG.\n
1931 See also: `hfy-relstub', `hfy-index-file'`'."
1932 ;;(message "hfy-href-stub");;DBUG
1933 ;; FIXME: Why not use something like
1934 ;; (file-relative-name (if ...) (file-name-directory this-file)) ? --Stef
1936 (hfy-relstub this-file
)
1937 (if (= 1 (length def-files
)) (car def-files
)
1938 (if (not hfy-split-index
) hfy-index-file
1939 (concat hfy-index-file
"." (upcase (substring tag
0 1)))))) )
1941 (defun hfy-href (this-file def-files tag tag-map
)
1942 "Return a relative href to the tag in question, based on\n
1943 THIS-FILE `hfy-link-extn' `hfy-extn' DEF-FILES TAG and TAG-MAP\n
1944 THIS-FILE is the current source file
1945 DEF-FILES is a list of file containing possible link endpoints for TAG
1946 TAG is the TAG in question
1947 TAG-MAP is the entry in `hfy-tags-cache'."
1948 ;;(message "hfy-href");;DBUG
1950 (hfy-href-stub this-file def-files tag
)
1951 (or hfy-link-extn hfy-extn
) "#" tag
;;(.src -> .html)
1952 (if (= 1 (length def-files
))
1953 (concat "." (format "%d" (cadr (assoc (car def-files
) tag-map
)))))) )
1955 (defun hfy-word-regex (string)
1956 "Return a regex that matches STRING as the first `match-string', with non
1957 word characters on either side."
1958 ;; FIXME: Should this use [^$[:alnum:]_] instead? --Stef
1959 (concat "[^$A-Za-z_0-9]\\(" (regexp-quote string
) "\\)[^A-Za-z_0-9]"))
1961 ;; mark all tags for hyperlinking, except the tags at
1962 ;; their own points of definition, iyswim:
1963 (defun hfy-mark-tag-hrefs (srcdir file
)
1964 "Mark href start points with the \'hfy-link prop \(value: href string\)\n
1965 Mark href end points with the \'hfy-endl prop \(value t\)\n
1966 Avoid overlapping links, and mark links in descending length of
1967 tag name in order to prevent subtags from usurping supertags,
1968 \(eg \"term\" for \"terminal\").
1969 SRCDIR is the directory being \"published\".
1970 FILE is the specific file we are rendering."
1971 ;;(message "hfy-mark-tag-hrefs");;DBUG
1972 (let ((cache-entry (assoc srcdir hfy-tags-cache
))
1973 (list-cache (assoc srcdir hfy-tags-sortl
))
1974 (rmap-cache (assoc srcdir hfy-tags-rmap
))
1975 (no-comment (hfy-opt 'zap-comment-links
))
1976 (no-strings (hfy-opt 'zap-string-links
))
1980 (case-fold-search nil
))
1981 ;; extract the tag mapping hashes (fwd and rev) and the tag list:
1982 (if (and (setq cache-hash
(cadr cache-entry
))
1983 (setq tags-rmap
(cadr rmap-cache
))
1984 (setq tags-list
(cadr list-cache
)))
1991 (case-fold-search nil
)
1998 (tag-regex (hfy-word-regex TAG
))
1999 (tag-map (gethash TAG cache-hash
))
2000 (tag-files (mapcar #'car tag-map
)))
2001 ;; find instances of TAG and do what needs to be done:
2002 (goto-char (point-min))
2003 (while (search-forward TAG nil
'NOERROR
)
2004 (setq tmp-point
(point)
2005 maybe-start
(- (match-beginning 0) 1))
2006 (goto-char maybe-start
)
2007 (if (not (looking-at tag-regex
))
2009 (setq start
(match-beginning 1))
2010 (setq stop
(match-end 1))
2012 (and (or no-comment no-strings
) (hfy-face-at start
)))
2014 (setq face-at
(cadr (memq :inherit face-at
))))
2015 (if (or (text-property-any start
(1+ stop
) 'hfy-linkp t
)
2016 (and no-comment
(eq 'font-lock-comment-face face-at
))
2017 (and no-strings
(eq 'font-lock-string-face face-at
)))
2018 nil
;; already a link, NOOP
2020 ;; set a reverse map entry:
2021 (setq rmap-line
(line-number-at-pos)
2022 rmap-entry
(gethash TAG tags-rmap
)
2023 rnew-elt
(list file rmap-line start
)
2024 rmap-entry
(cons rnew-elt rmap-entry
)
2025 name
(format "%s.%d" TAG rmap-line
))
2026 (put-text-property start
(1+ start
) 'hfy-inst name
)
2027 (puthash TAG rmap-entry tags-rmap
)
2029 ;; mark the link. link to index if the tag has > 1 def
2030 ;; add the line number to the #name if it does not:
2031 (setq href
(hfy-href file tag-files TAG tag-map
))
2032 (put-text-property start
(1+ start
) 'hfy-link href
)
2033 (put-text-property stop
(1+ stop
) 'hfy-endl t
)
2034 (put-text-property start
(1+ stop
) 'hfy-linkp t
)))
2035 (goto-char tmp-point
)) ))
2039 "Return `shell-file-name', or \"/bin/sh\" if it is a non-bourne shell."
2040 (if (string-match "\\<bash\\>\\|\\<sh\\>\\|\\<dash\\>" shell-file-name
)
2042 (or hfy-shell-file-name
"/bin/sh")))
2044 ;; cache the #(tag => file line point) entries for files under srcdir
2045 ;; and cache the descending sorted list of tags in the relevant alist,
2046 ;; also keyed by srcdir:
2047 (defun hfy-load-tags-cache (srcdir)
2048 "Run `hfy-etags-cmd' on SRCDIR, then call `hfy-parse-tags-buffer'."
2049 ;;(message "hfy-load-tags-cache");;DBUG
2050 (let ((etags-buffer (get-buffer-create "*hfy-tags*"))
2051 (etags-command (format hfy-etags-cmd hfy-etags-bin
))
2052 (shell-file-name (hfy-shell)))
2054 (shell-command etags-command etags-buffer
)
2055 (hfy-parse-tags-buffer srcdir etags-buffer
)) )
2057 ;; break this out from `hfy-load-tags-cache' to make the tar file
2058 ;; functionality easier to implement.
2059 ;; ( tar file functionality not merged here because it requires a
2060 ;; hacked copy of etags capable of tagging stdin: if Francesco
2061 ;; Potorti accepts a patch, or otherwise implements stdin tagging,
2062 ;; then I will provide a `htmlfontify-tar-file' defun )
2063 (defun hfy-parse-tags-buffer (srcdir buffer
)
2064 "Parse a BUFFER containing etags formatted output, loading the
2065 `hfy-tags-cache' and `hfy-tags-sortl' entries for SRCDIR."
2066 (let ((cache-entry (assoc srcdir hfy-tags-cache
))
2067 (tlist-cache (assoc srcdir hfy-tags-sortl
))
2068 (trmap-cache (assoc srcdir hfy-tags-rmap
))
2069 (cache-hash nil
) (trmap-hash nil
) (tags-list nil
)
2070 (hash-entry nil
) (tag-string nil
) (tag-line nil
)
2071 (tag-point nil
) (new-entry nil
) (etags-file nil
))
2073 ;; (re)initialise the tag reverse map:
2074 (if trmap-cache
(setq trmap-hash
(cadr trmap-cache
))
2075 (setq trmap-hash
(make-hash-table :test
'equal
))
2076 (setq hfy-tags-rmap
(list (list srcdir trmap-hash
) hfy-tags-rmap
)))
2077 (clrhash trmap-hash
)
2079 ;; (re)initialise the tag cache:
2080 (if cache-entry
(setq cache-hash
(cadr cache-entry
))
2081 (setq cache-hash
(make-hash-table :test
'equal
))
2082 (setq hfy-tags-cache
(list (list srcdir cache-hash
) hfy-tags-cache
)))
2083 (clrhash cache-hash
)
2085 ;; cache the TAG => ((file line point) (file line point) ... ) entries:
2086 (with-current-buffer buffer
2087 (goto-char (point-min))
2089 (while (and (looking-at "^\x0c") (= 0 (forward-line 1)))
2090 ;;(message "^L boundary")
2091 (if (and (looking-at "^\\(.+\\),\\([0-9]+\\)$")
2092 (= 0 (forward-line 1)))
2094 (setq etags-file
(match-string 1))
2095 ;;(message "TAGS for file: %s" etags-file)
2096 (while (and (looking-at hfy-etag-regex
) (= 0 (forward-line 1)))
2097 (setq tag-string
(match-string 1))
2098 (if (= 0 (length tag-string
)) nil
;; noop
2099 (setq tag-line
(round (string-to-number (match-string 2))))
2100 (setq tag-point
(round (string-to-number (match-string 3))))
2101 (setq hash-entry
(gethash tag-string cache-hash
))
2102 (setq new-entry
(list etags-file tag-line tag-point
))
2103 (push new-entry hash-entry
)
2104 ;;(message "HASH-ENTRY %s %S" tag-string new-entry)
2105 (puthash tag-string hash-entry cache-hash
)))) )))
2107 ;; cache a list of tags in descending length order:
2108 (maphash (lambda (K V
) (push K tags-list
)) cache-hash
)
2109 (setq tags-list
(sort tags-list
(lambda (A B
) (< (length B
) (length A
)))))
2111 ;; put the tag list into the cache:
2112 (if tlist-cache
(setcar (cdr tlist-cache
) tags-list
)
2113 (push (list srcdir tags-list
) hfy-tags-sortl
))
2115 ;; return the number of tags found:
2116 (length tags-list
) ))
2118 (defun hfy-prepare-index-i (srcdir dstdir filename
&optional stub map
)
2119 "Prepare a tags index buffer for SRCDIR.
2120 `hfy-tags-cache' must already have an entry for SRCDIR for this to work.
2121 `hfy-page-header', `hfy-page-footer', `hfy-link-extn' and `hfy-extn'
2122 all play a part here.\n
2123 If STUB is set, prepare an \(appropriately named\) index buffer
2124 specifically for entries beginning with STUB.\n
2125 If MAP is set, use that instead of `hfy-tags-cache'.
2126 FILENAME is the name of the file being indexed.
2127 DSTDIR is the output directory, where files will be written."
2128 ;;(message "hfy-write-index");;DBUG
2129 (let ((cache-entry (assoc srcdir
(or map hfy-tags-cache
)))
2133 (concat filename
(if stub
(concat "." stub
) "") hfy-extn
))
2135 (if (not (and cache-entry
2136 (setq cache-hash
(cadr cache-entry
))
2137 (setq index-buf
(get-buffer-create index-file
))))
2139 (maphash (lambda (K V
) (push K tag-list
)) cache-hash
)
2140 (setq tag-list
(sort tag-list
'string
<))
2141 (set-buffer index-buf
)
2143 (insert (funcall hfy-page-header filename
"<!-- CSS -->"))
2144 (insert "<table class=\"index\">\n")
2146 (dolist (TAG tag-list
)
2147 (let ((tag-started nil
))
2148 (dolist (DEF (gethash TAG cache-hash
))
2149 (if (and stub
(not (string-match (concat "^" stub
) TAG
)))
2150 nil
;; we have a stub and it didn't match: NOOP
2151 (let ((file (car DEF
))
2158 " <td><a href=\"%s%s\">%s</a></td> \n"
2159 " <td><a href=\"%s%s#%s.%d\">%d</a></td>\n"
2161 (if (string= TAG tag-started
) " "
2162 (format "<a name=\"%s\">%s</a>" TAG TAG
))
2163 file
(or hfy-link-extn hfy-extn
) file
2164 file
(or hfy-link-extn hfy-extn
) TAG line line
))
2165 (setq tag-started TAG
))))))
2166 (insert "</table>\n")
2167 (insert (funcall hfy-page-footer filename
))
2168 (and dstdir
(cd dstdir
))
2169 (set-visited-file-name index-file
)
2172 (defun hfy-prepare-index (srcdir dstdir
)
2173 "Return a list of index buffer\(s\), as determined by `hfy-split-index'.
2174 SRCDIR and DSTDIR are the source and output directories respectively."
2175 (if (not hfy-split-index
)
2176 (list (hfy-prepare-index-i srcdir dstdir hfy-index-file nil
))
2177 (let ((stub-list nil
)
2180 (cache-entry (assoc srcdir hfy-tags-cache
)))
2181 (if (and cache-entry
(setq cache-hash
(cadr cache-entry
)))
2184 (let ((stub (upcase (substring K
0 1))))
2185 (if (member stub stub-list
)
2186 nil
;; seen this already: NOOP
2188 stub-list
(cons stub stub-list
)
2189 index-list
(cons (hfy-prepare-index-i srcdir
2193 index-list
)) ))) cache-hash
) ) index-list
)))
2195 (defun hfy-prepare-tag-map (srcdir dstdir
)
2196 "Prepare the counterpart\(s\) to the index buffer\(s\) - a list of buffers
2197 with the same structure, but listing \( and linking to \) instances of tags
2198 \( as opposed to their definitions \).\n
2199 SRCDIR and DSTDIR are the source and output directories respectively.
2200 See: `hfy-prepare-index'
2202 (if (not hfy-split-index
)
2203 (list (hfy-prepare-index-i srcdir
2208 (let ((stub-list nil
)
2211 (cache-entry (assoc srcdir hfy-tags-rmap
)))
2213 (if (and cache-entry
(setq cache-hash
(cadr cache-entry
)))
2216 (let ((stub (upcase (substring K
0 1))))
2217 (if (member stub stub-list
)
2218 nil
;; seen this already: NOOP
2220 stub-list
(cons stub stub-list
)
2221 index-list
(cons (hfy-prepare-index-i srcdir
2226 index-list
)) ))) cache-hash
) ) index-list
)))
2228 (defun hfy-subtract-maps (srcdir)
2229 "Internal function - strips definitions of tags from the instance map.
2230 SRCDIR is the directory being \"published\".
2231 See: `hfy-tags-cache' and `hfy-tags-rmap'"
2232 (let ((new-list nil
)
2236 (fwd-map (cadr (assoc srcdir hfy-tags-cache
)))
2237 (rev-map (cadr (assoc srcdir hfy-tags-rmap
)))
2238 (taglist (cadr (assoc srcdir hfy-tags-sortl
))))
2239 (dolist (TAG taglist
)
2240 (setq def-list
(gethash TAG fwd-map
)
2241 old-list
(gethash TAG rev-map
)
2242 exc-list
(mapcar (lambda (P) (list (car P
) (cadr P
))) def-list
)
2244 (dolist (P old-list
)
2245 (or (member (list (car P
) (cadr P
)) exc-list
)
2247 (puthash TAG new-list rev-map
))))
2249 (defun htmlfontify-run-etags (srcdir)
2250 "Load the etags cache for SRCDIR.
2251 See `hfy-load-tags-cache'."
2252 (interactive "D source directory: ")
2253 (setq srcdir
(directory-file-name srcdir
))
2254 (hfy-load-tags-cache srcdir
))
2256 ;;(defun hfy-test-read-args (foo bar)
2257 ;; (interactive "D source directory: \nD target directory: ")
2258 ;; (message "foo: %S\nbar: %S" foo bar))
2260 (defun hfy-save-kill-buffers (buffer-list &optional dstdir
)
2261 (dolist (B buffer-list
)
2263 (and dstdir
(file-directory-p dstdir
) (cd dstdir
))
2267 (defun htmlfontify-copy-and-link-dir (srcdir dstdir
&optional f-ext l-ext
)
2268 "Trawl SRCDIR and write fontified-and-hyperlinked output in DSTDIR.
2269 F-EXT and L-EXT specify values for `hfy-extn' and `hfy-link-extn'.\n
2270 You may also want to set `hfy-page-header' and `hfy-page-footer'."
2271 (interactive "D source directory: \nD output directory: ")
2272 ;;(message "htmlfontify-copy-and-link-dir")
2273 (setq srcdir
(directory-file-name srcdir
))
2274 (setq dstdir
(directory-file-name dstdir
))
2275 (let ((source-files "SETME: list of source files, relative to srcdir")
2276 (tr-cache (assoc srcdir hfy-tags-rmap
))
2277 (hfy-extn (or f-ext
".html"))
2278 (hfy-link-extn (or l-ext
".html")))
2279 ;; oops, forgot to load etags for srcdir:
2281 (message "autoload of tags cache")
2282 (hfy-load-tags-cache srcdir
)
2283 (setq tr-cache
(assoc srcdir hfy-tags-rmap
)))
2284 ;; clear out the old cache:
2285 (clrhash (cadr tr-cache
))
2286 (hfy-make-directory dstdir
)
2287 (setq source-files
(hfy-list-files srcdir
))
2288 (dolist (file source-files
)
2289 (hfy-copy-and-fontify-file srcdir dstdir file
))
2290 (hfy-subtract-maps srcdir
)
2291 (hfy-save-kill-buffers (hfy-prepare-index srcdir dstdir
) dstdir
)
2292 (hfy-save-kill-buffers (hfy-prepare-tag-map srcdir dstdir
) dstdir
) ))
2294 ;; name of the init file we want:
2295 (defun hfy-initfile ()
2296 "Return the expected location of the htmlfontify specific init/custom file."
2297 (let* ((file (or (getenv "HFY_INITFILE") ".hfy.el")))
2298 (expand-file-name file
"~") ))
2301 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2302 ;; incomplete as yet : transfer hook settings to hfy init file:
2303 ;; (defalias 'hfy-set-hooks 'custom-set-variables)
2305 ;; (defun hfy-pp-hook (H)
2306 ;; (and (string-match "-hook$" (symbol-name H))
2309 ;; (insert (format "\n '(%S %S)" H (symbol-value H)))
2313 ;; (defun hfy-save-hooks ()
2314 ;; (let ((custom-file (hfy-initfile)))
2315 ;; (custom-save-delete 'hfy-set-hooks)
2316 ;; (let ((standard-output (current-buffer)))
2317 ;; (princ "(hfy-set-hooks\n;;auto-generated, only one copy allowed\n")
2318 ;; (mapatoms 'hfy-pp-hook)
2323 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2325 (defalias 'hfy-init-progn
'progn
)
2327 (defun hfy-save-initvar (sym)
2328 (princ (format "(setq %s\n '" sym
))
2329 (pp (symbol-value sym
))
2332 (defun htmlfontify-save-initfile ()
2333 "Save the htmlfontify settings to the htmlfontify init file."
2335 (let* ((start-pos nil
)
2336 (custom-file (hfy-initfile))
2337 (standard-output (find-file-noselect custom-file
'nowarn
)))
2339 (custom-save-delete 'hfy-init-progn
)
2340 (setq start-pos
(point))
2341 (princ "(hfy-init-progn\n;;auto-generated, only one copy allowed\n")
2342 ;; FIXME: This saving&restoring of global customization
2343 ;; variables can interfere with other customization settings for
2344 ;; those vars (in .emacs or in Customize).
2345 (mapc 'hfy-save-initvar
2346 '(auto-mode-alist interpreter-mode-alist
))
2348 (indent-region start-pos
(point) nil
))
2349 (custom-save-all) ))
2351 (defun htmlfontify-load-initfile ()
2352 "Load the htmlfontify specific init/custom file."
2354 (let ((file (hfy-initfile)))
2355 (load file
'NOERROR nil nil
) ))
2357 (provide 'htmlfontify
)
2358 ;;; htmlfontify.el ends here
2360 ;; arch-tag: 944e5e63-c81d-4baa-a82a-0275f9c30e61