Merge from origin/emacs-24
[emacs.git] / lisp / htmlfontify.el
blob719cb82b98946c09b60a9e6d4245c1832af4f03f
1 ;;; htmlfontify.el --- htmlize a buffer/source tree with optional hyperlinks
3 ;; Copyright (C) 2002-2003, 2009-2015 Free Software Foundation, Inc.
5 ;; Emacs Lisp Archive Entry
6 ;; Package: htmlfontify
7 ;; Filename: htmlfontify.el
8 ;; Version: 0.21
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: htmlize 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/>.
34 ;;; Commentary:
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)
80 ;;; History:
81 ;; Changes: moved to changelog (CHANGES) file.
83 ;;; Code:
84 (eval-when-compile (require 'cl))
85 (require 'faces)
86 ;; (`facep' `face-attr-construct' `x-color-values' `color-values' `face-name')
87 (require 'custom)
88 ;; (`defgroup' `defcustom')
89 (require 'font-lock)
90 ;; (`font-lock-fontify-region')
91 (require 'cus-edit)
93 (defconst htmlfontify-version 0.21)
95 (defconst hfy-meta-tags
96 (format "<meta name=\"generator\" content=\"emacs %s; htmlfontify %0.2f\" />"
97 emacs-version htmlfontify-version)
98 "The generator meta tag for this version of htmlfontify.")
100 (defconst htmlfontify-manual "Htmlfontify Manual"
101 "Copy and convert buffers and files to HTML, adding hyperlinks between files
102 \(driven by etags) if requested.
103 \nInteractive functions:
104 `htmlfontify-buffer'
105 `htmlfontify-run-etags'
106 `htmlfontify-copy-and-link-dir'
107 `htmlfontify-load-rgb-file'
108 `htmlfontify-unload-rgb-file'\n
109 In order to:\n
110 fontify a file you have open: \\[htmlfontify-buffer]
111 prepare the etags map for a directory: \\[htmlfontify-run-etags]
112 copy a directory, fontifying as you go: \\[htmlfontify-copy-and-link-dir]\n
113 The following might be useful when running non-windowed or in batch mode:
114 \(note that they shouldn't be necessary - we have a built in map)\n
115 load an X11 style rgb.txt file: \\[htmlfontify-load-rgb-file]
116 unload the current rgb.txt file: \\[htmlfontify-unload-rgb-file]\n
117 And here's a programmatic example:\n
118 \(defun rtfm-build-page-header (file style)
119 (format \"#define TEMPLATE red+black.html
120 #define DEBUG 1
121 #include <build/menu-dirlist|>\\n
122 html-css-url := /css/red+black.css
123 title := rtfm.etla.org ( %s / src/%s )
124 bodytag :=
125 head <=STYLESHEET;\\n
127 STYLESHEET
128 main-title := rtfm / %s / src/%s\\n
129 main-content <=MAIN_CONTENT;\\n\" rtfm-section file style rtfm-section file))
131 \(defun rtfm-build-page-footer (file) \"\\nMAIN_CONTENT\\n\")
133 \(defun rtfm-build-source-docs (section srcdir destdir)
134 (interactive
135 \"s section[eg- emacs / p4-blame]:\\nD source-dir: \\nD output-dir: \")
136 (require 'htmlfontify)
137 (hfy-load-tags-cache srcdir)
138 (let ((hfy-page-header 'rtfm-build-page-header)
139 (hfy-page-footer 'rtfm-build-page-footer)
140 (rtfm-section section)
141 (hfy-index-file \"index\"))
142 (htmlfontify-run-etags srcdir)
143 (htmlfontify-copy-and-link-dir srcdir destdir \".src\" \".html\")))")
145 (defgroup htmlfontify nil
146 "Convert buffers and files to HTML."
147 :group 'applications
148 :link '(variable-link htmlfontify-manual)
149 :link '(custom-manual "(htmlfontify) Top")
150 :link '(info-link "(htmlfontify) Customization")
151 :prefix "hfy-")
153 (defcustom hfy-page-header 'hfy-default-header
154 "Function called to build the header of the HTML source.
155 This is called with two arguments (the filename relative to the top
156 level source directory being etag'd and fontified), and a string containing
157 the <style>...</style> text to embed in the document.
158 It should return a string that will be used as the header for the
159 htmlfontified version of the source file.\n
160 See also `hfy-page-footer'."
161 :group 'htmlfontify
162 ;; FIXME: Why place such a :tag everywhere? Isn't it imposing your
163 ;; own Custom preference on your users? --Stef
164 :tag "page-header"
165 :type '(function))
167 (defcustom hfy-split-index nil
168 "Whether or not to split the index `hfy-index-file' alphabetically.
169 If non-nil, the index is split on the first letter of each tag.
170 Useful when the index would otherwise be large and take
171 a long time to render or be difficult to navigate."
172 :group 'htmlfontify
173 :tag "split-index"
174 :type '(boolean))
176 (defcustom hfy-page-footer 'hfy-default-footer
177 "As `hfy-page-header', but generates the output footer.
178 It takes only one argument, the filename."
179 :group 'htmlfontify
180 :tag "page-footer"
181 :type '(function))
183 (defcustom hfy-extn ".html"
184 "File extension used for output files."
185 :group 'htmlfontify
186 :tag "extension"
187 :type '(string))
189 (defcustom hfy-src-doc-link-style "text-decoration: underline;"
190 "String to add to the '<style> a' variant of an htmlfontify CSS class."
191 :group 'htmlfontify
192 :tag "src-doc-link-style"
193 :type '(string))
195 (defcustom hfy-src-doc-link-unstyle " text-decoration: none;"
196 "Regex to remove from the <style> a variant of an htmlfontify CSS class."
197 :group 'htmlfontify
198 :tag "src-doc-link-unstyle"
199 :type '(string))
201 (defcustom hfy-link-extn nil
202 "File extension used for href links.
203 Useful where the htmlfontify output files are going to be processed
204 again, with a resulting change in file extension. If nil, then any
205 code using this should fall back to `hfy-extn'."
206 :group 'htmlfontify
207 :tag "link-extension"
208 :type '(choice string (const nil)))
210 (defcustom hfy-link-style-fun 'hfy-link-style-string
211 "Function to customize the appearance of hyperlinks.
212 Set this to a function, which will be called with one argument
213 \(a \"{ foo: bar; ...}\" CSS style-string) - it should return a copy of
214 its argument, altered so as to make any changes you want made for text which
215 is a hyperlink, in addition to being in the class to which that style would
216 normally be applied."
217 :group 'htmlfontify
218 :tag "link-style-function"
219 :type '(function))
221 (defcustom hfy-index-file "hfy-index"
222 "Name (sans extension) of the tag definition index file produced during
223 fontification-and-hyperlinking."
224 :group 'htmlfontify
225 :tag "index-file"
226 :type '(string))
228 (defcustom hfy-instance-file "hfy-instance"
229 "Name (sans extension) of the tag usage index file produced during
230 fontification-and-hyperlinking."
231 :group 'htmlfontify
232 :tag "instance-file"
233 :type '(string))
235 (defcustom hfy-html-quote-regex "\\([<\"&>]\\)"
236 "Regex to match (with a single back-reference per match) strings in HTML
237 which should be quoted with `hfy-html-quote' (and `hfy-html-quote-map')
238 to make them safe."
239 :group 'htmlfontify
240 :tag "html-quote-regex"
241 :type '(regexp))
243 (define-obsolete-variable-alias 'hfy-init-kludge-hooks 'hfy-init-kludge-hook
244 "23.2")
245 (defcustom hfy-init-kludge-hook '(hfy-kludge-cperl-mode)
246 "List of functions to call when starting `htmlfontify-buffer' to do any
247 kludging necessary to get highlighting modes to behave as you want, even
248 when not running under a window system."
249 :group 'htmlfontify
250 :tag "init-kludge-hooks"
251 :type '(hook))
253 (define-obsolete-variable-alias 'hfy-post-html-hooks 'hfy-post-html-hook "24.3")
254 (defcustom hfy-post-html-hook nil
255 "List of functions to call after creating and filling the HTML buffer.
256 These functions will be called with the HTML buffer as the current buffer."
257 :group 'htmlfontify
258 :tag "post-html-hooks"
259 :options '(set-auto-mode)
260 :type '(hook))
262 (defcustom hfy-default-face-def nil
263 "Fallback `defface' specification for the face 'default, used when
264 `hfy-display-class' has been set (the normal htmlfontify way of extracting
265 potentially non-current face information doesn't necessarily work for
266 'default).\n
267 Example: I customize this to:\n
268 \((t :background \"black\" :foreground \"white\" :family \"misc-fixed\"))"
269 :group 'htmlfontify
270 :tag "default-face-definition"
271 :type '(alist))
273 (defcustom hfy-etag-regex (concat ".*"
274 "\x7f" "\\([^\x01\n]+\\)"
275 "\x01" "\\([0-9]+\\)"
276 "," "\\([0-9]+\\)$"
277 "\\|" ".*\x7f[0-9]+,[0-9]+$")
278 "Regex used to parse an etags entry: must have 3 subexps, corresponding,
279 in order, to:\n
280 1 - The tag
281 2 - The line
282 3 - The char (point) at which the tag occurs."
283 :group 'htmlfontify
284 :tag "etag-regex"
285 :type '(regexp))
287 (defcustom hfy-html-quote-map '(("\"" "&quot;")
288 ("<" "&lt;" )
289 ("&" "&amp;" )
290 (">" "&gt;" ))
291 "Alist of char -> entity mappings used to make the text HTML-safe."
292 :group 'htmlfontify
293 :tag "html-quote-map"
294 :type '(alist :key-type (string)))
295 (defconst hfy-e2x-etags-cmd "for src in `find . -type f`;
297 ETAGS=%s;
298 case ${src} in
299 *.ad[absm]|*.[CFHMSacfhlmpsty]|*.def|*.in[cs]|*.s[as]|*.src|*.cc|\\
300 *.hh|*.[chy]++|*.[ch]pp|*.[chy]xx|*.pdb|*.[ch]s|*.[Cc][Oo][Bb]|\\
301 *.[eh]rl|*.f90|*.for|*.java|*.[cem]l|*.clisp|*.lisp|*.[Ll][Ss][Pp]|\\
302 [Mm]akefile*|*.pas|*.[Pp][LlMm]|*.psw|*.lm|*.pc|*.prolog|*.oak|\\
303 *.p[sy]|*.sch|*.scheme|*.[Ss][Cc][Mm]|*.[Ss][Mm]|*.bib|*.cl[os]|\\
304 *.ltx|*.sty|*.TeX|*.tex|*.texi|*.texinfo|*.txi|*.x[bp]m|*.yy|\\
305 *.[Ss][Qq][Ll])
306 ${ETAGS} -o- ${src};
309 FTYPE=`file ${src}`;
310 case ${FTYPE} in
311 *script*text*)
312 ${ETAGS} -o- ${src};
314 *text*)
315 SHEBANG=`head -n1 ${src} | grep '#!' -c`;
316 if [ ${SHEBANG} -eq 1 ];
317 then
318 ${ETAGS} -o- ${src};
321 esac;
323 esac;
324 done;")
326 (defconst hfy-etags-cmd-alist-default
327 `(("emacs etags" . ,hfy-e2x-etags-cmd)
328 ("exuberant ctags" . "%s -R -f -" )))
330 (defcustom hfy-etags-cmd-alist
331 hfy-etags-cmd-alist-default
332 "Alist of possible shell commands that will generate etags output that
333 `htmlfontify' can use. '%s' will be replaced by `hfy-etags-bin'."
334 :group 'htmlfontify
335 :tag "etags-cmd-alist"
336 :type '(alist :key-type (string) :value-type (string)))
338 (defcustom hfy-etags-bin "etags"
339 "Location of etags binary (we begin by assuming it's in your path).\n
340 Note that if etags is not in your path, you will need to alter the shell
341 commands in `hfy-etags-cmd-alist'."
342 :group 'htmlfontify
343 :tag "etags-bin"
344 :type '(file))
346 (defcustom hfy-shell-file-name "/bin/sh"
347 "Shell (Bourne or compatible) to invoke for complex shell operations."
348 :group 'htmlfontify
349 :tag "shell-file-name"
350 :type '(file))
352 (defcustom hfy-ignored-properties '(read-only
353 intangible
354 modification-hooks
355 insert-in-front-hooks
356 insert-behind-hooks
357 point-entered
358 point-left)
359 "Properties to omit when copying a fontified buffer for HTML transformation."
360 :group 'htmlfontify
361 :tag "ignored-properties"
362 :type '(repeat symbol))
364 (defun hfy-which-etags ()
365 "Return a string indicating which flavor of etags we are using."
366 (let ((v (shell-command-to-string (concat hfy-etags-bin " --version"))))
367 (cond ((string-match "exube" v) "exuberant ctags")
368 ((string-match "GNU E" v) "emacs etags" )) ))
370 (defcustom hfy-etags-cmd
371 ;; We used to wrap this in a `eval-and-compile', but:
372 ;; - it had no effect because this expression was not seen by the
373 ;; byte-compiler (defcustom used to quote this argument).
374 ;; - it signals an error (`hfy-which-etags' is not defined at compile-time).
375 ;; - we want this auto-detection to reflect the system on which Emacs is run
376 ;; rather than the one on which it's compiled.
377 (cdr (assoc (hfy-which-etags) hfy-etags-cmd-alist))
378 "The etags equivalent command to run in a source directory to generate a tags
379 file for the whole source tree from there on down. The command should emit
380 the etags output on stdout.\n
381 Two canned commands are provided - they drive Emacs's etags and
382 exuberant-ctags' etags respectively."
383 :group 'htmlfontify
384 :tag "etags-command"
385 :type (let ((clist (list '(string))))
386 (dolist (C hfy-etags-cmd-alist)
387 (push (list 'const :tag (car C) (cdr C)) clist))
388 (cons 'choice clist)))
390 (defcustom hfy-istext-command "file %s | sed -e 's@^[^:]*:[ \t]*@@'"
391 "Command to run with the name of a file, to see whether it is a text file
392 or not. The command should emit a string containing the word 'text' if
393 the file is a text file, and a string not containing 'text' otherwise."
394 :group 'htmlfontify
395 :tag "istext-command"
396 :type '(string))
398 (defcustom hfy-find-cmd
399 "find . -type f \\! -name \\*~ \\! -name \\*.flc \\! -path \\*/CVS/\\*"
400 "Find command used to harvest a list of files to attempt to fontify."
401 :group 'htmlfontify
402 :tag "find-command"
403 :type '(string))
405 (defcustom hfy-display-class nil
406 "Display class to use to determine which display class to use when
407 calculating a face's attributes. This is useful when, for example, you
408 are running Emacs on a tty or in batch mode, and want htmlfontify to have
409 access to the face spec you would use if you were connected to an X display.\n
410 Some valid class specification elements are:\n
411 '(class color)
412 '(class grayscale)
413 '(background dark)
414 '(background light)
415 '(type x-toolkit)
416 '(type tty)
417 '(type motif)
418 '(type lucid)
419 Multiple values for a tag may be combined, to indicate that any one or more
420 of these values in the specification key constitutes a match, eg:\n
421 '((class color grayscale) (type tty)) would match any of:\n
422 '((class color))
423 '((class grayscale))
424 '((class color grayscale))
425 '((class color foo))
426 '((type tty))
427 '((type tty) (class color))\n
428 and so on."
429 :type '(alist :key-type (symbol) :value-type (symbol))
430 :group 'htmlfontify
431 :tag "display-class"
432 :options '((type (choice (const :tag "X11" x-toolkit)
433 (const :tag "Terminal" tty )
434 (const :tag "Lucid Toolkit" lucid )
435 (const :tag "Motif Toolkit" motif )))
437 (class (choice (const :tag "Color" color )
438 (const :tag "Grayscale" grayscale)))
440 (background (choice (const :tag "Dark" dark )
441 (const :tag "Bright" light ))) ))
443 (defcustom hfy-optimisations (list 'keep-overlays)
444 "Optimizations to turn on: So far, the following have been implemented:\n
445 merge-adjacent-tags: If two (or more) span tags are adjacent, identical and
446 separated by nothing more than whitespace, they will
447 be merged into one span.
448 zap-comment-links : Suppress hyperlinking of tags found in comments.
449 zap-string-links : Suppress hyperlinking of tags found in strings.
450 div-wrapper : Add <div class=\"default\"> </div> tags around the
451 output.
452 keep-overlays : More of a bell (or possibly whistle) than an
453 optimization - If on, preserve overlay highlighting
454 (cf ediff or goo-font-lock) as well as basic faces.\n
455 body-text-only : Emit only body-text. In concrete terms,
456 1. Suppress calls to `hfy-page-header'and
457 `hfy-page-footer'
458 2. Pretend that `div-wrapper' option above is
459 turned off
460 3. Don't enclose output in <pre> </pre> tags
461 And the following are planned but not yet available:\n
462 kill-context-leak : Suppress hyperlinking between files highlighted by
463 different modes.\n
464 Note: like compiler optimizations, these optimize the _output_ of the code,
465 not the processing of the source itself, and are therefore likely to slow
466 htmlfontify down, at least a little. Except for skip-refontification,
467 which can never slow you down, but may result in incomplete fontification."
468 :type '(set (const :tag "merge-adjacent-tags" merge-adjacent-tags )
469 (const :tag "zap-comment-links" zap-comment-links )
470 (const :tag "zap-string-links" zap-string-links )
471 (const :tag "skip-refontification" skip-refontification)
472 (const :tag "kill-context-leak" kill-context-leak )
473 (const :tag "div-wrapper" div-wrapper )
474 (const :tag "keep-overlays" keep-overlays )
475 (const :tag "body-text-only" body-text-only ))
476 :group 'htmlfontify
477 :tag "optimizations")
479 (defvar hfy-tags-cache nil
480 "Alist of the form:\n
481 \((\"/src/dir/0\" . tag-hash0) (\"/src/dir/1\" tag-hash1) ...)\n
482 Each tag hash entry then contains entries of the form:\n
483 \"tag_string\" => ((\"file/name.ext\" line char) ... )\n
484 ie an alist mapping (relative) file paths to line and character offsets.\n
485 See also `hfy-load-tags-cache'.")
487 (defvar hfy-tags-sortl nil
488 "Alist of the form ((\"/src/dir\" . (tag0 tag1 tag2)) ... )\n
489 where the tags are stored in descending order of length.\n
490 See also `hfy-load-tags-cache'.")
492 (defvar hfy-tags-rmap nil
493 "Alist of the form ((\"/src/dir\" . tag-rmap-hash))\n
494 where tag-rmap-hash has entries of the form:
495 \"tag_string\" => ( \"file/name.ext\" line char )
496 Unlike `hfy-tags-cache' these are the locations of occurrences of
497 tagged items, not the locations of their definitions.")
499 (defvar hfy-style-assoc 'please-ignore-this-line
500 "An assoc representing/describing an Emacs face.
501 Properties may be repeated, in which case later properties should be
502 treated as if they were inherited from a 'parent' font.
503 \(For some properties, only the first encountered value is of any importance,
504 for others the values might be cumulative, and for others they might be
505 cumulative in a complex way.)\n
506 Some examples:\n
507 \(hfy-face-to-style 'default) =>
508 ((\"background\" . \"rgb(0, 0, 0)\")
509 (\"color\" . \"rgb(255, 255, 255)\")
510 (\"font-style\" . \"normal\")
511 (\"font-weight\" . \"500\")
512 (\"font-stretch\" . \"normal\")
513 (\"font-family\" . \"misc-fixed\")
514 (\"font-size\" . \"13pt\")
515 (\"text-decoration\" . \"none\"))\n
516 \(hfy-face-to-style 'Info-title-3-face) =>
517 ((\"font-weight\" . \"700\")
518 (\"font-family\" . \"helv\")
519 (\"font-size\" . \"120%\")
520 (\"text-decoration\" . \"none\"))\n")
522 (defvar hfy-sheet-assoc 'please-ignore-this-line
523 "An assoc with elements of the form (face-name style-name . style-string):\n
524 '((default \"default\" . \"{background: black; color: white}\")
525 (font-lock-string-face \"string\" . \"{color: rgb(64,224,208)}\"))" )
527 (defvar hfy-facemap-assoc 'please-ignore-this-line
528 "An assoc of (point . FACE-SYMBOL) or (point . DEFFACE-LIST)
529 and (point . 'end) elements, in descending order of point value
530 \(ie from the file's end to its beginning).\n
531 The map is in reverse order because inserting a <style> tag (or any other
532 string) at `point' invalidates the map for all entries with a greater value of
533 point. By traversing the map from greatest to least point, we still invalidate
534 the map as we go, but only those points we have already dealt with (and
535 therefore no longer care about) will be invalid at any time.\n
536 '((64820 . end)
537 (64744 . font-lock-comment-face)
538 (64736 . end)
539 (64722 . font-lock-string-face)
540 (64630 . end)
541 (64623 . font-lock-string-face)
542 (64449 . end)
543 (64446 . font-lock-keyword-face)
544 (64406 . end)
545 (64395 . font-lock-constant-face)
546 (64393 . end)
547 (64386 . font-lock-keyword-face)
548 (64379 . end)
549 ;; big similar section elided. You get the idea.
550 (4285 . font-lock-constant-face)
551 (4285 . end)
552 (4221 . font-lock-comment-face)
553 (4221 . end)
554 (4197 . font-lock-constant-face)
555 (4197 . end)
556 (1 . font-lock-comment-face))")
558 (defvar hfy-tmpfont-stack nil
559 "An alist of derived fonts resulting from overlays.")
561 (defconst hfy-hex-regex "[0-9A-Fa-f]")
563 (defconst hfy-triplet-regex
564 (concat
565 "\\(" hfy-hex-regex hfy-hex-regex "\\)"
566 "\\(" hfy-hex-regex hfy-hex-regex "\\)"
567 "\\(" hfy-hex-regex hfy-hex-regex "\\)"))
569 (defun hfy-interq (set-a set-b)
570 "Return the intersection (using `eq') of two lists SET-A and SET-B."
571 (let ((sa set-a) (interq nil) (elt nil))
572 (while sa
573 (setq elt (car sa)
574 sa (cdr sa))
575 (if (memq elt set-b) (setq interq (cons elt interq))))
576 interq))
578 (defun hfy-colour-vals (colour)
579 "Where COLOUR is a color name or #XXXXXX style triplet, return a
580 list of three (16 bit) rgb values for said color.\n
581 If a window system is unavailable, calls `hfy-fallback-colour-values'."
582 (if (string-match hfy-triplet-regex colour)
583 (mapcar
584 (lambda (x) (* (string-to-number (match-string x colour) 16) 257))
585 '(1 2 3))
586 ;;(message ">> %s" colour)
587 (if window-system
588 (if (fboundp 'color-values)
589 (color-values colour)
590 ;;(message "[%S]" window-system)
591 (x-color-values colour))
592 ;; blarg - tty colors are no good - go fetch some X colors:
593 (hfy-fallback-colour-values colour))))
595 (defvar hfy-cperl-mode-kludged-p nil)
597 (defun hfy-kludge-cperl-mode ()
598 "CPerl mode does its damnedest not to do some of its fontification when not
599 in a windowing system - try to trick it..."
600 (if (not hfy-cperl-mode-kludged-p)
601 (progn (if (not window-system)
602 (let ((window-system 'htmlfontify))
603 (eval-and-compile (require 'cperl-mode))
604 (setq cperl-syntaxify-by-font-lock t)))
605 (setq hfy-cperl-mode-kludged-p t))) )
607 (defun hfy-opt (symbol)
608 "Is option SYMBOL set."
609 (memq symbol hfy-optimisations))
611 (defun hfy-default-header (file style)
612 "Default value for `hfy-page-header'.
613 FILE is the name of the file.
614 STYLE is the inline CSS stylesheet (or tag referring to an external sheet)."
615 ;; (format "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
616 ;; <html>\n <head>\n <title>%s</title>\n %s\n </head>\n <body>\n" file style))
617 (format "<?xml version=\"1.0\" encoding=\"utf-8\"?>
618 <!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\"
619 \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">
620 <html xmlns=\"http://www.w3.org/1999/xhtml\">
621 <head>
622 <title>%s</title>
624 <script type=\"text/javascript\"><!--
625 // this function is needed to work around
626 // a bug in IE related to element attributes
627 function hasClass(obj)
629 var result = false;
630 if (obj.getAttributeNode(\"class\") != null)
632 result = obj.getAttributeNode(\"class\").value;
634 return result;
637 function stripe(id)
639 // the flag we'll use to keep track of
640 // whether the current row is odd or even
641 var even = false;
643 // if arguments are provided to specify the colors
644 // of the even & odd rows, then use the them;
645 // otherwise use the following defaults:
646 var evenColor = arguments[1] ? arguments[1] : \"#fff\";
647 var oddColor = arguments[2] ? arguments[2] : \"#ddd\";
649 // obtain a reference to the desired table
650 // if no such table exists, abort
651 var table = document.getElementById(id);
652 if (! table) { return; }
654 // by definition, tables can have more than one tbody
655 // element, so we'll have to get the list of child
656 // &lt;tbody&gt;s
657 var tbodies = table.getElementsByTagName(\"tbody\");
659 // and iterate through them...
660 for (var h = 0; h < tbodies.length; h++)
662 // find all the &lt;tr&gt; elements...
663 var trs = tbodies[h].getElementsByTagName(\"tr\");
665 // ... and iterate through them
666 for (var i = 0; i < trs.length; i++)
668 // avoid rows that have a class attribute
669 // or backgroundColor style
670 if (! hasClass(trs[i]) &&
671 ! trs[i].style.backgroundColor)
673 // get all the cells in this row...
674 var tds = trs[i].getElementsByTagName(\"td\");
676 // and iterate through them...
677 for (var j = 0; j < tds.length; j++)
679 var mytd = tds[j];
681 // avoid cells that have a class attribute
682 // or backgroundColor style
683 if (! hasClass(mytd) &&
684 ! mytd.style.backgroundColor)
686 mytd.style.backgroundColor =
687 even ? evenColor : oddColor;
691 // flip from odd to even, or vice-versa
692 even = ! even;
697 function toggle_invis( name )
699 var filter =
700 { acceptNode:
701 function( node )
702 { var classname = node.id;
703 if( classname )
704 { var classbase = classname.substr( 0, name.length );
705 if( classbase == name ) { return NodeFilter.FILTER_ACCEPT; } }
706 return NodeFilter.FILTER_SKIP; } };
707 var walker = document.createTreeWalker( document.body ,
708 NodeFilter.SHOW_ELEMENT ,
709 filter ,
710 false );
711 while( walker.nextNode() )
713 var e = walker.currentNode;
714 if( e.style.display == \"none\" ) { e.style.display = \"inline\"; }
715 else { e.style.display = \"none\"; }
718 --> </script>
719 </head>
720 <body onload=\"stripe('index'); return true;\">\n"
721 (mapconcat 'hfy-html-quote (mapcar 'char-to-string file) "") style))
723 (defun hfy-default-footer (_file)
724 "Default value for `hfy-page-footer'.
725 FILE is the name of the file being rendered, in case it is needed."
726 "\n </body>\n</html>\n")
728 (defun hfy-link-style-string (style-string)
729 "Replace the end of a CSS style declaration STYLE-STRING with the contents
730 of the variable `hfy-src-doc-link-style', removing text matching the regex
731 `hfy-src-doc-link-unstyle' first, if necessary."
732 ;;(message "hfy-colour-vals");;DBUG
733 (if (string-match hfy-src-doc-link-unstyle style-string)
734 (setq style-string (replace-match "" 'fixed-case 'literal style-string)))
735 (if (and (not (string-match hfy-src-doc-link-style style-string))
736 (string-match "} *$" style-string))
737 (concat (replace-match hfy-src-doc-link-style
738 'fixed-case
739 'literal
740 style-string) " }")
741 style-string))
743 ;; utility functions - cast emacs style specification values into their
744 ;; css2 equivalents:
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 color you are processing) strange things
750 may happen."
751 ;;(message "hfy-colour-vals");;DBUG
752 ;; TODO? Can we do somehow do better than this?
753 (cond
754 ((equal colour "unspecified-fg") (setq colour "black"))
755 ((equal colour "unspecified-bg") (setq colour "white")))
756 (let ((white (mapcar (lambda (I) (float (1+ I))) (hfy-colour-vals "white")))
757 (rgb16 (mapcar (lambda (I) (float (1+ I))) (hfy-colour-vals colour))))
758 (if rgb16
759 ;;(apply 'format "rgb(%d, %d, %d)"
760 ;; Use #rrggbb instead, it is smaller
761 (apply 'format "#%02x%02x%02x"
762 (mapcar (lambda (X)
763 (* (/ (nth X rgb16)
764 (nth X white)) 255))
765 '(0 1 2))))))
767 (defun hfy-family (family) (list (cons "font-family" family)))
768 (defun hfy-bgcol (colour) (list (cons "background" (hfy-triplet colour))))
769 (defun hfy-colour (colour) (list (cons "color" (hfy-triplet colour))))
770 (defun hfy-width (width) (list (cons "font-stretch" (symbol-name width))))
772 (defcustom hfy-font-zoom 1.05
773 "Font scaling from Emacs to HTML."
774 :type 'float
775 :group 'htmlfontify)
777 (defun hfy-size (height)
778 "Derive a CSS font-size specifier from an Emacs font :height attribute HEIGHT.
779 Does not cope with the case where height is a function to be applied to
780 the height of the underlying font."
781 ;; In ttys, the default face has :height == 1.
782 (and (not (display-graphic-p)) (equal 1 height) (setq height 100))
783 (list
784 (cond
785 ;;(t (cons "font-size" ": 1em"))
786 ((floatp height)
787 (cons "font-size" (format "%d%%" (* (* hfy-font-zoom height) 100))))
788 ((integerp height)
789 (cons "font-size" (format "%dpt" (/ (* hfy-font-zoom height) 10 )))) )) )
791 (defun hfy-slant (slant)
792 "Derive a font-style CSS specifier from the Emacs :slant attribute SLANT:
793 CSS does not define the reverse-* styles, so just maps those to the
794 regular specifiers."
795 (list (cons "font-style"
796 (or (cdr (assq slant '((italic . "italic")
797 (reverse-italic . "italic" )
798 (oblique . "oblique")
799 (reverse-oblique . "oblique"))))
800 "normal"))))
802 (defun hfy-weight (weight)
803 "Derive a font-weight CSS specifier from an Emacs weight spec symbol WEIGHT."
804 (list (cons "font-weight" (cdr (assq weight '((ultra-bold . "900")
805 (extra-bold . "800")
806 (bold . "700")
807 (semi-bold . "600")
808 (normal . "500")
809 (semi-light . "400")
810 (light . "300")
811 (extra-light . "200")
812 (ultra-light . "100")))))))
814 (defun hfy-box-to-border-assoc (spec)
815 (if spec
816 (let ((tag (car spec))
817 (val (cadr spec)))
818 (cons (case tag
819 (:color (cons "colour" val))
820 (:width (cons "width" val))
821 (:style (cons "style" val)))
822 (hfy-box-to-border-assoc (cddr spec))))))
824 (defun hfy-box-to-style (spec)
825 (let* ((css (hfy-box-to-border-assoc spec))
826 (col (cdr (assoc "colour" css)))
827 (s (cdr (assoc "style" css))))
828 (list
829 (if col (cons "border-color" (cdr (assoc "colour" css))))
830 (cons "border-width" (format "%dpx" (or (cdr (assoc "width" css)) 1)))
831 (cons "border-style" (case s
832 (released-button "outset")
833 (pressed-button "inset" )
834 (t "solid" ))))))
836 (defun hfy-box (box)
837 "Derive CSS border-* attributes from the Emacs :box attribute BOX."
838 (if box
839 (cond
840 ((integerp box) (list (cons "border-width" (format "%dpx" box))))
841 ((stringp box) (list (cons "border" (format "solid %s 1px" box))))
842 ((listp box) (hfy-box-to-style box) ))) )
844 (defun hfy-decor (tag _val)
845 "Derive CSS text-decoration specifiers from various Emacs font attributes.
846 TAG is an Emacs font attribute key (eg :underline).
847 VAL is ignored."
848 (list
849 ;; FIXME: Why not '("text-decoration" . "underline")? --Stef
850 (case tag
851 (:underline (cons "text-decoration" "underline" ))
852 (:overline (cons "text-decoration" "overline" ))
853 (:strike-through (cons "text-decoration" "line-through")))))
855 (defun hfy-invisible (&optional _val)
856 "This text should be invisible.
857 Do something in CSS to make that happen.
858 VAL is ignored here."
859 '(("display" . "none")))
861 (defun hfy-combined-face-spec (face)
862 "Return a `defface' style alist of possible specifications for FACE.
863 Entries resulting from customization (`custom-set-faces') will take
864 precedence."
865 (append
866 (if (and hfy-display-class hfy-default-face-def (eq face 'default))
867 hfy-default-face-def)
868 (get face 'saved-face)
869 (get face 'face-defface-spec)))
871 (defun hfy-face-attr-for-class (face &optional class)
872 "Return the face attributes for FACE.
873 If CLASS is set, it must be a `defface' alist key [see below],
874 in which case the first face specification returned by `hfy-combined-face-spec'
875 which *doesn't* clash with CLASS is returned.\n
876 \(A specification with a class of t is considered to match any class you
877 specify - this matches Emacs's behavior when deciding on which face attributes
878 to use, to the best of my understanding).\n
879 If CLASS is nil, then you just get whatever `face-attr-construct' returns,
880 ie the current specification in effect for FACE.\n
881 *NOTE*: This function forces any face that is not 'default and which has
882 no :inherit property to inherit from 'default (this is because 'default
883 is magical in that Emacs's fonts behave as if they inherit implicitly from
884 'default, but no such behavior exists in HTML/CSS).\n
885 See also `hfy-display-class' for details of valid values for CLASS."
886 (let ((face-spec
887 (if class
888 (let ((face-props (hfy-combined-face-spec face))
889 (face-specn nil)
890 (face-class nil)
891 (face-attrs nil)
892 (face-score -1)
893 (face-match nil))
894 (while face-props
895 (setq face-specn (car face-props)
896 face-class (car face-specn)
897 face-attrs (cdr face-specn)
898 face-props (cdr face-props))
899 ;; if the current element CEL of CLASS is t we match
900 ;; if the current face-class is t, we match
901 ;; if the cdr of CEL has a non-nil
902 ;; intersection with the cdr of the first member of
903 ;; the current face-class with the same car as CEL, we match
904 ;; if we actually clash, then we can't match
905 (let ((cbuf class)
906 (cel nil)
907 (key nil)
908 (val nil)
909 (x nil)
910 (next nil)
911 (score 0))
912 (while (and cbuf (not next))
913 (setq cel (car cbuf)
914 cbuf (cdr cbuf)
915 key (car cel)
916 val (cdr cel)
917 val (if (listp val) val (list val)))
918 (cond
919 ((or (eq cel t)
920 (memq face-class '(t default))) ;Default match.
921 (setq score 0) (ignore "t match"))
922 ((not (cdr (assq key face-class))) ;Neither good nor bad.
923 nil (ignore "non match, non collision"))
924 ((setq x (hfy-interq val (cdr (assq key face-class))))
925 (setq score (+ score (length x)))
926 (ignore "intersection"))
927 (t ;; nope.
928 (setq next t score -10) (ignore "collision")) ))
929 (if (> score face-score)
930 (progn
931 (setq face-match face-attrs
932 face-score score )
933 (ignore "%d << %S/%S" score face-class class))
934 (ignore "--- %d ---- (insufficient)" score)) ))
935 ;; matched ? last attrs : nil
936 (if face-match
937 (if (listp (car face-match)) (car face-match) face-match)
938 nil))
939 ;; Unfortunately the default face returns a
940 ;; :background. Fortunately we can remove it, but how do we do
941 ;; that in a non-system specific way?
942 (let ((spec (face-attr-construct face))
943 (new-spec nil))
944 (if (not (memq :background spec))
945 spec
946 (while spec
947 (let ((a (nth 0 spec))
948 (b (nth 1 spec)))
949 (unless (and (eq a :background)
950 (stringp b)
951 (string= b "SystemWindow"))
952 (setq new-spec (cons a (cons b new-spec)))))
953 (setq spec (cddr spec)))
954 new-spec)))))
955 (if (or (memq :inherit face-spec) (eq 'default face))
956 face-spec
957 (append face-spec (list :inherit 'default)))))
959 ;; construct an assoc of (css-tag-name . css-tag-value) pairs
960 ;; from a face or assoc of face attributes:
962 ;; Some tests etc:
963 ;; (mumamo-message-with-face "testing face" 'highlight)
964 ;; (mumamo-message-with-face "testing face" '(:foreground "red" :background "yellow"))
965 ;; (hfy-face-to-style-i '(:inherit default foreground-color "red"))
966 ;; default face=(:stipple nil :background "SystemWindow" :foreground
967 ;; "SystemWindowText" :inverse-video nil :box nil :strike-through
968 ;; nil :overline nil :underline nil :slant normal :weight normal
969 ;; :height 98 :width normal :family "outline-courier new")
970 (defun hfy-face-to-style-i (fn)
971 "The guts of `hfy-face-to-style': FN should be a `defface' font spec,
972 as returned by `face-attr-construct' or `hfy-face-attr-for-class'.
973 Note that this function does not get font-sizes right if they are based
974 on inherited modifiers (via the :inherit) attribute, and any other
975 modifiers that are cumulative if they appear multiple times need to be
976 merged by the user - `hfy-flatten-style' should do this."
977 ;;(message "hfy-face-to-style-i");;DBUG
979 ;; fn's value could be something like
980 ;; (:inherit
981 ;; ((foreground-color . "blue"))
982 ;; (foreground-color . "blue")
983 ;; nil)
985 (when fn
986 (let ((key (car fn))
987 (val (cadr fn))
988 (next (cddr fn))
989 (that nil)
990 (this nil)
991 (parent nil))
992 (if (eq key :inherit)
993 (let ((vs (if (listp val) val (list val))))
994 ;; (let ((x '(a b))) (setq x (append '(c d) x)))
995 ;; (let ((x '(a b))) (setq x (append '(c d) x)))
996 (dolist (v vs)
997 (setq parent
998 (append
999 parent
1000 (hfy-face-to-style-i
1001 (hfy-face-attr-for-class v hfy-display-class)) ))))
1002 (setq this
1003 (if val (case key
1004 (:family (hfy-family val))
1005 (:width (hfy-width val))
1006 (:weight (hfy-weight val))
1007 (:slant (hfy-slant val))
1008 (:foreground (hfy-colour val))
1009 (:background (hfy-bgcol val))
1010 (:box (hfy-box val))
1011 (:height (hfy-size val))
1012 (:underline (hfy-decor key val))
1013 (:overline (hfy-decor key val))
1014 (:strike-through (hfy-decor key val))
1015 (:invisible (hfy-invisible val))
1016 (:bold (hfy-weight 'bold))
1017 (:italic (hfy-slant 'italic))))))
1018 (setq that (hfy-face-to-style-i next))
1019 ;;(lwarn t :warning "%S => %S" fn (nconc this that parent))
1020 (nconc this that parent))) )
1022 (defun hfy-size-to-int (spec)
1023 "Convert SPEC, a CSS font-size specifier, to an Emacs :height attribute value.
1024 Used while merging multiple font-size attributes."
1025 ;;(message "hfy-size-to-int");;DBUG
1026 (list
1027 (if (string-match "\\([0-9]+\\)\\(%\\|pt\\)" spec)
1028 (cond ((string= "%" (match-string 2 spec))
1029 (/ (string-to-number (match-string 1 spec)) 100.0))
1030 ((string= "pt" (match-string 2 spec))
1031 (* (string-to-number (match-string 1 spec)) 10)))
1032 (string-to-number spec))) )
1034 ;; size is different, in that in order to get it right at all,
1035 ;; we have to trawl the inheritance path, accumulating modifiers,
1036 ;; _until_ we get to an absolute (pt) specifier, then combine the lot
1037 (defun hfy-flatten-style (style)
1038 "Take STYLE (see `hfy-face-to-style-i', `hfy-face-to-style') and merge
1039 any multiple attributes appropriately. Currently only font-size is merged
1040 down to a single occurrence - others may need special handling, but I
1041 haven't encountered them yet. Returns a `hfy-style-assoc'."
1042 ;;(message "(hfy-flatten-style %S)" style) ;;DBUG
1043 (let ((n 0)
1044 (m (list 1))
1045 (x nil)
1046 (r nil))
1047 (dolist (css style)
1048 (if (string= (car css) "font-size")
1049 (progn
1050 (when (not x) (setq m (nconc m (hfy-size-to-int (cdr css)))))
1051 (when (string-match "pt" (cdr css)) (setq x t)))
1052 (setq r (nconc r (list css)))))
1053 ;;(message "r: %S" r)
1054 (setq n (apply '* m))
1055 (nconc r (hfy-size (if x (round n) (* n 1.0)))) ))
1057 (defun hfy-face-resolve-face (fn)
1058 (cond
1059 ((facep fn)
1060 (hfy-face-attr-for-class fn hfy-display-class))
1061 ((and (symbolp fn)
1062 (facep (symbol-value fn)))
1063 (hfy-face-attr-for-class (symbol-value fn) hfy-display-class))
1064 (t nil)))
1067 (defun hfy-face-to-style (fn)
1068 "Take FN, a font or `defface' style font specification,
1069 \(as returned by `face-attr-construct' or `hfy-face-attr-for-class')
1070 and return a `hfy-style-assoc'.\n
1071 See also `hfy-face-to-style-i', `hfy-flatten-style'."
1072 ;;(message "hfy-face-to-style");;DBUG
1073 (let* ((face-def (hfy-face-resolve-face fn))
1074 (final-style
1075 (hfy-flatten-style (hfy-face-to-style-i face-def))))
1076 ;;(message "%S" final-style)
1077 (if (not (assoc "text-decoration" final-style))
1078 (progn (setq final-style
1079 ;; Fix-me: there is no need for this since
1080 ;; text-decoration is not inherited.
1081 ;; but it's not wrong and if this ever changes it will
1082 ;; be needed, so I think it's better to leave it in? -- v
1083 (nconc final-style '(("text-decoration" . "none"))))))
1084 final-style))
1086 ;; strip redundant bits from a name. Technically, this could result in
1087 ;; a collision, but it is pretty unlikely - will fix later...
1088 ;; also handle ephemeral fonts created by overlays, which don't actually
1089 ;; have names:
1090 (defun hfy-face-or-def-to-name (fn)
1091 "Render a font symbol or `defface' font spec FN into a name (string)."
1092 ;;(message "generating name for %s" fn)
1093 (if (not (listp fn))
1094 (format "%s" fn)
1095 (let* ((key (format "%s" fn))
1096 (entry (assoc key hfy-tmpfont-stack))
1097 (base (cadr (memq :inherit fn)))
1098 (tag (cdr entry)))
1099 ;;(message "checking for key «%s» in font stack [%d]"
1100 ;; key (if entry 1 0))
1101 (if entry nil ;; noop
1102 (setq tag (format "%04d" (length hfy-tmpfont-stack))
1103 entry (cons key tag)
1104 hfy-tmpfont-stack (cons entry hfy-tmpfont-stack)))
1105 ;;(message " -> name: %s-%s" (or base 'default) tag)
1106 (format "%s-%s" (or base 'default) tag)) ))
1108 (defun hfy-css-name (fn)
1109 "Strip the boring bits from a font-name FN and return a CSS style name."
1110 ;;(message "hfy-css-name");;DBUG
1111 (let ((face-name (hfy-face-or-def-to-name fn)))
1112 (if (or (string-match "font-lock-\\(.*\\)" face-name)
1113 (string-match "cperl-\\(.*\\)" face-name)
1114 (string-match "^[Ii]nfo-\\(.*\\)" face-name))
1115 (progn
1116 (setq face-name (match-string 1 face-name))
1117 (if (string-match "\\(.*\\)-face\\'" face-name)
1118 (setq face-name (match-string 1 face-name)))
1119 face-name)
1120 face-name)) )
1122 ;; construct an assoc of (stripped-name . "{ css-stuff-here }") pairs
1123 ;; from a face:
1124 (defun hfy-face-to-css-default (fn)
1125 "Default handler for mapping faces to styles.
1126 See also `hfy-face-to-css'."
1127 ;;(message "hfy-face-to-css");;DBUG
1128 (let* ((css-list (hfy-face-to-style fn))
1129 (seen nil)
1130 (css-text
1131 (mapcar
1132 (lambda (E)
1133 (if (car E)
1134 (unless (member (car E) seen)
1135 (push (car E) seen)
1136 (format " %s: %s; " (car E) (cdr E)))))
1137 css-list)))
1138 (cons (hfy-css-name fn) (format "{%s}" (apply 'concat css-text)))) )
1140 (defvar hfy-face-to-css 'hfy-face-to-css-default
1141 "Handler for mapping faces to styles.
1142 The signature of the handler is of the form \(lambda (FN) ...\).
1143 FN is a font or `defface' specification (cf
1144 `face-attr-construct'). The handler should return a cons cell of
1145 the form (STYLE-NAME . STYLE-SPEC).
1147 The default handler is `hfy-face-to-css-default'.
1149 See also `hfy-face-to-style'.")
1151 (defalias 'hfy-prop-invisible-p
1152 (if (fboundp 'invisible-p) #'invisible-p
1153 (lambda (prop)
1154 "Is text property PROP an active invisibility property?"
1155 (or (and (eq buffer-invisibility-spec t) prop)
1156 (or (memq prop buffer-invisibility-spec)
1157 (assq prop buffer-invisibility-spec))))))
1159 (defun hfy-find-invisible-ranges ()
1160 "Return a list of (start-point . end-point) cons cells of invisible regions."
1161 (save-excursion
1162 (let (invisible p i s) ;; return-value pos invisible end start
1163 (setq p (goto-char (point-min)))
1164 (when (invisible-p p) (setq s p i t))
1165 (while (< p (point-max))
1166 (if i ;; currently invisible
1167 (when (not (invisible-p p)) ;; but became visible
1168 (setq i nil
1169 invisible (cons (cons s p) invisible)))
1170 ;; currently visible:
1171 (when (invisible-p p) ;; but have become invisible
1172 (setq s p i t)))
1173 (setq p (next-char-property-change p)))
1174 ;; still invisible at buffer end?
1175 (when i
1176 (setq invisible (cons (cons s (point-max)) invisible)))
1177 invisible)))
1179 (defun hfy-invisible-name (point map)
1180 "Generate a CSS style name for an invisible section of the buffer.
1181 POINT is the point inside the invisible region.
1182 MAP is the invisibility map as returned by `hfy-find-invisible-ranges'."
1183 ;;(message "(hfy-invisible-name %S %S)" point map)
1184 (let (name)
1185 (dolist (range map)
1186 (when (and (>= point (car range))
1187 (< point (cdr range)))
1188 (setq name (format "invisible-%S-%S" (car range) (cdr range)))))
1189 name))
1191 ;; Fix-me: This function needs some cleanup by someone who understand
1192 ;; all the formats that face properties can have.
1194 ;; overlay handling should be fine. haven't tested multiple stacked overlapping
1195 ;; overlays recently, but the common case of a text property face + an overlay
1196 ;; face produces the correct merged css style (or as close to it as css can get)
1197 ;; -- v
1198 (defun hfy-face-at (p)
1199 "Find face in effect at point P.
1200 If overlays are to be considered (see `hfy-optimisations') then this may
1201 return a `defface' style list of face properties instead of a face symbol."
1202 ;;(message "hfy-face-at");;DBUG
1203 ;; Fix-me: clean up, remove face-name etc
1204 ;; not sure why we'd want to remove face-name? -- v
1205 (let ((overlay-data nil)
1206 (base-face nil)
1207 (face-name (get-text-property p 'face))
1208 ;; (face-name (hfy-get-face-at p))
1209 (prop-seen nil)
1210 (extra-props nil)
1211 (text-props (text-properties-at p)))
1212 ;;(message "face-name: %S" face-name)
1213 (when (and face-name (listp face-name) (facep (car face-name)))
1214 ;;(message "face-name is a list %S" face-name)
1215 ;;(setq text-props (cons 'face face-name))
1216 (dolist (f face-name)
1217 (setq extra-props (if (listp f)
1218 ;; for things like (variable-pitch
1219 ;; (:foreground "red"))
1220 (cons f extra-props)
1221 (cons :inherit (cons f extra-props)))))
1222 (setq base-face (car face-name)
1223 face-name nil))
1224 ;; text-properties-at => (face (:foreground "red" ...))
1225 ;; or => (face (compilation-info underline)) list of faces
1226 ;; overlay-properties
1227 ;; format= (evaporate t face ((foreground-color . "red")))
1229 ;; SO: if we have turned overlays off,
1230 ;; or if there's no overlay data
1231 ;; just bail out and return whatever face data we've accumulated so far
1232 (if (or (not (hfy-opt 'keep-overlays))
1233 (not (setq overlay-data (hfy-overlay-props-at p))))
1234 (progn
1235 ;;(message "· %d: %s; %S; %s"
1236 ;; p face-name extra-props text-props)
1237 (or face-name base-face)) ;; no overlays or extra properties
1238 ;; collect any face data and any overlay data for processing:
1239 (when text-props
1240 (push text-props overlay-data))
1241 (setq overlay-data (nreverse overlay-data))
1242 ;;(message "- %d: %s; %S; %s; %s"
1243 ;; p face-name extra-props text-props overlay-data)
1244 ;; remember the basic face name so we don't keep repeating its specs:
1245 (when face-name (setq base-face face-name))
1246 (dolist (P overlay-data)
1247 (let ((iprops (cadr (memq 'invisible P)))) ;FIXME: plist-get?
1248 ;;(message "(hfy-prop-invisible-p %S)" iprops)
1249 (when (and iprops (hfy-prop-invisible-p iprops))
1250 (setq extra-props
1251 (cons :invisible (cons t extra-props))) ))
1252 (let ((fprops (cadr (or (memq 'face P)
1253 (memq 'font-lock-face P)))))
1254 ;;(message "overlay face: %s" fprops)
1255 (if (not (listp fprops))
1256 (let ((this-face (if (stringp fprops) (intern fprops) fprops)))
1257 (when (not (eq this-face base-face))
1258 (setq extra-props
1259 (cons :inherit
1260 (cons this-face extra-props))) ))
1261 (while fprops
1262 (if (facep (car fprops))
1263 (let ((face (car fprops)))
1264 (when (stringp face) (setq face (intern fprops)))
1265 (setq extra-props
1266 (cons :inherit
1267 (cons face
1268 extra-props)))
1269 (setq fprops (cdr fprops)))
1270 (let (p v)
1271 ;; Sigh.
1272 (if (listp (car fprops))
1273 (if (nlistp (cdr (car fprops)))
1274 (progn
1275 ;; ((prop . val))
1276 (setq p (caar fprops))
1277 (setq v (cdar fprops))
1278 (setq fprops (cdr fprops)))
1279 ;; ((prop val))
1280 (setq p (caar fprops))
1281 (setq v (cadar fprops))
1282 (setq fprops (cdr fprops)))
1283 (if (listp (cdr fprops))
1284 (progn
1285 ;; (:prop val :prop val ...)
1286 (setq p (car fprops))
1287 (setq v (cadr fprops))
1288 (setq fprops (cddr fprops)))
1289 (if (and (listp fprops)
1290 (not (listp (cdr fprops))))
1291 ;;(and (consp x) (cdr (last x)))
1292 (progn
1293 ;; (prop . val)
1294 (setq p (car fprops))
1295 (setq v (cdr fprops))
1296 (setq fprops nil))
1297 (error "Eh... another format! fprops=%s" fprops) )))
1298 (setq p (case p
1299 ;; These are all the properties handled
1300 ;; in `hfy-face-to-style-i'.
1302 ;; Are these translations right?
1303 ;; yes, they are -- v
1304 (family :family )
1305 (width :width )
1306 (height :height )
1307 (weight :weight )
1308 (slant :slant )
1309 (underline :underline )
1310 (overline :overline )
1311 (strike-through :strike-through)
1312 (box :box )
1313 (foreground-color :foreground)
1314 (background-color :background)
1315 (bold :bold )
1316 (italic :italic )
1317 (t p)))
1318 (if (memq p prop-seen) nil ;; noop
1319 (setq prop-seen (cons p prop-seen)
1320 extra-props (cons p (cons v extra-props))))))))))
1321 ;;(message "+ %d: %s; %S" p face-name extra-props)
1322 (if extra-props
1323 (nconc extra-props (if (listp face-name)
1324 face-name
1325 (face-attr-construct face-name)))
1326 face-name)) ))
1328 (defun hfy-overlay-props-at (p)
1329 "Grab overlay properties at point P.
1330 The plists are returned in descending priority order."
1331 (mapcar #'overlay-properties (overlays-at p 'sorted)))
1333 ;; construct an assoc of (face-name . (css-name . "{ css-style }")) elements:
1334 (defun hfy-compile-stylesheet ()
1335 "Trawl the current buffer, construct and return a `hfy-sheet-assoc'.
1336 If `hfy-user-sheet-assoc' is currently bound then use it to
1337 collect new styles discovered during this run. Otherwise create
1338 a new assoc."
1339 ;;(message "hfy-compile-stylesheet");;DBUG
1340 (let ((pt (point-min))
1341 ;; Make the font stack stay:
1342 ;;(hfy-tmpfont-stack nil)
1343 (fn nil)
1344 (style (and (boundp 'hfy-user-sheet-assoc) hfy-user-sheet-assoc)))
1345 (save-excursion
1346 (goto-char pt)
1347 (while (< pt (point-max))
1348 (if (and (setq fn (hfy-face-at pt)) (not (assoc fn style)))
1349 (push (cons fn (funcall hfy-face-to-css fn)) style))
1350 (setq pt (next-char-property-change pt))))
1351 (unless (assoc 'default style)
1352 (push (cons 'default (funcall hfy-face-to-css 'default)) style))
1353 (when (boundp 'hfy-user-sheet-assoc)
1354 (setq hfy-user-sheet-assoc style))
1355 style))
1357 (defun hfy-fontified-p ()
1358 "`font-lock' doesn't like to say it's been fontified when in batch
1359 mode, but we want to know if we should fontify or raw copy, so in batch
1360 mode we check for non-default face properties. Otherwise we test
1361 variable `font-lock-mode' and variable `font-lock-fontified' for truth."
1362 ;;(message "font-lock-fontified: %S" font-lock-fontified)
1363 ;;(message "noninteractive : %S" noninteractive)
1364 ;;(message "font-lock-mode : %S" font-lock-mode)
1365 (and font-lock-fontified
1366 (if noninteractive
1367 (let ((pt (point-min))
1368 (face-name nil))
1369 (save-excursion
1370 (goto-char pt)
1371 (while (and (< pt (point-max)) (not face-name))
1372 (setq face-name (hfy-face-at pt))
1373 (setq pt (next-char-property-change pt))))
1374 face-name)
1375 font-lock-mode)))
1377 ;; remember, the map is in reverse point order:
1378 ;; I wrote this while suffering the effects of a cold, and maybe a
1379 ;; mild fever - I think it's correct, but it might be a little warped
1380 ;; as my minfd keeps ... where was I? Oh yes, the bunnies...
1381 (defun hfy-merge-adjacent-spans (face-map)
1382 "Where FACE-MAP is a `hfy-facemap-assoc' for the current buffer,
1383 this function merges adjacent style blocks which are of the same value
1384 and are separated by nothing more interesting than whitespace.\n
1385 <span class=\"foo\">narf</span> <span class=\"foo\">brain</span>\n
1386 \(as interpreted from FACE-MAP) would become:\n
1387 <span class=\"foo\">narf brain</span>\n
1388 Returns a modified copy of FACE-MAP."
1389 (let ((tmp-map face-map)
1390 (map-buf nil)
1391 (first-start nil)
1392 (first-stop nil)
1393 (last-start nil)
1394 (last-stop nil)
1395 (span-stop nil)
1396 (span-start nil)
1397 (reduced-map nil))
1398 ;;(push (car tmp-map) reduced-map)
1399 ;;(push (cadr tmp-map) reduced-map)
1400 (while tmp-map
1401 (setq first-start (cadddr tmp-map)
1402 first-stop (caddr tmp-map)
1403 last-start (cadr tmp-map)
1404 last-stop (car tmp-map)
1405 map-buf tmp-map
1406 span-start last-start
1407 span-stop last-stop )
1408 (while (and (equal (cdr first-start)
1409 (cdr last-start))
1410 (save-excursion
1411 (goto-char (car first-stop))
1412 (not (re-search-forward "[^ \t\n\r]" (car last-start) t))))
1413 (setq map-buf (cddr map-buf)
1414 span-start first-start
1415 first-start (cadddr map-buf)
1416 first-stop (caddr map-buf)
1417 last-start (cadr map-buf)
1418 last-stop (car map-buf)))
1419 (push span-stop reduced-map)
1420 (push span-start reduced-map)
1421 (setq tmp-map (memq last-start tmp-map))
1422 (setq tmp-map (cdr tmp-map)))
1423 (setq reduced-map (nreverse reduced-map))))
1425 ;; remember to generate 'synthetic' </span> entries -
1426 ;; emacs copes by just having a stack of styles in effect
1427 ;; and only using the top one: html has a more simplistic approach -
1428 ;; we have to explicitly end a style, there's no way of temporarily
1429 ;; overriding it w. another one... (afaik)
1430 (defun hfy-compile-face-map ()
1431 ;; no need for special <a> version.
1432 ;; IME hyperlinks don't get underlined, esp when you htmlfontify a whole
1433 ;; source tree, so the <a> version is needed -- v
1434 ;; Fix-me: save table for multi-buffer
1435 "Compile and return a `hfy-facemap-assoc' for the current buffer."
1436 ;;(message "hfy-compile-face-map");;DBUG
1437 (let* ((pt (point-min))
1438 (pt-narrow (save-restriction (widen) (point-min)))
1439 (offset (- pt pt-narrow))
1440 (fn nil)
1441 (map nil)
1442 (prev-tag nil)) ;; t if the last tag-point was a span-start
1443 ;; nil if it was a span-stop
1444 (save-excursion
1445 (goto-char pt)
1446 (while (< pt (point-max))
1447 (if (setq fn (hfy-face-at pt))
1448 (progn (if prev-tag (push (cons pt-narrow 'end) map))
1449 (push (cons pt-narrow fn) map)
1450 (setq prev-tag t))
1451 (if prev-tag (push (cons pt-narrow 'end) map))
1452 (setq prev-tag nil))
1453 (setq pt (next-char-property-change pt))
1454 (setq pt-narrow (+ offset pt)))
1455 (if (and map (not (eq 'end (cdar map))))
1456 (push (cons (1+ (- (point-max) (point-min))) 'end) map)))
1457 (if (hfy-opt 'merge-adjacent-tags) (hfy-merge-adjacent-spans map) map)))
1459 (defun hfy-buffer ()
1460 "Generate a buffer to hold the HTML output.
1461 The filename of this buffer is derived from the source (current) buffer's
1462 variable `buffer-file-name', if it is set, plus `hfy-extn'.
1463 Otherwise a plausible filename is constructed from `default-directory',
1464 `buffer-name' and `hfy-extn'."
1465 (let* ((name (concat (buffer-name) hfy-extn))
1466 (src (buffer-file-name))
1467 (buf (get-buffer-create name)))
1468 (with-current-buffer buf
1469 (setq buffer-file-name
1470 (if src (concat src hfy-extn)
1471 (expand-file-name (if (string-match "^.*/\\([^/]*\\)\\'" name)
1472 (match-string 1 name)
1473 name))))
1474 buf)))
1476 (defun hfy-lookup (face style)
1477 "Get a CSS style name for FACE from STYLE."
1478 (cadr (assoc face style)))
1480 (defun hfy-link-style (style-string)
1481 "Copy, alter and return a STYLE-STRING to make it suitable for a hyperlink.
1482 Uses `hfy-link-style-fun' to do this."
1483 (if (functionp hfy-link-style-fun)
1484 (funcall hfy-link-style-fun style-string)
1485 style-string))
1487 (defun hfy-sprintf-stylesheet (css file)
1488 "Return the inline CSS style sheet for FILE as a string."
1489 (let ((stylesheet
1490 (concat
1491 hfy-meta-tags
1492 "\n<style type=\"text/css\"><!-- \n"
1493 ;; Fix-me: Add handling of page breaks here + scan for ^L
1494 ;; where appropriate.
1495 (format "body %s\n" (cddr (assq 'default css)))
1496 (apply 'concat
1497 (mapcar
1498 (lambda (style)
1499 (format
1500 "span.%s %s\nspan.%s a %s\n"
1501 (cadr style) (cddr style)
1502 (cadr style) (hfy-link-style (cddr style))))
1503 css))
1504 " --></style>\n")))
1505 (funcall hfy-page-header file stylesheet)))
1507 ;; tag all the dangerous characters we want to escape
1508 ;; (ie any "<> chars we _didn't_ put there explicitly for css markup)
1509 (defun hfy-html-enkludge-buffer ()
1510 "Mark dangerous [\"<>] characters with the `hfy-quoteme' property.\n
1511 See also `hfy-html-dekludge-buffer'."
1512 ;;(message "hfy-html-enkludge-buffer");;DBUG
1513 (save-excursion
1514 (goto-char (point-min))
1515 (while (re-search-forward hfy-html-quote-regex nil t)
1516 (put-text-property (match-beginning 0) (point) 'hfy-quoteme t))) )
1518 ;; dangerous char -> &entity;
1519 (defun hfy-html-quote (char-string)
1520 "Map CHAR-STRING to an HTML safe string (entity) if need be."
1521 ;;(message "hfy-html-quote");;DBUG
1522 (or (cadr (assoc char-string hfy-html-quote-map)) char-string) )
1524 ;; actually entity-ise dangerous chars.
1525 ;; note that we can't do this until _after_ we have inserted the css
1526 ;; markup, since we use a position-based map to insert this, and if we
1527 ;; enter any other text before we do this, we'd have to track another
1528 ;; map of offsets, which would be tedious...
1529 (defun hfy-html-dekludge-buffer ()
1530 "Transform all dangerous characters marked with the `hfy-quoteme' property
1531 using `hfy-html-quote'.\n
1532 See also `hfy-html-enkludge-buffer'."
1533 ;;(message "hfy-html-dekludge-buffer");;DBUG
1534 (save-excursion
1535 (goto-char (point-min))
1536 (while (re-search-forward hfy-html-quote-regex nil t)
1537 (if (get-text-property (match-beginning 0) 'hfy-quoteme)
1538 (replace-match (hfy-html-quote (match-string 1))) )) ))
1540 ;; Borrowed from font-lock.el
1541 (defmacro hfy-save-buffer-state (varlist &rest body)
1542 "Bind variables according to VARLIST and eval BODY restoring buffer state.
1543 Do not record undo information during evaluation of BODY."
1544 (declare (indent 1) (debug let))
1545 (let ((modified (make-symbol "modified")))
1546 `(let* ,(append varlist
1547 `((,modified (buffer-modified-p))
1548 (buffer-undo-list t)
1549 (inhibit-read-only t)
1550 (inhibit-point-motion-hooks t)
1551 (inhibit-modification-hooks t)
1552 deactivate-mark
1553 buffer-file-name
1554 buffer-file-truename))
1555 (progn
1556 ,@body)
1557 (unless ,modified
1558 (restore-buffer-modified-p nil)))))
1560 (defun hfy-mark-trailing-whitespace ()
1561 "Tag trailing whitespace with a hfy property if it is currently highlighted."
1562 (when show-trailing-whitespace
1563 (let ((inhibit-read-only t))
1564 (save-excursion
1565 (goto-char (point-min))
1566 (hfy-save-buffer-state nil
1567 (while (re-search-forward "[ \t]+$" nil t)
1568 (put-text-property (match-beginning 0) (match-end 0)
1569 'hfy-show-trailing-whitespace t)))))))
1571 (defun hfy-unmark-trailing-whitespace ()
1572 "Undo the effect of `hfy-mark-trailing-whitespace'."
1573 (when show-trailing-whitespace
1574 (hfy-save-buffer-state nil
1575 (remove-text-properties (point-min) (point-max)
1576 '(hfy-show-trailing-whitespace)))))
1578 (defun hfy-begin-span (style text-block text-id text-begins-block-p)
1579 "Default handler to begin a span of text.
1580 Insert \"<span class=\"STYLE\" ...>\". See
1581 `hfy-begin-span-handler' for more information."
1582 (when text-begins-block-p
1583 (insert
1584 (format "<span onclick=\"toggle_invis('%s');\">…</span>" text-block)))
1586 (insert
1587 (if text-block
1588 (format "<span class=\"%s\" id=\"%s-%d\">" style text-block text-id)
1589 (format "<span class=\"%s\">" style))))
1591 (defun hfy-end-span ()
1592 "Default handler to end a span of text.
1593 Insert \"</span>\". See `hfy-end-span-handler' for more
1594 information."
1595 (insert "</span>"))
1597 (defvar hfy-begin-span-handler 'hfy-begin-span
1598 "Handler to begin a span of text.
1599 The signature of the handler is \(lambda (STYLE TEXT-BLOCK
1600 TEXT-ID TEXT-BEGINS-BLOCK-P) ...\). The handler must insert
1601 appropriate tags to begin a span of text.
1603 STYLE is the name of the style that begins at point. It is
1604 derived from the face attributes as part of `hfy-face-to-css'
1605 callback. The other arguments TEXT-BLOCK, TEXT-ID,
1606 TEXT-BEGINS-BLOCK-P are non-nil only if the buffer contains
1607 invisible text.
1609 TEXT-BLOCK is a string that identifies a single chunk of visible
1610 or invisible text of which the current position is a part. For
1611 visible portions, it's value is \"nil\". For invisible portions,
1612 it's value is computed as part of `hfy-invisible-name'.
1614 TEXT-ID marks a unique position within a block. It is set to
1615 value of `point' at the current buffer position.
1617 TEXT-BEGINS-BLOCK-P is a boolean and is non-nil if the current
1618 span also begins a invisible portion of text.
1620 An implementation can use TEXT-BLOCK, TEXT-ID,
1621 TEXT-BEGINS-BLOCK-P to implement fold/unfold-on-mouse-click like
1622 behavior.
1624 The default handler is `hfy-begin-span'.")
1626 (defvar hfy-end-span-handler 'hfy-end-span
1627 "Handler to end a span of text.
1628 The signature of the handler is \(lambda () ...\). The handler
1629 must insert appropriate tags to end a span of text.
1631 The default handler is `hfy-end-span'.")
1633 (defun hfy-fontify-buffer (&optional srcdir file)
1634 "Implement the guts of `htmlfontify-buffer'.
1635 SRCDIR, if set, is the directory being htmlfontified.
1636 FILE, if set, is the file name."
1637 (if srcdir (setq srcdir (directory-file-name srcdir)))
1638 (let* ( (html-buffer (hfy-buffer))
1639 (css-sheet nil)
1640 (css-map nil)
1641 (invis-ranges nil)
1642 (rovl nil)
1643 (rmin (when mark-active (region-beginning)))
1644 (rmax (when mark-active (region-end ))) )
1645 (when (and mark-active
1646 transient-mark-mode)
1647 (unless (and (= rmin (point-min))
1648 (= rmax (point-max)))
1649 (setq rovl (make-overlay rmin rmax))
1650 (overlay-put rovl 'priority 1000)
1651 (overlay-put rovl 'face 'region)))
1652 ;; copy the buffer, including fontification, and switch to it:
1653 (hfy-mark-trailing-whitespace)
1654 (setq css-sheet (hfy-compile-stylesheet )
1655 css-map (hfy-compile-face-map )
1656 invis-ranges (hfy-find-invisible-ranges))
1657 (hfy-unmark-trailing-whitespace)
1658 (when rovl
1659 (delete-overlay rovl))
1660 (copy-to-buffer html-buffer (point-min) (point-max))
1661 (set-buffer html-buffer)
1662 ;; rip out props that could interfere with our htmlization of the buffer:
1663 (remove-text-properties (point-min) (point-max) hfy-ignored-properties)
1664 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1665 ;; at this point, html-buffer retains the fontification of the parent:
1666 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1667 ;; we don't really need or want text in the html buffer to be invisible, as
1668 ;; that can make it look like we've rendered invalid xhtml when all that's
1669 ;; happened is some tags are in the invisible portions of the buffer:
1670 (setq buffer-invisibility-spec nil)
1671 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1672 ;; #####################################################################
1673 ;; if we are in etags mode, add properties to mark the anchors and links
1674 (if (and srcdir file)
1675 (progn
1676 (hfy-mark-tag-names srcdir file) ;; mark anchors
1677 (hfy-mark-tag-hrefs srcdir file))) ;; mark links
1678 ;; #####################################################################
1679 ;; mark the 'dangerous' characters
1680 ;;(message "marking dangerous characters")
1681 (hfy-html-enkludge-buffer)
1682 ;; trawl the position-based face-map, inserting span tags as we go
1683 ;; note that we cannot change any character positions before this point
1684 ;; or we will invalidate the map:
1685 ;; NB: This also means we have to trawl the map in descending file-offset
1686 ;; order, obviously.
1687 ;; ---------------------------------------------------------------------
1688 ;; Remember, inserting pushes properties to the right, which we don't
1689 ;; actually want to happen for link properties, so we have to flag
1690 ;; them and move them by hand - if you don't, you end up with
1692 ;; <span class="foo"><a href="bar">texta</span><span class="bletch"></a>...
1694 ;; instead of:
1696 ;; <span class="foo"><a href="bar">texta</a></span><span class="bletch">...
1698 ;; If my analysis of the problem is correct, we can detect link-ness by
1699 ;; either hfy-linkp or hfy-endl properties at the insertion point, but I
1700 ;; think we only need to relocate the hfy-endl property, as the hfy-linkp
1701 ;; property has already served its main purpose by this point.
1702 ;;(message "mapcar over the CSS-MAP")
1703 ;; (message "invis-ranges:\n%S" invis-ranges)
1704 (dolist (point-face css-map)
1705 (let ((pt (car point-face))
1706 (fn (cdr point-face))
1707 (move-link nil))
1708 (goto-char pt)
1709 (setq move-link
1710 (or (get-text-property pt 'hfy-linkp)
1711 (get-text-property pt 'hfy-endl )))
1712 (if (eq 'end fn)
1713 (funcall hfy-end-span-handler)
1714 (if (not (and srcdir file))
1716 (when move-link
1717 (remove-text-properties (point) (1+ (point)) '(hfy-endl nil))
1718 (put-text-property pt (1+ pt) 'hfy-endl t) ))
1719 ;; if we have invisible blocks, we need to do some extra magic:
1720 (funcall hfy-begin-span-handler
1721 (hfy-lookup fn css-sheet)
1722 (and invis-ranges
1723 (format "%s" (hfy-invisible-name pt invis-ranges)))
1724 (and invis-ranges pt)
1725 (and invis-ranges (assq pt invis-ranges)))
1726 (if (not move-link) nil
1727 ;;(message "removing prop2 @ %d" (point))
1728 (if (remove-text-properties (point) (1+ (point)) '(hfy-endl nil))
1729 (put-text-property pt (1+ pt) 'hfy-endl t))))))
1730 ;; #####################################################################
1731 ;; Invisibility
1732 ;; Maybe just make the text invisible in XHTML?
1733 ;; DONE -- big block of obsolete invisibility code elided here -- v
1734 ;; #####################################################################
1735 ;; (message "checking to see whether we should link...")
1736 (if (and srcdir file)
1737 (let ((lp 'hfy-link)
1738 (pt (point-min))
1739 (pr nil)
1740 (rr nil))
1741 ;; (message " yes we should.")
1742 ;; translate 'hfy-anchor properties to anchors
1743 (while (setq pt (next-single-property-change pt 'hfy-anchor))
1744 (if (setq pr (get-text-property pt 'hfy-anchor))
1745 (progn (goto-char pt)
1746 (remove-text-properties pt (1+ pt) '(hfy-anchor nil))
1747 (insert (concat "<a name=\"" pr "\"></a>")))))
1748 ;; translate alternate 'hfy-link and 'hfy-endl props to opening
1749 ;; and closing links. (this should avoid those spurious closes
1750 ;; we sometimes get by generating only paired tags)
1751 (setq pt (point-min))
1752 (while (setq pt (next-single-property-change pt lp))
1753 (if (not (setq pr (get-text-property pt lp))) nil
1754 (goto-char pt)
1755 (remove-text-properties pt (1+ pt) (list lp nil))
1756 (case lp
1757 (hfy-link
1758 (if (setq rr (get-text-property pt 'hfy-inst))
1759 (insert (format "<a name=\"%s\"></a>" rr)))
1760 (insert (format "<a href=\"%s\">" pr))
1761 (setq lp 'hfy-endl))
1762 (hfy-endl
1763 (insert "</a>") (setq lp 'hfy-link)) ))) ))
1765 ;; #####################################################################
1766 ;; transform the dangerous chars. This changes character positions
1767 ;; since entities have > char length.
1768 ;; note that this deletes the dangerous characters, and therefore
1769 ;; destroys any properties they may contain (such as 'hfy-endl),
1770 ;; so we have to do this after we use said properties:
1771 ;; (message "munging dangerous characters")
1772 (hfy-html-dekludge-buffer)
1773 (unless (hfy-opt 'body-text-only)
1774 ;; insert the stylesheet at the top:
1775 (goto-char (point-min))
1777 ;;(message "inserting stylesheet")
1778 (insert (hfy-sprintf-stylesheet css-sheet file))
1780 (if (hfy-opt 'div-wrapper) (insert "<div class=\"default\">"))
1781 (insert "\n<pre>")
1782 (goto-char (point-max))
1783 (insert "</pre>\n")
1784 (if (hfy-opt 'div-wrapper) (insert "</div>"))
1785 ;;(message "inserting footer")
1786 (insert (funcall hfy-page-footer file)))
1787 ;; call any post html-generation hooks:
1788 (run-hooks 'hfy-post-html-hook)
1789 ;; return the html buffer
1790 (set-buffer-modified-p nil)
1791 html-buffer))
1793 (defun htmlfontify-string (string)
1794 "Take a STRING and return a fontified version of it.
1795 It is assumed that STRING has text properties that allow it to be
1796 fontified. This is a simple convenience wrapper around
1797 `htmlfontify-buffer'."
1798 (let* ((hfy-optimisations-1 (copy-sequence hfy-optimisations))
1799 (hfy-optimisations (add-to-list 'hfy-optimisations-1
1800 'skip-refontification)))
1801 (with-temp-buffer
1802 (insert string)
1803 (htmlfontify-buffer)
1804 (buffer-string))))
1806 (defun hfy-force-fontification ()
1807 "Try to force font-locking even when it is optimized away."
1808 (run-hooks 'hfy-init-kludge-hook)
1809 (eval-and-compile (require 'font-lock))
1810 (if (boundp 'font-lock-cache-position)
1811 (or font-lock-cache-position
1812 (setq font-lock-cache-position (make-marker))))
1813 (cond
1814 (noninteractive
1815 (message "hfy batch mode (%s:%S)"
1816 (or (buffer-file-name) (buffer-name)) major-mode)
1817 (if (fboundp 'font-lock-ensure)
1818 (font-lock-ensure)
1819 (when font-lock-defaults
1820 (font-lock-fontify-buffer))))
1821 ((fboundp #'jit-lock-fontify-now)
1822 (message "hfy jit-lock mode (%S %S)" window-system major-mode)
1823 (jit-lock-fontify-now))
1825 (message "hfy interactive mode (%S %S)" window-system major-mode)
1826 ;; If jit-lock is not in use, then the buffer is already fontified!
1827 ;; (when (and font-lock-defaults
1828 ;; font-lock-mode)
1829 ;; (font-lock-fontify-region (point-min) (point-max) nil))
1832 ;;;###autoload
1833 (defun htmlfontify-buffer (&optional srcdir file)
1834 "Create a new buffer, named for the current buffer + a .html extension,
1835 containing an inline CSS-stylesheet and formatted CSS-markup HTML
1836 that reproduces the look of the current Emacs buffer as closely
1837 as possible.
1839 Dangerous characters in the existing buffer are turned into HTML
1840 entities, so you should even be able to do HTML-within-HTML
1841 fontified display.
1843 You should, however, note that random control or eight-bit
1844 characters such as ^L (\x0c) or ¤ (\xa4) won't get mapped yet.
1846 If the SRCDIR and FILE arguments are set, lookup etags derived
1847 entries in the `hfy-tags-cache' and add HTML anchors and
1848 hyperlinks as appropriate."
1849 (interactive)
1850 ;; pick up the file name in case we didn't receive it
1851 (if (not file)
1852 (progn (setq file (or (buffer-file-name) (buffer-name)))
1853 (if (string-match "/\\([^/]*\\)\\'" file)
1854 (setq file (match-string 1 file)))) )
1856 (if (not (hfy-opt 'skip-refontification))
1857 (save-excursion ;; Keep region
1858 (hfy-force-fontification)))
1859 (if (called-interactively-p 'any) ;; display the buffer in interactive mode:
1860 (switch-to-buffer (hfy-fontify-buffer srcdir file))
1861 (hfy-fontify-buffer srcdir file)))
1863 ;; recursive file listing
1864 (defun hfy-list-files (directory)
1865 "Return a list of files under DIRECTORY.
1866 Strips any leading \"./\" from each filename."
1867 ;;(message "hfy-list-files");;DBUG
1868 ;; FIXME: this changes the dir of the current buffer. Is that right??
1869 (cd directory)
1870 (mapcar (lambda (F) (if (string-match "^./\\(.*\\)" F) (match-string 1 F) F))
1871 (split-string (shell-command-to-string hfy-find-cmd))) )
1873 ;; strip the filename off, return a directory name
1874 ;; not a particularly thorough implementation, but it will be
1875 ;; fed pretty carefully, so it should be Ok:
1876 (defun hfy-dirname (file)
1877 "Return everything preceding the last \"/\" from a relative filename FILE,
1878 on the assumption that this will produce a relative directory name.
1879 Hardly bombproof, but good enough in the context in which it is being used."
1880 ;;(message "hfy-dirname");;DBUG
1881 (let ((f (directory-file-name file)))
1882 (and (string-match "^\\(.*\\)/" f) (match-string 1 f))))
1884 ;; create a directory, cf mkdir -p
1885 (defun hfy-make-directory (dir)
1886 "Approx. equivalent of mkdir -p DIR."
1887 ;;(message "hfy-make-directory");;DBUG
1888 (if (file-exists-p dir)
1889 (if (file-directory-p dir) t)
1890 (make-directory dir t)))
1892 (defun hfy-text-p (srcdir file)
1893 "Is SRCDIR/FILE text? Uses `hfy-istext-command' to determine this."
1894 (let* ((cmd (format hfy-istext-command (expand-file-name file srcdir)))
1895 (rsp (shell-command-to-string cmd)))
1896 (string-match "text" rsp)))
1898 ;; open a file, check fontification, if fontified, write a fontified copy
1899 ;; to the destination directory, otherwise just copy the file:
1900 (defun hfy-copy-and-fontify-file (srcdir dstdir file)
1901 "Open FILE in SRCDIR - if fontified, write a fontified copy to DSTDIR
1902 adding an extension of `hfy-extn'. Fontification is actually done by
1903 `htmlfontify-buffer'. If the buffer is not fontified, just copy it."
1904 ;;(message "hfy-copy-and-fontify-file");;DBUG
1905 (let (;;(fast-lock-minimum-size hfy-fast-lock-save)
1906 ;;(font-lock-support-mode 'fast-lock-mode)
1907 ;;(window-system (or window-system 'htmlfontify))
1908 (target nil)
1909 (source nil)
1910 (html nil))
1911 (cd srcdir)
1912 (with-current-buffer (setq source (find-file-noselect file))
1913 ;; FIXME: Shouldn't this use expand-file-name? --Stef
1914 (setq target (concat dstdir "/" file))
1915 (hfy-make-directory (hfy-dirname target))
1916 (if (not (hfy-opt 'skip-refontification)) (hfy-force-fontification))
1917 (if (or (hfy-fontified-p) (hfy-text-p srcdir file))
1918 (progn (setq html (hfy-fontify-buffer srcdir file))
1919 (set-buffer html)
1920 (write-file (concat target hfy-extn))
1921 (kill-buffer html))
1922 ;; #o0200 == 128, but emacs20 doesn't know that
1923 (if (and (file-exists-p target) (not (file-writable-p target)))
1924 (set-file-modes target (logior (file-modes target) 128)))
1925 (copy-file (buffer-file-name source) target 'overwrite))
1926 (kill-buffer source)) ))
1928 ;; list of tags in file in srcdir
1929 (defun hfy-tags-for-file (cache-hash file)
1930 "List of etags tags that have definitions in this FILE.
1931 CACHE-HASH is the tags cache."
1932 ;;(message "hfy-tags-for-file");;DBUG
1933 (let* ((tag-list nil))
1934 (if cache-hash
1935 (maphash
1936 (lambda (K V)
1937 (if (assoc file V)
1938 (setq tag-list (cons K tag-list))))
1939 cache-hash))
1940 tag-list))
1942 ;; mark the tags native to this file for anchors
1943 (defun hfy-mark-tag-names (srcdir file)
1944 "Mark tags in FILE (lookup SRCDIR in `hfy-tags-cache') with the `hfy-anchor'
1945 property, with a value of \"tag.line-number\"."
1946 ;;(message "(hfy-mark-tag-names %s %s)" srcdir file);;DBUG
1947 (let* ((cache-entry (assoc srcdir hfy-tags-cache))
1948 (cache-hash (cadr cache-entry)))
1949 (if cache-hash
1950 (mapcar
1951 (lambda (TAG)
1952 (mapcar
1953 (lambda (TLIST)
1954 (if (string= file (car TLIST))
1955 (let* ((line (cadr TLIST) )
1956 (chr (caddr TLIST) )
1957 (link (format "%s.%d" TAG line) ))
1958 (put-text-property (+ 1 chr)
1959 (+ 2 chr)
1960 'hfy-anchor link))))
1961 (gethash TAG cache-hash)))
1962 (hfy-tags-for-file cache-hash file)))))
1964 (defun hfy-relstub (file &optional start)
1965 "Return a \"../\" stub of the appropriate length for the current source
1966 tree depth, as determined from FILE (a filename).
1967 START is the offset at which to start looking for the / character in FILE."
1968 ;;(message "hfy-relstub");;DBUG
1969 (let ((c ""))
1970 (while (setq start (string-match "/" file start))
1971 (setq start (1+ start)) (setq c (concat c "../")))
1974 (defun hfy-href-stub (this-file def-files tag)
1975 "Return an href stub for a tag href in THIS-FILE.
1976 If DEF-FILES (list of files containing definitions for the tag in question)
1977 contains only one entry, the href should link straight to that file.
1978 Otherwise, the link should be to the index file.\n
1979 We are not yet concerned with the file extensions/tag line number and so on at
1980 this point.\n
1981 If `hfy-split-index' is set, and the href wil be to an index file rather than
1982 a source file, append a .X to `hfy-index-file', where X is the uppercased
1983 first character of TAG.\n
1984 See also `hfy-relstub', `hfy-index-file'."
1985 ;;(message "hfy-href-stub");;DBUG
1986 ;; FIXME: Why not use something like
1987 ;; (file-relative-name (if ...) (file-name-directory this-file)) ? --Stef
1988 (concat
1989 (hfy-relstub this-file)
1990 (if (= 1 (length def-files)) (car def-files)
1991 (if (not hfy-split-index) hfy-index-file
1992 (concat hfy-index-file "." (upcase (substring tag 0 1)))))) )
1994 (defun hfy-href (this-file def-files tag tag-map)
1995 "Return a relative href to the tag in question, based on\n
1996 THIS-FILE `hfy-link-extn' `hfy-extn' DEF-FILES TAG and TAG-MAP\n
1997 THIS-FILE is the current source file
1998 DEF-FILES is a list of file containing possible link endpoints for TAG
1999 TAG is the tag in question
2000 TAG-MAP is the entry in `hfy-tags-cache'."
2001 ;;(message "hfy-href");;DBUG
2002 (concat
2003 (hfy-href-stub this-file def-files tag)
2004 (or hfy-link-extn hfy-extn) "#" tag ;;(.src -> .html)
2005 (if (= 1 (length def-files))
2006 (concat "." (format "%d" (cadr (assoc (car def-files) tag-map)))))) )
2008 (defun hfy-word-regex (string)
2009 "Return a regex that matches STRING as the first `match-string', with non
2010 word characters on either side."
2011 ;; FIXME: Should this use [^$[:alnum:]_] instead? --Stef
2012 (concat "[^$A-Za-z_0-9]\\(" (regexp-quote string) "\\)[^A-Za-z_0-9]"))
2014 ;; mark all tags for hyperlinking, except the tags at
2015 ;; their own points of definition, iyswim:
2016 (defun hfy-mark-tag-hrefs (srcdir file)
2017 "Mark href start points with the `hfy-link' prop (value: href string).\n
2018 Mark href end points with the `hfy-endl' prop (value t).\n
2019 Avoid overlapping links, and mark links in descending length of
2020 tag name in order to prevent subtags from usurping supertags,
2021 \(eg \"term\" for \"terminal\").
2022 SRCDIR is the directory being \"published\".
2023 FILE is the specific file we are rendering."
2024 ;;(message "hfy-mark-tag-hrefs");;DBUG
2025 (let ((cache-entry (assoc srcdir hfy-tags-cache))
2026 (list-cache (assoc srcdir hfy-tags-sortl))
2027 (rmap-cache (assoc srcdir hfy-tags-rmap ))
2028 (no-comment (hfy-opt 'zap-comment-links))
2029 (no-strings (hfy-opt 'zap-string-links ))
2030 (cache-hash nil)
2031 (tags-list nil)
2032 (tags-rmap nil)
2033 (case-fold-search nil))
2034 ;; extract the tag mapping hashes (fwd and rev) and the tag list:
2035 (if (and (setq cache-hash (cadr cache-entry))
2036 (setq tags-rmap (cadr rmap-cache ))
2037 (setq tags-list (cadr list-cache )))
2038 (mapcar
2039 (lambda (TAG)
2040 (let* ((start nil)
2041 (stop nil)
2042 (href nil)
2043 (name nil)
2044 (case-fold-search nil)
2045 (tmp-point nil)
2046 (maybe-start nil)
2047 (face-at nil)
2048 (rmap-entry nil)
2049 (rnew-elt nil)
2050 (rmap-line nil)
2051 (tag-regex (hfy-word-regex TAG))
2052 (tag-map (gethash TAG cache-hash))
2053 (tag-files (mapcar #'car tag-map)))
2054 ;; find instances of TAG and do what needs to be done:
2055 (goto-char (point-min))
2056 (while (search-forward TAG nil 'NOERROR)
2057 (setq tmp-point (point)
2058 maybe-start (- (match-beginning 0) 1))
2059 (goto-char maybe-start)
2060 (if (not (looking-at tag-regex))
2062 (setq start (match-beginning 1))
2063 (setq stop (match-end 1))
2064 (setq face-at
2065 (and (or no-comment no-strings) (hfy-face-at start)))
2066 (if (listp face-at)
2067 (setq face-at (cadr (memq :inherit face-at))))
2068 (if (or (text-property-any start (1+ stop) 'hfy-linkp t)
2069 (and no-comment (eq 'font-lock-comment-face face-at))
2070 (and no-strings (eq 'font-lock-string-face face-at)))
2071 nil ;; already a link, NOOP
2073 ;; set a reverse map entry:
2074 (setq rmap-line (line-number-at-pos)
2075 rmap-entry (gethash TAG tags-rmap)
2076 rnew-elt (list file rmap-line start)
2077 rmap-entry (cons rnew-elt rmap-entry)
2078 name (format "%s.%d" TAG rmap-line))
2079 (put-text-property start (1+ start) 'hfy-inst name)
2080 (puthash TAG rmap-entry tags-rmap)
2082 ;; mark the link. link to index if the tag has > 1 def
2083 ;; add the line number to the #name if it does not:
2084 (setq href (hfy-href file tag-files TAG tag-map))
2085 (put-text-property start (1+ start) 'hfy-link href)
2086 (put-text-property stop (1+ stop ) 'hfy-endl t )
2087 (put-text-property start (1+ stop ) 'hfy-linkp t )))
2088 (goto-char tmp-point)) ))
2089 tags-list) )))
2091 (defun hfy-shell ()
2092 "Return `shell-file-name', or \"/bin/sh\" if it is a non-Bourne shell."
2093 (if (string-match "\\<bash\\>\\|\\<sh\\>\\|\\<dash\\>" shell-file-name)
2094 shell-file-name
2095 (or hfy-shell-file-name "/bin/sh")))
2097 ;; cache the #(tag => file line point) entries for files under srcdir
2098 ;; and cache the descending sorted list of tags in the relevant alist,
2099 ;; also keyed by srcdir:
2100 (defun hfy-load-tags-cache (srcdir)
2101 "Run `hfy-etags-cmd' on SRCDIR, then call `hfy-parse-tags-buffer'."
2102 ;;(message "hfy-load-tags-cache");;DBUG
2103 (let ((etags-buffer (get-buffer-create "*hfy-tags*"))
2104 (etags-command (format hfy-etags-cmd hfy-etags-bin))
2105 (shell-file-name (hfy-shell)))
2106 (cd srcdir)
2107 (shell-command etags-command etags-buffer)
2108 (hfy-parse-tags-buffer srcdir etags-buffer)) )
2110 ;; break this out from `hfy-load-tags-cache' to make the tar file
2111 ;; functionality easier to implement.
2112 ;; ( tar file functionality not merged here because it requires a
2113 ;; hacked copy of etags capable of tagging stdin: if Francesco
2114 ;; Potortì accepts a patch, or otherwise implements stdin tagging,
2115 ;; then I will provide a `htmlfontify-tar-file' defun )
2116 (defun hfy-parse-tags-buffer (srcdir buffer)
2117 "Parse a BUFFER containing etags formatted output, loading the
2118 `hfy-tags-cache' and `hfy-tags-sortl' entries for SRCDIR."
2119 (let ((cache-entry (assoc srcdir hfy-tags-cache))
2120 (tlist-cache (assoc srcdir hfy-tags-sortl))
2121 (trmap-cache (assoc srcdir hfy-tags-rmap ))
2122 (cache-hash nil) (trmap-hash nil) (tags-list nil)
2123 (hash-entry nil) (tag-string nil) (tag-line nil)
2124 (tag-point nil) (new-entry nil) (etags-file nil))
2126 ;; (re)initialize the tag reverse map:
2127 (if trmap-cache (setq trmap-hash (cadr trmap-cache))
2128 (setq trmap-hash (make-hash-table :test 'equal))
2129 (setq hfy-tags-rmap (list (list srcdir trmap-hash) hfy-tags-rmap)))
2130 (clrhash trmap-hash)
2132 ;; (re)initialize the tag cache:
2133 (if cache-entry (setq cache-hash (cadr cache-entry))
2134 (setq cache-hash (make-hash-table :test 'equal))
2135 (setq hfy-tags-cache (list (list srcdir cache-hash) hfy-tags-cache)))
2136 (clrhash cache-hash)
2138 ;; cache the TAG => ((file line point) (file line point) ... ) entries:
2139 (with-current-buffer buffer
2140 (goto-char (point-min))
2142 (while (and (looking-at "^\x0c") (= 0 (forward-line 1)))
2143 ;;(message "^L boundary")
2144 (if (and (looking-at "^\\(.+\\),\\([0-9]+\\)$")
2145 (= 0 (forward-line 1)))
2146 (progn
2147 (setq etags-file (match-string 1))
2148 ;;(message "TAGS for file: %s" etags-file)
2149 (while (and (looking-at hfy-etag-regex) (= 0 (forward-line 1)))
2150 (setq tag-string (match-string 1))
2151 (if (= 0 (length tag-string)) nil ;; noop
2152 (setq tag-line (round (string-to-number (match-string 2))))
2153 (setq tag-point (round (string-to-number (match-string 3))))
2154 (setq hash-entry (gethash tag-string cache-hash))
2155 (setq new-entry (list etags-file tag-line tag-point))
2156 (push new-entry hash-entry)
2157 ;;(message "HASH-ENTRY %s %S" tag-string new-entry)
2158 (puthash tag-string hash-entry cache-hash)))) )))
2160 ;; cache a list of tags in descending length order:
2161 (maphash (lambda (K _V) (push K tags-list)) cache-hash)
2162 (setq tags-list (sort tags-list (lambda (A B) (< (length B) (length A)))))
2164 ;; put the tag list into the cache:
2165 (if tlist-cache (setcar (cdr tlist-cache) tags-list)
2166 (push (list srcdir tags-list) hfy-tags-sortl))
2168 ;; return the number of tags found:
2169 (length tags-list) ))
2171 (defun hfy-prepare-index-i (srcdir dstdir filename &optional stub map)
2172 "Prepare a tags index buffer for SRCDIR.
2173 `hfy-tags-cache' must already have an entry for SRCDIR for this to work.
2174 `hfy-page-header', `hfy-page-footer', `hfy-link-extn' and `hfy-extn'
2175 all play a part here.\n
2176 If STUB is set, prepare an (appropriately named) index buffer
2177 specifically for entries beginning with STUB.\n
2178 If MAP is set, use that instead of `hfy-tags-cache'.
2179 FILENAME is the name of the file being indexed.
2180 DSTDIR is the output directory, where files will be written."
2181 ;;(message "hfy-write-index");;DBUG
2182 (let ((cache-entry (assoc srcdir (or map hfy-tags-cache)))
2183 (cache-hash nil)
2184 (tag-list nil)
2185 (index-file
2186 (concat filename (if stub (concat "." stub) "") hfy-extn))
2187 (index-buf nil))
2188 (if (not (and cache-entry
2189 (setq cache-hash (cadr cache-entry))
2190 (setq index-buf (get-buffer-create index-file))))
2191 nil ;; noop
2192 (maphash (lambda (K _V) (push K tag-list)) cache-hash)
2193 (setq tag-list (sort tag-list 'string<))
2194 (set-buffer index-buf)
2195 (erase-buffer)
2196 (insert (funcall hfy-page-header filename "<!-- CSS -->"))
2197 (insert "<table class=\"index\">\n")
2199 (dolist (TAG tag-list)
2200 (let ((tag-started nil))
2201 (dolist (DEF (gethash TAG cache-hash))
2202 (if (and stub (not (string-match (concat "^" stub) TAG)))
2203 nil ;; we have a stub and it didn't match: NOOP
2204 (let ((file (car DEF))
2205 (line (cadr DEF)))
2206 (insert
2207 (format
2208 (concat
2209 " <tr> \n"
2210 " <td>%s</td> \n"
2211 " <td><a href=\"%s%s\">%s</a></td> \n"
2212 " <td><a href=\"%s%s#%s.%d\">%d</a></td>\n"
2213 " </tr> \n")
2214 (if (string= TAG tag-started) "&nbsp;"
2215 (format "<a name=\"%s\">%s</a>" TAG TAG))
2216 file (or hfy-link-extn hfy-extn) file
2217 file (or hfy-link-extn hfy-extn) TAG line line))
2218 (setq tag-started TAG))))))
2219 (insert "</table>\n")
2220 (insert (funcall hfy-page-footer filename))
2221 (and dstdir (cd dstdir))
2222 (set-visited-file-name index-file)
2223 index-buf) ))
2225 (defun hfy-prepare-index (srcdir dstdir)
2226 "Return a list of index buffer(s), as determined by `hfy-split-index'.
2227 SRCDIR and DSTDIR are the source and output directories respectively."
2228 (if (not hfy-split-index)
2229 (list (hfy-prepare-index-i srcdir dstdir hfy-index-file nil))
2230 (let ((stub-list nil)
2231 (cache-hash nil)
2232 (index-list nil)
2233 (cache-entry (assoc srcdir hfy-tags-cache)))
2234 (if (and cache-entry (setq cache-hash (cadr cache-entry)))
2235 (maphash
2236 (lambda (K _V)
2237 (let ((stub (upcase (substring K 0 1))))
2238 (if (member stub stub-list)
2239 nil ;; seen this already: NOOP
2240 (setq
2241 stub-list (cons stub stub-list)
2242 index-list (cons (hfy-prepare-index-i srcdir
2243 dstdir
2244 hfy-index-file
2245 stub)
2246 index-list)) )))
2247 cache-hash) )
2248 index-list)))
2250 (defun hfy-prepare-tag-map (srcdir dstdir)
2251 "Prepare the counterpart(s) to the index buffer(s) - a list of buffers
2252 with the same structure, but listing (and linking to) instances of tags
2253 \(as opposed to their definitions).\n
2254 SRCDIR and DSTDIR are the source and output directories respectively.
2255 See also `hfy-prepare-index', `hfy-split-index'."
2256 (if (not hfy-split-index)
2257 (list (hfy-prepare-index-i srcdir
2258 dstdir
2259 hfy-instance-file
2261 hfy-tags-rmap))
2262 (let ((stub-list nil)
2263 (cache-hash nil)
2264 (index-list nil)
2265 (cache-entry (assoc srcdir hfy-tags-rmap)))
2267 (if (and cache-entry (setq cache-hash (cadr cache-entry)))
2268 (maphash
2269 (lambda (K _V)
2270 (let ((stub (upcase (substring K 0 1))))
2271 (if (member stub stub-list)
2272 nil ;; seen this already: NOOP
2273 (setq
2274 stub-list (cons stub stub-list)
2275 index-list (cons (hfy-prepare-index-i srcdir
2276 dstdir
2277 hfy-instance-file
2278 stub
2279 hfy-tags-rmap)
2280 index-list)) )))
2281 cache-hash) )
2282 index-list)))
2284 (defun hfy-subtract-maps (srcdir)
2285 "Internal function - strips definitions of tags from the instance map.
2286 SRCDIR is the directory being \"published\".
2287 See also `hfy-tags-cache', `hfy-tags-rmap'."
2288 (let ((new-list nil)
2289 (old-list nil)
2290 (def-list nil)
2291 (exc-list nil)
2292 (fwd-map (cadr (assoc srcdir hfy-tags-cache)))
2293 (rev-map (cadr (assoc srcdir hfy-tags-rmap )))
2294 (taglist (cadr (assoc srcdir hfy-tags-sortl))))
2295 (dolist (TAG taglist)
2296 (setq def-list (gethash TAG fwd-map)
2297 old-list (gethash TAG rev-map)
2298 exc-list (mapcar (lambda (P) (list (car P) (cadr P))) def-list)
2299 new-list nil)
2300 (dolist (P old-list)
2301 (or (member (list (car P) (cadr P)) exc-list)
2302 (push P new-list)))
2303 (puthash TAG new-list rev-map))))
2305 (defun htmlfontify-run-etags (srcdir)
2306 "Load the etags cache for SRCDIR.
2307 See also `hfy-load-tags-cache'."
2308 (interactive "D source directory: ")
2309 (hfy-load-tags-cache (directory-file-name srcdir)))
2311 ;;(defun hfy-test-read-args (foo bar)
2312 ;; (interactive "D source directory: \nD target directory: ")
2313 ;; (message "foo: %S\nbar: %S" foo bar))
2315 (defun hfy-save-kill-buffers (buffer-list &optional dstdir)
2316 (dolist (B buffer-list)
2317 (set-buffer B)
2318 (and dstdir (file-directory-p dstdir) (cd dstdir))
2319 (save-buffer)
2320 (kill-buffer B)))
2322 ;;;###autoload
2323 (defun htmlfontify-copy-and-link-dir (srcdir dstdir &optional f-ext l-ext)
2324 "Trawl SRCDIR and write fontified-and-hyperlinked output in DSTDIR.
2325 F-EXT and L-EXT specify values for `hfy-extn' and `hfy-link-extn'.\n
2326 You may also want to set `hfy-page-header' and `hfy-page-footer'."
2327 (interactive "D source directory: \nD output directory: ")
2328 ;;(message "htmlfontify-copy-and-link-dir")
2329 (setq srcdir (directory-file-name srcdir))
2330 (setq dstdir (directory-file-name dstdir))
2331 (let ((source-files "SETME: list of source files, relative to srcdir")
2332 (tr-cache (assoc srcdir hfy-tags-rmap))
2333 (hfy-extn (or f-ext ".html"))
2334 (hfy-link-extn (or l-ext ".html")))
2335 ;; oops, forgot to load etags for srcdir:
2336 (if tr-cache nil
2337 (message "autoload of tags cache")
2338 (hfy-load-tags-cache srcdir)
2339 (setq tr-cache (assoc srcdir hfy-tags-rmap)))
2340 ;; clear out the old cache:
2341 (clrhash (cadr tr-cache))
2342 (hfy-make-directory dstdir)
2343 (setq source-files (hfy-list-files srcdir))
2344 (dolist (file source-files)
2345 (hfy-copy-and-fontify-file srcdir dstdir file))
2346 (hfy-subtract-maps srcdir)
2347 (hfy-save-kill-buffers (hfy-prepare-index srcdir dstdir) dstdir)
2348 (hfy-save-kill-buffers (hfy-prepare-tag-map srcdir dstdir) dstdir) ))
2350 ;; name of the init file we want:
2351 (defun hfy-initfile ()
2352 "Return the expected location of the htmlfontify specific init/custom file."
2353 (let* ((file (or (getenv "HFY_INITFILE") ".hfy.el")))
2354 (expand-file-name file "~") ))
2357 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2358 ;; incomplete as yet : transfer hook settings to hfy init file:
2359 ;; (defalias 'hfy-set-hooks 'custom-set-variables)
2361 ;; (defun hfy-pp-hook (H)
2362 ;; (and (string-match "-hook\\'" (symbol-name H))
2363 ;; (boundp H)
2364 ;; (symbol-value H)
2365 ;; (insert (format "\n '(%S %S)" H (symbol-value H)))
2366 ;; )
2367 ;; )
2369 ;; (defun hfy-save-hooks ()
2370 ;; (let ((custom-file (hfy-initfile)))
2371 ;; (custom-save-delete 'hfy-set-hooks)
2372 ;; (let ((standard-output (current-buffer)))
2373 ;; (princ "(hfy-set-hooks\n;;auto-generated, only one copy allowed\n")
2374 ;; (mapatoms 'hfy-pp-hook)
2375 ;; (insert "\n)")
2376 ;; )
2377 ;; )
2378 ;; )
2379 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2381 (defalias 'hfy-init-progn 'progn)
2383 (defun hfy-save-initvar (sym)
2384 (princ (format "(setq %s\n '" sym))
2385 (pp (symbol-value sym))
2386 (princ ")\n"))
2388 (defun htmlfontify-save-initfile ()
2389 "Save the htmlfontify settings to the htmlfontify init file."
2390 (interactive)
2391 (let* ((start-pos nil)
2392 (custom-file (hfy-initfile))
2393 (standard-output (find-file-noselect custom-file 'nowarn)))
2394 (save-excursion
2395 (custom-save-delete 'hfy-init-progn)
2396 (setq start-pos (point))
2397 (princ "(hfy-init-progn\n;;auto-generated, only one copy allowed\n")
2398 ;; FIXME: This saving&restoring of global customization
2399 ;; variables can interfere with other customization settings for
2400 ;; those vars (in .emacs or in Customize).
2401 (mapc 'hfy-save-initvar
2402 '(auto-mode-alist interpreter-mode-alist))
2403 (princ ")\n")
2404 (indent-region start-pos (point) nil))
2405 (custom-save-all) ))
2407 (defun htmlfontify-load-initfile ()
2408 "Load the htmlfontify specific init/custom file."
2409 (interactive)
2410 (let ((file (hfy-initfile)))
2411 (load file 'NOERROR nil nil) ))
2414 ;;;### (autoloads nil "hfy-cmap" "hfy-cmap.el" "ce07a28b93c09032fd6b225ad74be0df")
2415 ;;; Generated autoloads from hfy-cmap.el
2417 (autoload 'htmlfontify-load-rgb-file "hfy-cmap" "\
2418 Load an X11 style rgb.txt FILE.
2419 Search `hfy-rgb-load-path' if FILE is not specified.
2420 Loads the variable `hfy-rgb-txt-colour-map', which is used by
2421 `hfy-fallback-colour-values'.
2423 \(fn &optional FILE)" t nil)
2425 (autoload 'hfy-fallback-colour-values "hfy-cmap" "\
2426 Use a fallback method for obtaining the rgb values for a color.
2428 \(fn COLOUR-STRING)" nil nil)
2430 ;;;***
2433 (provide 'htmlfontify)
2435 ;; Local Variables:
2436 ;; coding: utf-8
2437 ;; End:
2439 ;;; htmlfontify.el ends here