]> code.delx.au - gnu-emacs/blob - lisp/htmlfontify.el
Update docs for `customize-mode'
[gnu-emacs] / lisp / htmlfontify.el
1 ;;; htmlfontify.el --- htmlize a buffer/source tree with optional hyperlinks
2
3 ;; Copyright (C) 2002-2003, 2009-2016 Free Software Foundation, Inc.
4
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
18
19 ;; This file is part of GNU Emacs.
20
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.
25
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.
30
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/>.
33
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).
40 ;;
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.
44 ;;
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.
48 ;;
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.)
54 ;;
55 ;; 2007-12-27 Lennart Borgman
56 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
57
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.
62
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.
68
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.
73
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)
79
80 ;;; History:
81 ;; Changes: moved to changelog (CHANGES) file.
82
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)
92
93 (defconst htmlfontify-version 0.21)
94
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.")
99
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
126 %s
127 STYLESHEET
128 main-title := rtfm / %s / src/%s\\n
129 main-content <=MAIN_CONTENT;\\n\" rtfm-section file style rtfm-section file))
130
131 \(defun rtfm-build-page-footer (file) \"\\nMAIN_CONTENT\\n\")
132
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\")))")
144
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-")
152
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))
166
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))
175
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))
182
183 (defcustom hfy-extn ".html"
184 "File extension used for output files."
185 :group 'htmlfontify
186 :tag "extension"
187 :type '(string))
188
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))
194
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))
200
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)))
209
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))
220
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))
227
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))
234
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))
242
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))
252
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))
261
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))
272
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))
286
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`;
296 do
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};
307 ;;
308 *)
309 FTYPE=`file ${src}`;
310 case ${FTYPE} in
311 *script*text*)
312 ${ETAGS} -o- ${src};
313 ;;
314 *text*)
315 SHEBANG=`head -n1 ${src} | grep '#!' -c`;
316 if [ ${SHEBANG} -eq 1 ];
317 then
318 ${ETAGS} -o- ${src};
319 fi;
320 ;;
321 esac;
322 ;;
323 esac;
324 done;")
325
326 (defconst hfy-etags-cmd-alist-default
327 `(("emacs etags" . ,hfy-e2x-etags-cmd)
328 ("exuberant ctags" . "%s -R -f -" )))
329
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)))
337
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))
345
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))
351
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))
363
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" )) ))
369
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)))
389
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))
397
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))
404
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 )))
436
437 (class (choice (const :tag "Color" color )
438 (const :tag "Grayscale" grayscale)))
439
440 (background (choice (const :tag "Dark" dark )
441 (const :tag "Bright" light ))) ))
442
443 (defcustom hfy-optimizations (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")
478 (define-obsolete-variable-alias 'hfy-optimisations 'hfy-optimizations "25.1")
479
480 (defvar hfy-tags-cache nil
481 "Alist of the form:\n
482 \((\"/src/dir/0\" . tag-hash0) (\"/src/dir/1\" tag-hash1) ...)\n
483 Each tag hash entry then contains entries of the form:\n
484 \"tag_string\" => ((\"file/name.ext\" line char) ... )\n
485 ie an alist mapping (relative) file paths to line and character offsets.\n
486 See also `hfy-load-tags-cache'.")
487
488 (defvar hfy-tags-sortl nil
489 "Alist of the form ((\"/src/dir\" . (tag0 tag1 tag2)) ... )\n
490 where the tags are stored in descending order of length.\n
491 See also `hfy-load-tags-cache'.")
492
493 (defvar hfy-tags-rmap nil
494 "Alist of the form ((\"/src/dir\" . tag-rmap-hash))\n
495 where tag-rmap-hash has entries of the form:
496 \"tag_string\" => ( \"file/name.ext\" line char )
497 Unlike `hfy-tags-cache' these are the locations of occurrences of
498 tagged items, not the locations of their definitions.")
499
500 (defvar hfy-style-assoc 'please-ignore-this-line
501 "An assoc representing/describing an Emacs face.
502 Properties may be repeated, in which case later properties should be
503 treated as if they were inherited from a `parent' font.
504 \(For some properties, only the first encountered value is of any importance,
505 for others the values might be cumulative, and for others they might be
506 cumulative in a complex way.)\n
507 Some examples:\n
508 \(hfy-face-to-style \\='default) =>
509 ((\"background\" . \"rgb(0, 0, 0)\")
510 (\"color\" . \"rgb(255, 255, 255)\")
511 (\"font-style\" . \"normal\")
512 (\"font-weight\" . \"500\")
513 (\"font-stretch\" . \"normal\")
514 (\"font-family\" . \"misc-fixed\")
515 (\"font-size\" . \"13pt\")
516 (\"text-decoration\" . \"none\"))\n
517 \(hfy-face-to-style \\='Info-title-3-face) =>
518 ((\"font-weight\" . \"700\")
519 (\"font-family\" . \"helv\")
520 (\"font-size\" . \"120%\")
521 (\"text-decoration\" . \"none\"))\n")
522
523 (defvar hfy-sheet-assoc 'please-ignore-this-line
524 "An assoc with elements of the form (face-name style-name . style-string):\n
525 '((default \"default\" . \"{background: black; color: white}\")
526 (font-lock-string-face \"string\" . \"{color: rgb(64,224,208)}\"))" )
527
528 (defvar hfy-facemap-assoc 'please-ignore-this-line
529 "An assoc of (point . FACE-SYMBOL) or (point . DEFFACE-LIST)
530 and (point . \\='end) elements, in descending order of point value
531 \(ie from the file's end to its beginning).\n
532 The map is in reverse order because inserting a <style> tag (or any other
533 string) at `point' invalidates the map for all entries with a greater value of
534 point. By traversing the map from greatest to least point, we still invalidate
535 the map as we go, but only those points we have already dealt with (and
536 therefore no longer care about) will be invalid at any time.\n
537 \\='((64820 . end)
538 (64744 . font-lock-comment-face)
539 (64736 . end)
540 (64722 . font-lock-string-face)
541 (64630 . end)
542 (64623 . font-lock-string-face)
543 (64449 . end)
544 (64446 . font-lock-keyword-face)
545 (64406 . end)
546 (64395 . font-lock-constant-face)
547 (64393 . end)
548 (64386 . font-lock-keyword-face)
549 (64379 . end)
550 ;; big similar section elided. You get the idea.
551 (4285 . font-lock-constant-face)
552 (4285 . end)
553 (4221 . font-lock-comment-face)
554 (4221 . end)
555 (4197 . font-lock-constant-face)
556 (4197 . end)
557 (1 . font-lock-comment-face))")
558
559 (defvar hfy-tmpfont-stack nil
560 "An alist of derived fonts resulting from overlays.")
561
562 (defconst hfy-hex-regex "[0-9A-Fa-f]")
563
564 (defconst hfy-triplet-regex
565 (concat
566 "\\(" hfy-hex-regex hfy-hex-regex "\\)"
567 "\\(" hfy-hex-regex hfy-hex-regex "\\)"
568 "\\(" hfy-hex-regex hfy-hex-regex "\\)"))
569
570 (defun hfy-interq (set-a set-b)
571 "Return the intersection (using `eq') of two lists SET-A and SET-B."
572 (let ((sa set-a) (interq nil) (elt nil))
573 (while sa
574 (setq elt (car sa)
575 sa (cdr sa))
576 (if (memq elt set-b) (setq interq (cons elt interq))))
577 interq))
578
579 (defun hfy-colour-vals (colour)
580 "Where COLOUR is a color name or #XXXXXX style triplet, return a
581 list of three (16 bit) rgb values for said color.\n
582 If a window system is unavailable, calls `hfy-fallback-colour-values'."
583 (if (string-match hfy-triplet-regex colour)
584 (mapcar
585 (lambda (x) (* (string-to-number (match-string x colour) 16) 257))
586 '(1 2 3))
587 ;;(message ">> %s" colour)
588 (if window-system
589 (if (fboundp 'color-values)
590 (color-values colour)
591 ;;(message "[%S]" window-system)
592 (x-color-values colour))
593 ;; blarg - tty colors are no good - go fetch some X colors:
594 (hfy-fallback-colour-values colour))))
595
596 (defvar hfy-cperl-mode-kludged-p nil)
597
598 (defun hfy-kludge-cperl-mode ()
599 "CPerl mode does its damnedest not to do some of its fontification when not
600 in a windowing system - try to trick it..."
601 (if (not hfy-cperl-mode-kludged-p)
602 (progn (if (not window-system)
603 (let ((window-system 'htmlfontify))
604 (eval-and-compile (require 'cperl-mode))
605 (setq cperl-syntaxify-by-font-lock t)))
606 (setq hfy-cperl-mode-kludged-p t))) )
607
608 (defun hfy-opt (symbol)
609 "Is option SYMBOL set."
610 (memq symbol hfy-optimizations))
611
612 (defun hfy-default-header (file style)
613 "Default value for `hfy-page-header'.
614 FILE is the name of the file.
615 STYLE is the inline CSS stylesheet (or tag referring to an external sheet)."
616 ;; (format "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
617 ;; <html>\n <head>\n <title>%s</title>\n %s\n </head>\n <body>\n" file style))
618 (format "<?xml version=\"1.0\" encoding=\"utf-8\"?>
619 <!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\"
620 \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">
621 <html xmlns=\"http://www.w3.org/1999/xhtml\">
622 <head>
623 <title>%s</title>
624 %s
625 <script type=\"text/javascript\"><!--
626 // this function is needed to work around
627 // a bug in IE related to element attributes
628 function hasClass(obj)
629 {
630 var result = false;
631 if (obj.getAttributeNode(\"class\") != null)
632 {
633 result = obj.getAttributeNode(\"class\").value;
634 }
635 return result;
636 }
637
638 function stripe(id)
639 {
640 // the flag we'll use to keep track of
641 // whether the current row is odd or even
642 var even = false;
643
644 // if arguments are provided to specify the colors
645 // of the even & odd rows, then use the them;
646 // otherwise use the following defaults:
647 var evenColor = arguments[1] ? arguments[1] : \"#fff\";
648 var oddColor = arguments[2] ? arguments[2] : \"#ddd\";
649
650 // obtain a reference to the desired table
651 // if no such table exists, abort
652 var table = document.getElementById(id);
653 if (! table) { return; }
654
655 // by definition, tables can have more than one tbody
656 // element, so we'll have to get the list of child
657 // &lt;tbody&gt;s
658 var tbodies = table.getElementsByTagName(\"tbody\");
659
660 // and iterate through them...
661 for (var h = 0; h < tbodies.length; h++)
662 {
663 // find all the &lt;tr&gt; elements...
664 var trs = tbodies[h].getElementsByTagName(\"tr\");
665
666 // ... and iterate through them
667 for (var i = 0; i < trs.length; i++)
668 {
669 // avoid rows that have a class attribute
670 // or backgroundColor style
671 if (! hasClass(trs[i]) &&
672 ! trs[i].style.backgroundColor)
673 {
674 // get all the cells in this row...
675 var tds = trs[i].getElementsByTagName(\"td\");
676
677 // and iterate through them...
678 for (var j = 0; j < tds.length; j++)
679 {
680 var mytd = tds[j];
681
682 // avoid cells that have a class attribute
683 // or backgroundColor style
684 if (! hasClass(mytd) &&
685 ! mytd.style.backgroundColor)
686 {
687 mytd.style.backgroundColor =
688 even ? evenColor : oddColor;
689 }
690 }
691 }
692 // flip from odd to even, or vice-versa
693 even = ! even;
694 }
695 }
696 }
697
698 function toggle_invis( name )
699 {
700 var filter =
701 { acceptNode:
702 function( node )
703 { var classname = node.id;
704 if( classname )
705 { var classbase = classname.substr( 0, name.length );
706 if( classbase == name ) { return NodeFilter.FILTER_ACCEPT; } }
707 return NodeFilter.FILTER_SKIP; } };
708 var walker = document.createTreeWalker( document.body ,
709 NodeFilter.SHOW_ELEMENT ,
710 filter ,
711 false );
712 while( walker.nextNode() )
713 {
714 var e = walker.currentNode;
715 if( e.style.display == \"none\" ) { e.style.display = \"inline\"; }
716 else { e.style.display = \"none\"; }
717 }
718 }
719 --> </script>
720 </head>
721 <body onload=\"stripe('index'); return true;\">\n"
722 (mapconcat 'hfy-html-quote (mapcar 'char-to-string file) "") style))
723
724 (defun hfy-default-footer (_file)
725 "Default value for `hfy-page-footer'.
726 FILE is the name of the file being rendered, in case it is needed."
727 "\n </body>\n</html>\n")
728
729 (defun hfy-link-style-string (style-string)
730 "Replace the end of a CSS style declaration STYLE-STRING with the contents
731 of the variable `hfy-src-doc-link-style', removing text matching the regex
732 `hfy-src-doc-link-unstyle' first, if necessary."
733 ;;(message "hfy-colour-vals");;DBUG
734 (if (string-match hfy-src-doc-link-unstyle style-string)
735 (setq style-string (replace-match "" 'fixed-case 'literal style-string)))
736 (if (and (not (string-match hfy-src-doc-link-style style-string))
737 (string-match "} *$" style-string))
738 (concat (replace-match hfy-src-doc-link-style
739 'fixed-case
740 'literal
741 style-string) " }")
742 style-string))
743
744 ;; utility functions - cast emacs style specification values into their
745 ;; css2 equivalents:
746 (defun hfy-triplet (colour)
747 "Takes a COLOUR name (string) and return a CSS rgb(R, G, B) triplet string.
748 Uses the definition of \"white\" to map the numbers to the 0-255 range, so
749 if you've redefined white, (esp. if you've redefined it to have a triplet
750 member lower than that of the color you are processing) strange things
751 may happen."
752 ;;(message "hfy-colour-vals");;DBUG
753 ;; TODO? Can we do somehow do better than this?
754 (cond
755 ((equal colour "unspecified-fg") (setq colour "black"))
756 ((equal colour "unspecified-bg") (setq colour "white")))
757 (let ((white (mapcar (lambda (I) (float (1+ I))) (hfy-colour-vals "white")))
758 (rgb16 (mapcar (lambda (I) (float (1+ I))) (hfy-colour-vals colour))))
759 (if rgb16
760 ;;(apply 'format "rgb(%d, %d, %d)"
761 ;; Use #rrggbb instead, it is smaller
762 (apply 'format "#%02x%02x%02x"
763 (mapcar (lambda (X)
764 (* (/ (nth X rgb16)
765 (nth X white)) 255))
766 '(0 1 2))))))
767
768 (defun hfy-family (family) (list (cons "font-family" family)))
769 (defun hfy-bgcol (colour) (list (cons "background" (hfy-triplet colour))))
770 (defun hfy-colour (colour) (list (cons "color" (hfy-triplet colour))))
771 (defun hfy-width (width) (list (cons "font-stretch" (symbol-name width))))
772
773 (defcustom hfy-font-zoom 1.05
774 "Font scaling from Emacs to HTML."
775 :type 'float
776 :group 'htmlfontify)
777
778 (defun hfy-size (height)
779 "Derive a CSS font-size specifier from an Emacs font :height attribute HEIGHT.
780 Does not cope with the case where height is a function to be applied to
781 the height of the underlying font."
782 ;; In ttys, the default face has :height == 1.
783 (and (not (display-graphic-p)) (equal 1 height) (setq height 100))
784 (list
785 (cond
786 ;;(t (cons "font-size" ": 1em"))
787 ((floatp height)
788 (cons "font-size" (format "%d%%" (* (* hfy-font-zoom height) 100))))
789 ((integerp height)
790 (cons "font-size" (format "%dpt" (/ (* hfy-font-zoom height) 10 )))) )) )
791
792 (defun hfy-slant (slant)
793 "Derive a font-style CSS specifier from the Emacs :slant attribute SLANT:
794 CSS does not define the reverse-* styles, so just maps those to the
795 regular specifiers."
796 (list (cons "font-style"
797 (or (cdr (assq slant '((italic . "italic")
798 (reverse-italic . "italic" )
799 (oblique . "oblique")
800 (reverse-oblique . "oblique"))))
801 "normal"))))
802
803 (defun hfy-weight (weight)
804 "Derive a font-weight CSS specifier from an Emacs weight spec symbol WEIGHT."
805 (list (cons "font-weight" (cdr (assq weight '((ultra-bold . "900")
806 (extra-bold . "800")
807 (bold . "700")
808 (semi-bold . "600")
809 (normal . "500")
810 (semi-light . "400")
811 (light . "300")
812 (extra-light . "200")
813 (ultra-light . "100")))))))
814
815 (defun hfy-box-to-border-assoc (spec)
816 (if spec
817 (let ((tag (car spec))
818 (val (cadr spec)))
819 (cons (case tag
820 (:color (cons "colour" val))
821 (:width (cons "width" val))
822 (:style (cons "style" val)))
823 (hfy-box-to-border-assoc (cddr spec))))))
824
825 (defun hfy-box-to-style (spec)
826 (let* ((css (hfy-box-to-border-assoc spec))
827 (col (cdr (assoc "colour" css)))
828 (s (cdr (assoc "style" css))))
829 (list
830 (if col (cons "border-color" (cdr (assoc "colour" css))))
831 (cons "border-width" (format "%dpx" (or (cdr (assoc "width" css)) 1)))
832 (cons "border-style" (case s
833 (released-button "outset")
834 (pressed-button "inset" )
835 (t "solid" ))))))
836
837 (defun hfy-box (box)
838 "Derive CSS border-* attributes from the Emacs :box attribute BOX."
839 (if box
840 (cond
841 ((integerp box) (list (cons "border-width" (format "%dpx" box))))
842 ((stringp box) (list (cons "border" (format "solid %s 1px" box))))
843 ((listp box) (hfy-box-to-style box) ))) )
844
845 (defun hfy-decor (tag _val)
846 "Derive CSS text-decoration specifiers from various Emacs font attributes.
847 TAG is an Emacs font attribute key (eg :underline).
848 VAL is ignored."
849 (list
850 ;; FIXME: Why not '("text-decoration" . "underline")? --Stef
851 (case tag
852 (:underline (cons "text-decoration" "underline" ))
853 (:overline (cons "text-decoration" "overline" ))
854 (:strike-through (cons "text-decoration" "line-through")))))
855
856 (defun hfy-invisible (&optional _val)
857 "This text should be invisible.
858 Do something in CSS to make that happen.
859 VAL is ignored here."
860 '(("display" . "none")))
861
862 (defun hfy-combined-face-spec (face)
863 "Return a `defface' style alist of possible specifications for FACE.
864 Entries resulting from customization (`custom-set-faces') will take
865 precedence."
866 (append
867 (if (and hfy-display-class hfy-default-face-def (eq face 'default))
868 hfy-default-face-def)
869 (get face 'saved-face)
870 (get face 'face-defface-spec)))
871
872 (defun hfy-face-attr-for-class (face &optional class)
873 "Return the face attributes for FACE.
874 If CLASS is set, it must be a `defface' alist key [see below],
875 in which case the first face specification returned by `hfy-combined-face-spec'
876 which *doesn't* clash with CLASS is returned.\n
877 \(A specification with a class of t is considered to match any class you
878 specify - this matches Emacs's behavior when deciding on which face attributes
879 to use, to the best of my understanding).\n
880 If CLASS is nil, then you just get whatever `face-attr-construct' returns,
881 ie the current specification in effect for FACE.\n
882 *NOTE*: This function forces any face that is not `default' and which has
883 no :inherit property to inherit from `default' (this is because `default'
884 is magical in that Emacs's fonts behave as if they inherit implicitly from
885 `default', but no such behavior exists in HTML/CSS).\n
886 See also `hfy-display-class' for details of valid values for CLASS."
887 (let ((face-spec
888 (if class
889 (let ((face-props (hfy-combined-face-spec face))
890 (face-specn nil)
891 (face-class nil)
892 (face-attrs nil)
893 (face-score -1)
894 (face-match nil))
895 (while face-props
896 (setq face-specn (car face-props)
897 face-class (car face-specn)
898 face-attrs (cdr face-specn)
899 face-props (cdr face-props))
900 ;; if the current element CEL of CLASS is t we match
901 ;; if the current face-class is t, we match
902 ;; if the cdr of CEL has a non-nil
903 ;; intersection with the cdr of the first member of
904 ;; the current face-class with the same car as CEL, we match
905 ;; if we actually clash, then we can't match
906 (let ((cbuf class)
907 (cel nil)
908 (key nil)
909 (val nil)
910 (x nil)
911 (next nil)
912 (score 0))
913 (while (and cbuf (not next))
914 (setq cel (car cbuf)
915 cbuf (cdr cbuf)
916 key (car cel)
917 val (cdr cel)
918 val (if (listp val) val (list val)))
919 (cond
920 ((or (eq cel t)
921 (memq face-class '(t default))) ;Default match.
922 (setq score 0) (ignore "t match"))
923 ((not (cdr (assq key face-class))) ;Neither good nor bad.
924 nil (ignore "non match, non collision"))
925 ((setq x (hfy-interq val (cdr (assq key face-class))))
926 (setq score (+ score (length x)))
927 (ignore "intersection"))
928 (t ;; nope.
929 (setq next t score -10) (ignore "collision")) ))
930 (if (> score face-score)
931 (progn
932 (setq face-match face-attrs
933 face-score score )
934 (ignore "%d << %S/%S" score face-class class))
935 (ignore "--- %d ---- (insufficient)" score)) ))
936 ;; matched ? last attrs : nil
937 (if face-match
938 (if (listp (car face-match)) (car face-match) face-match)
939 nil))
940 ;; Unfortunately the default face returns a
941 ;; :background. Fortunately we can remove it, but how do we do
942 ;; that in a non-system specific way?
943 (let ((spec (face-attr-construct face))
944 (new-spec nil))
945 (if (not (memq :background spec))
946 spec
947 (while spec
948 (let ((a (nth 0 spec))
949 (b (nth 1 spec)))
950 (unless (and (eq a :background)
951 (stringp b)
952 (string= b "SystemWindow"))
953 (setq new-spec (cons a (cons b new-spec)))))
954 (setq spec (cddr spec)))
955 new-spec)))))
956 (if (or (memq :inherit face-spec) (eq 'default face))
957 face-spec
958 (append face-spec (list :inherit 'default)))))
959
960 ;; construct an assoc of (css-tag-name . css-tag-value) pairs
961 ;; from a face or assoc of face attributes:
962
963 ;; Some tests etc:
964 ;; (mumamo-message-with-face "testing face" 'highlight)
965 ;; (mumamo-message-with-face "testing face" '(:foreground "red" :background "yellow"))
966 ;; (hfy-face-to-style-i '(:inherit default foreground-color "red"))
967 ;; default face=(:stipple nil :background "SystemWindow" :foreground
968 ;; "SystemWindowText" :inverse-video nil :box nil :strike-through
969 ;; nil :overline nil :underline nil :slant normal :weight normal
970 ;; :height 98 :width normal :family "outline-courier new")
971 (defun hfy-face-to-style-i (fn)
972 "The guts of `hfy-face-to-style': FN should be a `defface' font spec,
973 as returned by `face-attr-construct' or `hfy-face-attr-for-class'.
974 Note that this function does not get font-sizes right if they are based
975 on inherited modifiers (via the :inherit) attribute, and any other
976 modifiers that are cumulative if they appear multiple times need to be
977 merged by the user - `hfy-flatten-style' should do this."
978 ;;(message "hfy-face-to-style-i");;DBUG
979
980 ;; fn's value could be something like
981 ;; (:inherit
982 ;; ((foreground-color . "blue"))
983 ;; (foreground-color . "blue")
984 ;; nil)
985
986 (when fn
987 (let ((key (car fn))
988 (val (cadr fn))
989 (next (cddr fn))
990 (that nil)
991 (this nil)
992 (parent nil))
993 (if (eq key :inherit)
994 (let ((vs (if (listp val) val (list val))))
995 ;; (let ((x '(a b))) (setq x (append '(c d) x)))
996 ;; (let ((x '(a b))) (setq x (append '(c d) x)))
997 (dolist (v vs)
998 (setq parent
999 (append
1000 parent
1001 (hfy-face-to-style-i
1002 (hfy-face-attr-for-class v hfy-display-class))))))
1003 (setq this
1004 (if val (case key
1005 (:family (hfy-family val))
1006 (:width (hfy-width val))
1007 (:weight (hfy-weight val))
1008 (:slant (hfy-slant val))
1009 (:foreground (hfy-colour val))
1010 (:background (hfy-bgcol val))
1011 (:box (hfy-box val))
1012 (:height (hfy-size val))
1013 (:underline (hfy-decor key val))
1014 (:overline (hfy-decor key val))
1015 (:strike-through (hfy-decor key val))
1016 (:invisible (hfy-invisible val))
1017 (:bold (hfy-weight 'bold))
1018 (:italic (hfy-slant 'italic))))))
1019 (setq that (hfy-face-to-style-i next))
1020 ;;(lwarn t :warning "%S => %S" fn (nconc this that parent))
1021 (nconc this parent that))) )
1022
1023 (defun hfy-size-to-int (spec)
1024 "Convert SPEC, a CSS font-size specifier, to an Emacs :height attribute value.
1025 Used while merging multiple font-size attributes."
1026 ;;(message "hfy-size-to-int");;DBUG
1027 (list
1028 (if (string-match "\\([0-9]+\\)\\(%\\|pt\\)" spec)
1029 (cond ((string= "%" (match-string 2 spec))
1030 (/ (string-to-number (match-string 1 spec)) 100.0))
1031 ((string= "pt" (match-string 2 spec))
1032 (* (string-to-number (match-string 1 spec)) 10)))
1033 (string-to-number spec))) )
1034
1035 ;; size is different, in that in order to get it right at all,
1036 ;; we have to trawl the inheritance path, accumulating modifiers,
1037 ;; _until_ we get to an absolute (pt) specifier, then combine the lot
1038 (defun hfy-flatten-style (style)
1039 "Take STYLE (see `hfy-face-to-style-i', `hfy-face-to-style') and merge
1040 any multiple attributes appropriately. Currently only font-size is merged
1041 down to a single occurrence - others may need special handling, but I
1042 haven't encountered them yet. Returns a `hfy-style-assoc'."
1043 ;;(message "(hfy-flatten-style %S)" style) ;;DBUG
1044 (let ((n 0)
1045 (m (list 1))
1046 (x nil)
1047 (r nil))
1048 (dolist (css style)
1049 (if (string= (car css) "font-size")
1050 (progn
1051 (when (not x) (setq m (nconc m (hfy-size-to-int (cdr css)))))
1052 (when (string-match "pt" (cdr css)) (setq x t)))
1053 (setq r (nconc r (list css)))))
1054 ;;(message "r: %S" r)
1055 (setq n (apply '* m))
1056 (nconc r (hfy-size (if x (round n) (* n 1.0)))) ))
1057
1058 (defun hfy-face-resolve-face (fn)
1059 "For FN return a face specification.
1060 FN may be either a face or a face specification. If the latter,
1061 then the specification is returned unchanged."
1062 (cond
1063 ((facep fn)
1064 (hfy-face-attr-for-class fn hfy-display-class))
1065 ;; FIXME: is this necessary? Faces can be symbols, but
1066 ;; not symbols refering to other symbols?
1067 ((and (symbolp fn)
1068 (facep (symbol-value fn)))
1069 (hfy-face-attr-for-class
1070 (symbol-value fn) hfy-display-class))
1071 (t fn)))
1072
1073
1074 (defun hfy-face-to-style (fn)
1075 "Take FN, a font or `defface' style font specification,
1076 \(as returned by `face-attr-construct' or `hfy-face-attr-for-class')
1077 and return a `hfy-style-assoc'.\n
1078 See also `hfy-face-to-style-i', `hfy-flatten-style'."
1079 ;;(message "hfy-face-to-style");;DBUG
1080 (let* ((face-def (hfy-face-resolve-face fn))
1081 (final-style
1082 (hfy-flatten-style (hfy-face-to-style-i face-def))))
1083 ;;(message "%S" final-style)
1084 (if (not (assoc "text-decoration" final-style))
1085 (progn (setq final-style
1086 ;; Fix-me: there is no need for this since
1087 ;; text-decoration is not inherited.
1088 ;; but it's not wrong and if this ever changes it will
1089 ;; be needed, so I think it's better to leave it in? -- v
1090 (nconc final-style '(("text-decoration" . "none"))))))
1091 final-style))
1092
1093 ;; strip redundant bits from a name. Technically, this could result in
1094 ;; a collision, but it is pretty unlikely - will fix later...
1095 ;; also handle ephemeral fonts created by overlays, which don't actually
1096 ;; have names:
1097 (defun hfy-face-or-def-to-name (fn)
1098 "Render a font symbol or `defface' font spec FN into a name (string)."
1099 ;;(message "generating name for %s" fn)
1100 (if (not (listp fn))
1101 (format "%s" fn)
1102 (let* ((key (format "%s" fn))
1103 (entry (assoc key hfy-tmpfont-stack))
1104 (base (cadr (memq :inherit fn)))
1105 (tag (cdr entry)))
1106 ;;(message "checking for key «%s» in font stack [%d]"
1107 ;; key (if entry 1 0))
1108 (if entry nil ;; noop
1109 (setq tag (format "%04d" (length hfy-tmpfont-stack))
1110 entry (cons key tag)
1111 hfy-tmpfont-stack (cons entry hfy-tmpfont-stack)))
1112 ;;(message " -> name: %s-%s" (or base 'default) tag)
1113 (format "%s-%s" (or base 'default) tag)) ))
1114
1115 (defun hfy-css-name (fn)
1116 "Strip the boring bits from a font-name FN and return a CSS style name."
1117 ;;(message "hfy-css-name");;DBUG
1118 (let ((face-name (hfy-face-or-def-to-name fn)))
1119 (if (or (string-match "font-lock-\\(.*\\)" face-name)
1120 (string-match "cperl-\\(.*\\)" face-name)
1121 (string-match "^[Ii]nfo-\\(.*\\)" face-name))
1122 (progn
1123 (setq face-name (match-string 1 face-name))
1124 (if (string-match "\\(.*\\)-face\\'" face-name)
1125 (setq face-name (match-string 1 face-name)))
1126 face-name)
1127 face-name)) )
1128
1129 ;; construct an assoc of (stripped-name . "{ css-stuff-here }") pairs
1130 ;; from a face:
1131 (defun hfy-face-to-css-default (fn)
1132 "Default handler for mapping faces to styles.
1133 See also `hfy-face-to-css'."
1134 ;;(message "hfy-face-to-css");;DBUG
1135 (let* ((css-list (hfy-face-to-style fn))
1136 (seen nil)
1137 (css-text
1138 (mapcar
1139 (lambda (E)
1140 (if (car E)
1141 (unless (member (car E) seen)
1142 (push (car E) seen)
1143 (format " %s: %s; " (car E) (cdr E)))))
1144 css-list)))
1145 (cons (hfy-css-name fn) (format "{%s}" (apply 'concat css-text)))) )
1146
1147 (defvar hfy-face-to-css 'hfy-face-to-css-default
1148 "Handler for mapping faces to styles.
1149 The signature of the handler is of the form \(lambda (FN) ...).
1150 FN is a font or `defface' specification (cf
1151 `face-attr-construct'). The handler should return a cons cell of
1152 the form (STYLE-NAME . STYLE-SPEC).
1153
1154 The default handler is `hfy-face-to-css-default'.
1155
1156 See also `hfy-face-to-style'.")
1157
1158 (defalias 'hfy-prop-invisible-p
1159 (if (fboundp 'invisible-p) #'invisible-p
1160 (lambda (prop)
1161 "Is text property PROP an active invisibility property?"
1162 (or (and (eq buffer-invisibility-spec t) prop)
1163 (or (memq prop buffer-invisibility-spec)
1164 (assq prop buffer-invisibility-spec))))))
1165
1166 (defun hfy-find-invisible-ranges ()
1167 "Return a list of (start-point . end-point) cons cells of invisible regions."
1168 (save-excursion
1169 (let (invisible p i s) ;; return-value pos invisible end start
1170 (setq p (goto-char (point-min)))
1171 (when (invisible-p p) (setq s p i t))
1172 (while (< p (point-max))
1173 (if i ;; currently invisible
1174 (when (not (invisible-p p)) ;; but became visible
1175 (setq i nil
1176 invisible (cons (cons s p) invisible)))
1177 ;; currently visible:
1178 (when (invisible-p p) ;; but have become invisible
1179 (setq s p i t)))
1180 (setq p (next-char-property-change p)))
1181 ;; still invisible at buffer end?
1182 (when i
1183 (setq invisible (cons (cons s (point-max)) invisible)))
1184 invisible)))
1185
1186 (defun hfy-invisible-name (point map)
1187 "Generate a CSS style name for an invisible section of the buffer.
1188 POINT is the point inside the invisible region.
1189 MAP is the invisibility map as returned by `hfy-find-invisible-ranges'."
1190 ;;(message "(hfy-invisible-name %S %S)" point map)
1191 (let (name)
1192 (dolist (range map)
1193 (when (and (>= point (car range))
1194 (< point (cdr range)))
1195 (setq name (format "invisible-%S-%S" (car range) (cdr range)))))
1196 name))
1197
1198 ;; Fix-me: This function needs some cleanup by someone who understand
1199 ;; all the formats that face properties can have.
1200 ;;
1201 ;; overlay handling should be fine. haven't tested multiple stacked overlapping
1202 ;; overlays recently, but the common case of a text property face + an overlay
1203 ;; face produces the correct merged css style (or as close to it as css can get)
1204 ;; -- v
1205 (defun hfy-face-at (p)
1206 "Find face in effect at point P.
1207 If overlays are to be considered (see `hfy-optimizations') then this may
1208 return a `defface' style list of face properties instead of a face symbol."
1209 ;;(message "hfy-face-at");;DBUG
1210 ;; Fix-me: clean up, remove face-name etc
1211 ;; not sure why we'd want to remove face-name? -- v
1212 (let ((overlay-data nil)
1213 (base-face nil)
1214 (face-name (get-text-property p 'face))
1215 ;; (face-name (hfy-get-face-at p))
1216 (prop-seen nil)
1217 (extra-props nil)
1218 (text-props (text-properties-at p)))
1219 ;;(message "face-name: %S" face-name)
1220 (when (and face-name (listp face-name) (facep (car face-name)))
1221 ;;(message "face-name is a list %S" face-name)
1222 ;;(setq text-props (cons 'face face-name))
1223 (dolist (f face-name)
1224 (setq extra-props (if (listp f)
1225 ;; for things like (variable-pitch
1226 ;; (:foreground "red"))
1227 (cons f extra-props)
1228 (cons :inherit (cons f extra-props)))))
1229 (setq base-face (car face-name)
1230 face-name nil))
1231 ;; text-properties-at => (face (:foreground "red" ...))
1232 ;; or => (face (compilation-info underline)) list of faces
1233 ;; overlay-properties
1234 ;; format= (evaporate t face ((foreground-color . "red")))
1235
1236 ;; SO: if we have turned overlays off,
1237 ;; or if there's no overlay data
1238 ;; just bail out and return whatever face data we've accumulated so far
1239 (if (or (not (hfy-opt 'keep-overlays))
1240 (not (setq overlay-data (hfy-overlay-props-at p))))
1241 (progn
1242 ;;(message "· %d: %s; %S; %s"
1243 ;; p face-name extra-props text-props)
1244 (or face-name base-face)) ;; no overlays or extra properties
1245 ;; collect any face data and any overlay data for processing:
1246 (when text-props
1247 (push text-props overlay-data))
1248 (setq overlay-data (nreverse overlay-data))
1249 ;;(message "- %d: %s; %S; %s; %s"
1250 ;; p face-name extra-props text-props overlay-data)
1251 ;; remember the basic face name so we don't keep repeating its specs:
1252 (when face-name (setq base-face face-name))
1253 (dolist (P overlay-data)
1254 (let ((iprops (cadr (memq 'invisible P)))) ;FIXME: plist-get?
1255 ;;(message "(hfy-prop-invisible-p %S)" iprops)
1256 (when (and iprops (hfy-prop-invisible-p iprops))
1257 (setq extra-props
1258 (cons :invisible (cons t extra-props))) ))
1259 (let ((fprops (cadr (or (memq 'face P)
1260 (memq 'font-lock-face P)))))
1261 ;;(message "overlay face: %s" fprops)
1262 (if (not (listp fprops))
1263 (let ((this-face (if (stringp fprops) (intern fprops) fprops)))
1264 (when (not (eq this-face base-face))
1265 (setq extra-props
1266 (cons :inherit
1267 (cons this-face extra-props))) ))
1268 (while fprops
1269 (if (facep (car fprops))
1270 (let ((face (car fprops)))
1271 (when (stringp face) (setq face (intern fprops)))
1272 (setq extra-props
1273 (cons :inherit
1274 (cons face
1275 extra-props)))
1276 (setq fprops (cdr fprops)))
1277 (let (p v)
1278 ;; Sigh.
1279 (if (listp (car fprops))
1280 (if (nlistp (cdr (car fprops)))
1281 (progn
1282 ;; ((prop . val))
1283 (setq p (caar fprops))
1284 (setq v (cdar fprops))
1285 (setq fprops (cdr fprops)))
1286 ;; ((prop val))
1287 (setq p (caar fprops))
1288 (setq v (cadar fprops))
1289 (setq fprops (cdr fprops)))
1290 (if (listp (cdr fprops))
1291 (progn
1292 ;; (:prop val :prop val ...)
1293 (setq p (car fprops))
1294 (setq v (cadr fprops))
1295 (setq fprops (cddr fprops)))
1296 (if (and (listp fprops)
1297 (not (listp (cdr fprops))))
1298 ;;(and (consp x) (cdr (last x)))
1299 (progn
1300 ;; (prop . val)
1301 (setq p (car fprops))
1302 (setq v (cdr fprops))
1303 (setq fprops nil))
1304 (error "Eh... another format! fprops=%s" fprops) )))
1305 (setq p (case p
1306 ;; These are all the properties handled
1307 ;; in `hfy-face-to-style-i'.
1308 ;;
1309 ;; Are these translations right?
1310 ;; yes, they are -- v
1311 (family :family )
1312 (width :width )
1313 (height :height )
1314 (weight :weight )
1315 (slant :slant )
1316 (underline :underline )
1317 (overline :overline )
1318 (strike-through :strike-through)
1319 (box :box )
1320 (foreground-color :foreground)
1321 (background-color :background)
1322 (bold :bold )
1323 (italic :italic )
1324 (t p)))
1325 (if (memq p prop-seen) nil ;; noop
1326 (setq prop-seen (cons p prop-seen)
1327 extra-props (cons p (cons v extra-props))))))))))
1328 ;;(message "+ %d: %s; %S" p face-name extra-props)
1329 (if extra-props
1330 (nconc extra-props (if (listp face-name)
1331 face-name
1332 (face-attr-construct face-name)))
1333 face-name)) ))
1334
1335 (defun hfy-overlay-props-at (p)
1336 "Grab overlay properties at point P.
1337 The plists are returned in descending priority order."
1338 (mapcar #'overlay-properties (overlays-at p 'sorted)))
1339
1340 ;; construct an assoc of (face-name . (css-name . "{ css-style }")) elements:
1341 (defun hfy-compile-stylesheet ()
1342 "Trawl the current buffer, construct and return a `hfy-sheet-assoc'.
1343 If `hfy-user-sheet-assoc' is currently bound then use it to
1344 collect new styles discovered during this run. Otherwise create
1345 a new assoc."
1346 ;;(message "hfy-compile-stylesheet");;DBUG
1347 (let ((pt (point-min))
1348 ;; Make the font stack stay:
1349 ;;(hfy-tmpfont-stack nil)
1350 (fn nil)
1351 (style (and (boundp 'hfy-user-sheet-assoc) hfy-user-sheet-assoc)))
1352 (save-excursion
1353 (goto-char pt)
1354 (while (< pt (point-max))
1355 (if (and (setq fn (hfy-face-at pt)) (not (assoc fn style)))
1356 (push (cons fn (funcall hfy-face-to-css fn)) style))
1357 (setq pt (next-char-property-change pt))))
1358 (unless (assoc 'default style)
1359 (push (cons 'default (funcall hfy-face-to-css 'default)) style))
1360 (when (boundp 'hfy-user-sheet-assoc)
1361 (setq hfy-user-sheet-assoc style))
1362 style))
1363
1364 (defun hfy-fontified-p ()
1365 "`font-lock' doesn't like to say it's been fontified when in batch
1366 mode, but we want to know if we should fontify or raw copy, so in batch
1367 mode we check for non-default face properties. Otherwise we test
1368 variable `font-lock-mode' and variable `font-lock-fontified' for truth."
1369 ;;(message "font-lock-fontified: %S" font-lock-fontified)
1370 ;;(message "noninteractive : %S" noninteractive)
1371 ;;(message "font-lock-mode : %S" font-lock-mode)
1372 (and font-lock-fontified
1373 (if noninteractive
1374 (let ((pt (point-min))
1375 (face-name nil))
1376 (save-excursion
1377 (goto-char pt)
1378 (while (and (< pt (point-max)) (not face-name))
1379 (setq face-name (hfy-face-at pt))
1380 (setq pt (next-char-property-change pt))))
1381 face-name)
1382 font-lock-mode)))
1383
1384 ;; remember, the map is in reverse point order:
1385 ;; I wrote this while suffering the effects of a cold, and maybe a
1386 ;; mild fever - I think it's correct, but it might be a little warped
1387 ;; as my minfd keeps ... where was I? Oh yes, the bunnies...
1388 (defun hfy-merge-adjacent-spans (face-map)
1389 "Where FACE-MAP is a `hfy-facemap-assoc' for the current buffer,
1390 this function merges adjacent style blocks which are of the same value
1391 and are separated by nothing more interesting than whitespace.\n
1392 <span class=\"foo\">narf</span> <span class=\"foo\">brain</span>\n
1393 \(as interpreted from FACE-MAP) would become:\n
1394 <span class=\"foo\">narf brain</span>\n
1395 Returns a modified copy of FACE-MAP."
1396 (let ((tmp-map face-map)
1397 (map-buf nil)
1398 (first-start nil)
1399 (first-stop nil)
1400 (last-start nil)
1401 (last-stop nil)
1402 (span-stop nil)
1403 (span-start nil)
1404 (reduced-map nil))
1405 ;;(push (car tmp-map) reduced-map)
1406 ;;(push (cadr tmp-map) reduced-map)
1407 (while tmp-map
1408 (setq first-start (cadddr tmp-map)
1409 first-stop (caddr tmp-map)
1410 last-start (cadr tmp-map)
1411 last-stop (car tmp-map)
1412 map-buf tmp-map
1413 span-start last-start
1414 span-stop last-stop )
1415 (while (and (equal (cdr first-start)
1416 (cdr last-start))
1417 (save-excursion
1418 (goto-char (car first-stop))
1419 (not (re-search-forward "[^ \t\n\r]" (car last-start) t))))
1420 (setq map-buf (cddr map-buf)
1421 span-start first-start
1422 first-start (cadddr map-buf)
1423 first-stop (caddr map-buf)
1424 last-start (cadr map-buf)
1425 last-stop (car map-buf)))
1426 (push span-stop reduced-map)
1427 (push span-start reduced-map)
1428 (setq tmp-map (memq last-start tmp-map))
1429 (setq tmp-map (cdr tmp-map)))
1430 (setq reduced-map (nreverse reduced-map))))
1431
1432 ;; remember to generate 'synthetic' </span> entries -
1433 ;; emacs copes by just having a stack of styles in effect
1434 ;; and only using the top one: html has a more simplistic approach -
1435 ;; we have to explicitly end a style, there's no way of temporarily
1436 ;; overriding it w. another one... (afaik)
1437 (defun hfy-compile-face-map ()
1438 ;; no need for special <a> version.
1439 ;; IME hyperlinks don't get underlined, esp when you htmlfontify a whole
1440 ;; source tree, so the <a> version is needed -- v
1441 ;; Fix-me: save table for multi-buffer
1442 "Compile and return a `hfy-facemap-assoc' for the current buffer."
1443 ;;(message "hfy-compile-face-map");;DBUG
1444 (let* ((pt (point-min))
1445 (pt-narrow (save-restriction (widen) (point-min)))
1446 (offset (- pt pt-narrow))
1447 (fn nil)
1448 (map nil)
1449 (prev-tag nil)) ;; t if the last tag-point was a span-start
1450 ;; nil if it was a span-stop
1451 (save-excursion
1452 (goto-char pt)
1453 (while (< pt (point-max))
1454 (if (setq fn (hfy-face-at pt))
1455 (progn (if prev-tag (push (cons pt-narrow 'end) map))
1456 (push (cons pt-narrow fn) map)
1457 (setq prev-tag t))
1458 (if prev-tag (push (cons pt-narrow 'end) map))
1459 (setq prev-tag nil))
1460 (setq pt (next-char-property-change pt))
1461 (setq pt-narrow (+ offset pt)))
1462 (if (and map (not (eq 'end (cdar map))))
1463 (push (cons (1+ (- (point-max) (point-min))) 'end) map)))
1464 (if (hfy-opt 'merge-adjacent-tags) (hfy-merge-adjacent-spans map) map)))
1465
1466 (defun hfy-buffer ()
1467 "Generate a buffer to hold the HTML output.
1468 The filename of this buffer is derived from the source (current) buffer's
1469 variable `buffer-file-name', if it is set, plus `hfy-extn'.
1470 Otherwise a plausible filename is constructed from `default-directory',
1471 `buffer-name' and `hfy-extn'."
1472 (let* ((name (concat (buffer-name) hfy-extn))
1473 (src (buffer-file-name))
1474 (buf (get-buffer-create name)))
1475 (with-current-buffer buf
1476 (setq buffer-file-name
1477 (if src (concat src hfy-extn)
1478 (expand-file-name (if (string-match "^.*/\\([^/]*\\)\\'" name)
1479 (match-string 1 name)
1480 name))))
1481 buf)))
1482
1483 (defun hfy-lookup (face style)
1484 "Get a CSS style name for FACE from STYLE."
1485 (cadr (assoc face style)))
1486
1487 (defun hfy-link-style (style-string)
1488 "Copy, alter and return a STYLE-STRING to make it suitable for a hyperlink.
1489 Uses `hfy-link-style-fun' to do this."
1490 (if (functionp hfy-link-style-fun)
1491 (funcall hfy-link-style-fun style-string)
1492 style-string))
1493
1494 (defun hfy-sprintf-stylesheet (css file)
1495 "Return the inline CSS style sheet for FILE as a string."
1496 (let ((stylesheet
1497 (concat
1498 hfy-meta-tags
1499 "\n<style type=\"text/css\"><!-- \n"
1500 ;; Fix-me: Add handling of page breaks here + scan for ^L
1501 ;; where appropriate.
1502 (format "body %s\n" (cddr (assq 'default css)))
1503 (apply 'concat
1504 (mapcar
1505 (lambda (style)
1506 (format
1507 "span.%s %s\nspan.%s a %s\n"
1508 (cadr style) (cddr style)
1509 (cadr style) (hfy-link-style (cddr style))))
1510 css))
1511 " --></style>\n")))
1512 (funcall hfy-page-header file stylesheet)))
1513
1514 ;; tag all the dangerous characters we want to escape
1515 ;; (ie any "<> chars we _didn't_ put there explicitly for css markup)
1516 (defun hfy-html-enkludge-buffer ()
1517 "Mark dangerous [\"<>] characters with the `hfy-quoteme' property.\n
1518 See also `hfy-html-dekludge-buffer'."
1519 ;;(message "hfy-html-enkludge-buffer");;DBUG
1520 (save-excursion
1521 (goto-char (point-min))
1522 (while (re-search-forward hfy-html-quote-regex nil t)
1523 (put-text-property (match-beginning 0) (point) 'hfy-quoteme t))) )
1524
1525 ;; dangerous char -> &entity;
1526 (defun hfy-html-quote (char-string)
1527 "Map CHAR-STRING to an HTML safe string (entity) if need be."
1528 ;;(message "hfy-html-quote");;DBUG
1529 (or (cadr (assoc char-string hfy-html-quote-map)) char-string) )
1530
1531 ;; actually entity-ise dangerous chars.
1532 ;; note that we can't do this until _after_ we have inserted the css
1533 ;; markup, since we use a position-based map to insert this, and if we
1534 ;; enter any other text before we do this, we'd have to track another
1535 ;; map of offsets, which would be tedious...
1536 (defun hfy-html-dekludge-buffer ()
1537 "Transform all dangerous characters marked with the `hfy-quoteme' property
1538 using `hfy-html-quote'.\n
1539 See also `hfy-html-enkludge-buffer'."
1540 ;;(message "hfy-html-dekludge-buffer");;DBUG
1541 (save-excursion
1542 (goto-char (point-min))
1543 (while (re-search-forward hfy-html-quote-regex nil t)
1544 (if (get-text-property (match-beginning 0) 'hfy-quoteme)
1545 (replace-match (hfy-html-quote (match-string 1))) )) ))
1546
1547 ;; Borrowed from font-lock.el
1548 (defmacro hfy-save-buffer-state (varlist &rest body)
1549 "Bind variables according to VARLIST and eval BODY restoring buffer state.
1550 Do not record undo information during evaluation of BODY."
1551 (declare (indent 1) (debug let))
1552 (let ((modified (make-symbol "modified")))
1553 `(let* ,(append varlist
1554 `((,modified (buffer-modified-p))
1555 (buffer-undo-list t)
1556 (inhibit-read-only t)
1557 (inhibit-point-motion-hooks t)
1558 (inhibit-modification-hooks t)
1559 deactivate-mark
1560 buffer-file-name
1561 buffer-file-truename))
1562 (progn
1563 ,@body)
1564 (unless ,modified
1565 (restore-buffer-modified-p nil)))))
1566
1567 (defun hfy-mark-trailing-whitespace ()
1568 "Tag trailing whitespace with a hfy property if it is currently highlighted."
1569 (when show-trailing-whitespace
1570 (let ((inhibit-read-only t))
1571 (save-excursion
1572 (goto-char (point-min))
1573 (hfy-save-buffer-state nil
1574 (while (re-search-forward "[ \t]+$" nil t)
1575 (put-text-property (match-beginning 0) (match-end 0)
1576 'hfy-show-trailing-whitespace t)))))))
1577
1578 (defun hfy-unmark-trailing-whitespace ()
1579 "Undo the effect of `hfy-mark-trailing-whitespace'."
1580 (when show-trailing-whitespace
1581 (hfy-save-buffer-state nil
1582 (remove-text-properties (point-min) (point-max)
1583 '(hfy-show-trailing-whitespace)))))
1584
1585 (defun hfy-begin-span (style text-block text-id text-begins-block-p)
1586 "Default handler to begin a span of text.
1587 Insert \"<span class=\"STYLE\" ...>\". See
1588 `hfy-begin-span-handler' for more information."
1589 (when text-begins-block-p
1590 (insert
1591 (format "<span onclick=\"toggle_invis('%s');\">…</span>" text-block)))
1592
1593 (insert
1594 (if text-block
1595 (format "<span class=\"%s\" id=\"%s-%d\">" style text-block text-id)
1596 (format "<span class=\"%s\">" style))))
1597
1598 (defun hfy-end-span ()
1599 "Default handler to end a span of text.
1600 Insert \"</span>\". See `hfy-end-span-handler' for more
1601 information."
1602 (insert "</span>"))
1603
1604 (defvar hfy-begin-span-handler 'hfy-begin-span
1605 "Handler to begin a span of text.
1606 The signature of the handler is \(lambda (STYLE TEXT-BLOCK
1607 TEXT-ID TEXT-BEGINS-BLOCK-P) ...). The handler must insert
1608 appropriate tags to begin a span of text.
1609
1610 STYLE is the name of the style that begins at point. It is
1611 derived from the face attributes as part of `hfy-face-to-css'
1612 callback. The other arguments TEXT-BLOCK, TEXT-ID,
1613 TEXT-BEGINS-BLOCK-P are non-nil only if the buffer contains
1614 invisible text.
1615
1616 TEXT-BLOCK is a string that identifies a single chunk of visible
1617 or invisible text of which the current position is a part. For
1618 visible portions, it's value is \"nil\". For invisible portions,
1619 it's value is computed as part of `hfy-invisible-name'.
1620
1621 TEXT-ID marks a unique position within a block. It is set to
1622 value of `point' at the current buffer position.
1623
1624 TEXT-BEGINS-BLOCK-P is a boolean and is non-nil if the current
1625 span also begins a invisible portion of text.
1626
1627 An implementation can use TEXT-BLOCK, TEXT-ID,
1628 TEXT-BEGINS-BLOCK-P to implement fold/unfold-on-mouse-click like
1629 behavior.
1630
1631 The default handler is `hfy-begin-span'.")
1632
1633 (defvar hfy-end-span-handler 'hfy-end-span
1634 "Handler to end a span of text.
1635 The signature of the handler is \(lambda () ...). The handler
1636 must insert appropriate tags to end a span of text.
1637
1638 The default handler is `hfy-end-span'.")
1639
1640 (defun hfy-fontify-buffer (&optional srcdir file)
1641 "Implement the guts of `htmlfontify-buffer'.
1642 SRCDIR, if set, is the directory being htmlfontified.
1643 FILE, if set, is the file name."
1644 (if srcdir (setq srcdir (directory-file-name srcdir)))
1645 (let* ( (html-buffer (hfy-buffer))
1646 (css-sheet nil)
1647 (css-map nil)
1648 (invis-ranges nil)
1649 (rovl nil)
1650 (rmin (when mark-active (region-beginning)))
1651 (rmax (when mark-active (region-end ))) )
1652 (when (and mark-active
1653 transient-mark-mode)
1654 (unless (and (= rmin (point-min))
1655 (= rmax (point-max)))
1656 (setq rovl (make-overlay rmin rmax))
1657 (overlay-put rovl 'priority 1000)
1658 (overlay-put rovl 'face 'region)))
1659 ;; copy the buffer, including fontification, and switch to it:
1660 (hfy-mark-trailing-whitespace)
1661 (setq css-sheet (hfy-compile-stylesheet )
1662 css-map (hfy-compile-face-map )
1663 invis-ranges (hfy-find-invisible-ranges))
1664 (hfy-unmark-trailing-whitespace)
1665 (when rovl
1666 (delete-overlay rovl))
1667 (copy-to-buffer html-buffer (point-min) (point-max))
1668 (set-buffer html-buffer)
1669 ;; rip out props that could interfere with our htmlization of the buffer:
1670 (remove-text-properties (point-min) (point-max) hfy-ignored-properties)
1671 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1672 ;; at this point, html-buffer retains the fontification of the parent:
1673 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1674 ;; we don't really need or want text in the html buffer to be invisible, as
1675 ;; that can make it look like we've rendered invalid xhtml when all that's
1676 ;; happened is some tags are in the invisible portions of the buffer:
1677 (setq buffer-invisibility-spec nil)
1678 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1679 ;; #####################################################################
1680 ;; if we are in etags mode, add properties to mark the anchors and links
1681 (if (and srcdir file)
1682 (progn
1683 (hfy-mark-tag-names srcdir file) ;; mark anchors
1684 (hfy-mark-tag-hrefs srcdir file))) ;; mark links
1685 ;; #####################################################################
1686 ;; mark the 'dangerous' characters
1687 ;;(message "marking dangerous characters")
1688 (hfy-html-enkludge-buffer)
1689 ;; trawl the position-based face-map, inserting span tags as we go
1690 ;; note that we cannot change any character positions before this point
1691 ;; or we will invalidate the map:
1692 ;; NB: This also means we have to trawl the map in descending file-offset
1693 ;; order, obviously.
1694 ;; ---------------------------------------------------------------------
1695 ;; Remember, inserting pushes properties to the right, which we don't
1696 ;; actually want to happen for link properties, so we have to flag
1697 ;; them and move them by hand - if you don't, you end up with
1698 ;;
1699 ;; <span class="foo"><a href="bar">texta</span><span class="bletch"></a>...
1700 ;;
1701 ;; instead of:
1702 ;;
1703 ;; <span class="foo"><a href="bar">texta</a></span><span class="bletch">...
1704 ;;
1705 ;; If my analysis of the problem is correct, we can detect link-ness by
1706 ;; either hfy-linkp or hfy-endl properties at the insertion point, but I
1707 ;; think we only need to relocate the hfy-endl property, as the hfy-linkp
1708 ;; property has already served its main purpose by this point.
1709 ;;(message "mapcar over the CSS-MAP")
1710 ;; (message "invis-ranges:\n%S" invis-ranges)
1711 (dolist (point-face css-map)
1712 (let ((pt (car point-face))
1713 (fn (cdr point-face))
1714 (move-link nil))
1715 (goto-char pt)
1716 (setq move-link
1717 (or (get-text-property pt 'hfy-linkp)
1718 (get-text-property pt 'hfy-endl )))
1719 (if (eq 'end fn)
1720 (funcall hfy-end-span-handler)
1721 (if (not (and srcdir file))
1722 nil
1723 (when move-link
1724 (remove-text-properties (point) (1+ (point)) '(hfy-endl nil))
1725 (put-text-property pt (1+ pt) 'hfy-endl t) ))
1726 ;; if we have invisible blocks, we need to do some extra magic:
1727 (funcall hfy-begin-span-handler
1728 (hfy-lookup fn css-sheet)
1729 (and invis-ranges
1730 (format "%s" (hfy-invisible-name pt invis-ranges)))
1731 (and invis-ranges pt)
1732 (and invis-ranges (assq pt invis-ranges)))
1733 (if (not move-link) nil
1734 ;;(message "removing prop2 @ %d" (point))
1735 (if (remove-text-properties (point) (1+ (point)) '(hfy-endl nil))
1736 (put-text-property pt (1+ pt) 'hfy-endl t))))))
1737 ;; #####################################################################
1738 ;; Invisibility
1739 ;; Maybe just make the text invisible in XHTML?
1740 ;; DONE -- big block of obsolete invisibility code elided here -- v
1741 ;; #####################################################################
1742 ;; (message "checking to see whether we should link...")
1743 (if (and srcdir file)
1744 (let ((lp 'hfy-link)
1745 (pt (point-min))
1746 (pr nil)
1747 (rr nil))
1748 ;; (message " yes we should.")
1749 ;; translate 'hfy-anchor properties to anchors
1750 (while (setq pt (next-single-property-change pt 'hfy-anchor))
1751 (if (setq pr (get-text-property pt 'hfy-anchor))
1752 (progn (goto-char pt)
1753 (remove-text-properties pt (1+ pt) '(hfy-anchor nil))
1754 (insert (concat "<a name=\"" pr "\"></a>")))))
1755 ;; translate alternate 'hfy-link and 'hfy-endl props to opening
1756 ;; and closing links. (this should avoid those spurious closes
1757 ;; we sometimes get by generating only paired tags)
1758 (setq pt (point-min))
1759 (while (setq pt (next-single-property-change pt lp))
1760 (if (not (setq pr (get-text-property pt lp))) nil
1761 (goto-char pt)
1762 (remove-text-properties pt (1+ pt) (list lp nil))
1763 (case lp
1764 (hfy-link
1765 (if (setq rr (get-text-property pt 'hfy-inst))
1766 (insert (format "<a name=\"%s\"></a>" rr)))
1767 (insert (format "<a href=\"%s\">" pr))
1768 (setq lp 'hfy-endl))
1769 (hfy-endl
1770 (insert "</a>") (setq lp 'hfy-link)) ))) ))
1771
1772 ;; #####################################################################
1773 ;; transform the dangerous chars. This changes character positions
1774 ;; since entities have > char length.
1775 ;; note that this deletes the dangerous characters, and therefore
1776 ;; destroys any properties they may contain (such as 'hfy-endl),
1777 ;; so we have to do this after we use said properties:
1778 ;; (message "munging dangerous characters")
1779 (hfy-html-dekludge-buffer)
1780 (unless (hfy-opt 'body-text-only)
1781 ;; insert the stylesheet at the top:
1782 (goto-char (point-min))
1783
1784 ;;(message "inserting stylesheet")
1785 (insert (hfy-sprintf-stylesheet css-sheet file))
1786
1787 (if (hfy-opt 'div-wrapper) (insert "<div class=\"default\">"))
1788 (insert "\n<pre>")
1789 (goto-char (point-max))
1790 (insert "</pre>\n")
1791 (if (hfy-opt 'div-wrapper) (insert "</div>"))
1792 ;;(message "inserting footer")
1793 (insert (funcall hfy-page-footer file)))
1794 ;; call any post html-generation hooks:
1795 (run-hooks 'hfy-post-html-hook)
1796 ;; return the html buffer
1797 (set-buffer-modified-p nil)
1798 html-buffer))
1799
1800 (defun htmlfontify-string (string)
1801 "Take a STRING and return a fontified version of it.
1802 It is assumed that STRING has text properties that allow it to be
1803 fontified. This is a simple convenience wrapper around
1804 `htmlfontify-buffer'."
1805 (let* ((hfy-optimizations-1 (copy-sequence hfy-optimizations))
1806 (hfy-optimizations (add-to-list 'hfy-optimizations-1
1807 'skip-refontification)))
1808 (with-temp-buffer
1809 (insert string)
1810 (htmlfontify-buffer)
1811 (buffer-string))))
1812
1813 (defun hfy-force-fontification ()
1814 "Try to force font-locking even when it is optimized away."
1815 (run-hooks 'hfy-init-kludge-hook)
1816 (eval-and-compile (require 'font-lock))
1817 (if (boundp 'font-lock-cache-position)
1818 (or font-lock-cache-position
1819 (setq font-lock-cache-position (make-marker))))
1820 (cond
1821 (noninteractive
1822 (message "hfy batch mode (%s:%S)"
1823 (or (buffer-file-name) (buffer-name)) major-mode)
1824 (if (fboundp 'font-lock-ensure)
1825 (font-lock-ensure)
1826 (when font-lock-defaults
1827 (font-lock-fontify-buffer))))
1828 ((fboundp #'jit-lock-fontify-now)
1829 (message "hfy jit-lock mode (%S %S)" window-system major-mode)
1830 (jit-lock-fontify-now))
1831 (t
1832 (message "hfy interactive mode (%S %S)" window-system major-mode)
1833 ;; If jit-lock is not in use, then the buffer is already fontified!
1834 ;; (when (and font-lock-defaults
1835 ;; font-lock-mode)
1836 ;; (font-lock-fontify-region (point-min) (point-max) nil))
1837 )))
1838
1839 ;;;###autoload
1840 (defun htmlfontify-buffer (&optional srcdir file)
1841 "Create a new buffer, named for the current buffer + a .html extension,
1842 containing an inline CSS-stylesheet and formatted CSS-markup HTML
1843 that reproduces the look of the current Emacs buffer as closely
1844 as possible.
1845
1846 Dangerous characters in the existing buffer are turned into HTML
1847 entities, so you should even be able to do HTML-within-HTML
1848 fontified display.
1849
1850 You should, however, note that random control or eight-bit
1851 characters such as ^L (\x0c) or ¤ (\xa4) won't get mapped yet.
1852
1853 If the SRCDIR and FILE arguments are set, lookup etags derived
1854 entries in the `hfy-tags-cache' and add HTML anchors and
1855 hyperlinks as appropriate."
1856 (interactive)
1857 ;; pick up the file name in case we didn't receive it
1858 (if (not file)
1859 (progn (setq file (or (buffer-file-name) (buffer-name)))
1860 (if (string-match "/\\([^/]*\\)\\'" file)
1861 (setq file (match-string 1 file)))) )
1862
1863 (if (not (hfy-opt 'skip-refontification))
1864 (save-excursion ;; Keep region
1865 (hfy-force-fontification)))
1866 (if (called-interactively-p 'any) ;; display the buffer in interactive mode:
1867 (switch-to-buffer (hfy-fontify-buffer srcdir file))
1868 (hfy-fontify-buffer srcdir file)))
1869
1870 ;; recursive file listing
1871 (defun hfy-list-files (directory)
1872 "Return a list of files under DIRECTORY.
1873 Strips any leading \"./\" from each filename."
1874 ;;(message "hfy-list-files");;DBUG
1875 ;; FIXME: this changes the dir of the current buffer. Is that right??
1876 (cd directory)
1877 (mapcar (lambda (F) (if (string-match "^./\\(.*\\)" F) (match-string 1 F) F))
1878 (split-string (shell-command-to-string hfy-find-cmd))) )
1879
1880 ;; strip the filename off, return a directory name
1881 ;; not a particularly thorough implementation, but it will be
1882 ;; fed pretty carefully, so it should be Ok:
1883 (defun hfy-dirname (file)
1884 "Return everything preceding the last \"/\" from a relative filename FILE,
1885 on the assumption that this will produce a relative directory name.
1886 Hardly bombproof, but good enough in the context in which it is being used."
1887 ;;(message "hfy-dirname");;DBUG
1888 (let ((f (directory-file-name file)))
1889 (and (string-match "^\\(.*\\)/" f) (match-string 1 f))))
1890
1891 ;; create a directory, cf mkdir -p
1892 (defun hfy-make-directory (dir)
1893 "Approx. equivalent of mkdir -p DIR."
1894 ;;(message "hfy-make-directory");;DBUG
1895 (if (file-exists-p dir)
1896 (if (file-directory-p dir) t)
1897 (make-directory dir t)))
1898
1899 (defun hfy-text-p (srcdir file)
1900 "Is SRCDIR/FILE text? Uses `hfy-istext-command' to determine this."
1901 (let* ((cmd (format hfy-istext-command (expand-file-name file srcdir)))
1902 (rsp (shell-command-to-string cmd)))
1903 (string-match "text" rsp)))
1904
1905 ;; open a file, check fontification, if fontified, write a fontified copy
1906 ;; to the destination directory, otherwise just copy the file:
1907 (defun hfy-copy-and-fontify-file (srcdir dstdir file)
1908 "Open FILE in SRCDIR - if fontified, write a fontified copy to DSTDIR
1909 adding an extension of `hfy-extn'. Fontification is actually done by
1910 `htmlfontify-buffer'. If the buffer is not fontified, just copy it."
1911 ;;(message "hfy-copy-and-fontify-file");;DBUG
1912 (let (;;(fast-lock-minimum-size hfy-fast-lock-save)
1913 ;;(font-lock-support-mode 'fast-lock-mode)
1914 ;;(window-system (or window-system 'htmlfontify))
1915 (target nil)
1916 (source nil)
1917 (html nil))
1918 (cd srcdir)
1919 (with-current-buffer (setq source (find-file-noselect file))
1920 ;; FIXME: Shouldn't this use expand-file-name? --Stef
1921 (setq target (concat dstdir "/" file))
1922 (hfy-make-directory (hfy-dirname target))
1923 (if (not (hfy-opt 'skip-refontification)) (hfy-force-fontification))
1924 (if (or (hfy-fontified-p) (hfy-text-p srcdir file))
1925 (progn (setq html (hfy-fontify-buffer srcdir file))
1926 (set-buffer html)
1927 (write-file (concat target hfy-extn))
1928 (kill-buffer html))
1929 ;; #o0200 == 128, but emacs20 doesn't know that
1930 (if (and (file-exists-p target) (not (file-writable-p target)))
1931 (set-file-modes target (logior (file-modes target) 128)))
1932 (copy-file (buffer-file-name source) target 'overwrite))
1933 (kill-buffer source)) ))
1934
1935 ;; list of tags in file in srcdir
1936 (defun hfy-tags-for-file (cache-hash file)
1937 "List of etags tags that have definitions in this FILE.
1938 CACHE-HASH is the tags cache."
1939 ;;(message "hfy-tags-for-file");;DBUG
1940 (let* ((tag-list nil))
1941 (if cache-hash
1942 (maphash
1943 (lambda (K V)
1944 (if (assoc file V)
1945 (setq tag-list (cons K tag-list))))
1946 cache-hash))
1947 tag-list))
1948
1949 ;; mark the tags native to this file for anchors
1950 (defun hfy-mark-tag-names (srcdir file)
1951 "Mark tags in FILE (lookup SRCDIR in `hfy-tags-cache') with the `hfy-anchor'
1952 property, with a value of \"tag.line-number\"."
1953 ;;(message "(hfy-mark-tag-names %s %s)" srcdir file);;DBUG
1954 (let* ((cache-entry (assoc srcdir hfy-tags-cache))
1955 (cache-hash (cadr cache-entry)))
1956 (if cache-hash
1957 (mapcar
1958 (lambda (TAG)
1959 (mapcar
1960 (lambda (TLIST)
1961 (if (string= file (car TLIST))
1962 (let* ((line (cadr TLIST) )
1963 (chr (caddr TLIST) )
1964 (link (format "%s.%d" TAG line) ))
1965 (put-text-property (+ 1 chr)
1966 (+ 2 chr)
1967 'hfy-anchor link))))
1968 (gethash TAG cache-hash)))
1969 (hfy-tags-for-file cache-hash file)))))
1970
1971 (defun hfy-relstub (file &optional start)
1972 "Return a \"../\" stub of the appropriate length for the current source
1973 tree depth, as determined from FILE (a filename).
1974 START is the offset at which to start looking for the / character in FILE."
1975 ;;(message "hfy-relstub");;DBUG
1976 (let ((c ""))
1977 (while (setq start (string-match "/" file start))
1978 (setq start (1+ start)) (setq c (concat c "../")))
1979 c))
1980
1981 (defun hfy-href-stub (this-file def-files tag)
1982 "Return an href stub for a tag href in THIS-FILE.
1983 If DEF-FILES (list of files containing definitions for the tag in question)
1984 contains only one entry, the href should link straight to that file.
1985 Otherwise, the link should be to the index file.\n
1986 We are not yet concerned with the file extensions/tag line number and so on at
1987 this point.\n
1988 If `hfy-split-index' is set, and the href wil be to an index file rather than
1989 a source file, append a .X to `hfy-index-file', where X is the uppercased
1990 first character of TAG.\n
1991 See also `hfy-relstub', `hfy-index-file'."
1992 ;;(message "hfy-href-stub");;DBUG
1993 ;; FIXME: Why not use something like
1994 ;; (file-relative-name (if ...) (file-name-directory this-file)) ? --Stef
1995 (concat
1996 (hfy-relstub this-file)
1997 (if (= 1 (length def-files)) (car def-files)
1998 (if (not hfy-split-index) hfy-index-file
1999 (concat hfy-index-file "." (upcase (substring tag 0 1)))))) )
2000
2001 (defun hfy-href (this-file def-files tag tag-map)
2002 "Return a relative href to the tag in question, based on\n
2003 THIS-FILE `hfy-link-extn' `hfy-extn' DEF-FILES TAG and TAG-MAP\n
2004 THIS-FILE is the current source file
2005 DEF-FILES is a list of file containing possible link endpoints for TAG
2006 TAG is the tag in question
2007 TAG-MAP is the entry in `hfy-tags-cache'."
2008 ;;(message "hfy-href");;DBUG
2009 (concat
2010 (hfy-href-stub this-file def-files tag)
2011 (or hfy-link-extn hfy-extn) "#" tag ;;(.src -> .html)
2012 (if (= 1 (length def-files))
2013 (concat "." (format "%d" (cadr (assoc (car def-files) tag-map)))))) )
2014
2015 (defun hfy-word-regex (string)
2016 "Return a regex that matches STRING as the first `match-string', with non
2017 word characters on either side."
2018 ;; FIXME: Should this use [^$[:alnum:]_] instead? --Stef
2019 (concat "[^$A-Za-z_0-9]\\(" (regexp-quote string) "\\)[^A-Za-z_0-9]"))
2020
2021 ;; mark all tags for hyperlinking, except the tags at
2022 ;; their own points of definition, iyswim:
2023 (defun hfy-mark-tag-hrefs (srcdir file)
2024 "Mark href start points with the `hfy-link' prop (value: href string).\n
2025 Mark href end points with the `hfy-endl' prop (value t).\n
2026 Avoid overlapping links, and mark links in descending length of
2027 tag name in order to prevent subtags from usurping supertags,
2028 \(eg \"term\" for \"terminal\").
2029 SRCDIR is the directory being \"published\".
2030 FILE is the specific file we are rendering."
2031 ;;(message "hfy-mark-tag-hrefs");;DBUG
2032 (let ((cache-entry (assoc srcdir hfy-tags-cache))
2033 (list-cache (assoc srcdir hfy-tags-sortl))
2034 (rmap-cache (assoc srcdir hfy-tags-rmap ))
2035 (no-comment (hfy-opt 'zap-comment-links))
2036 (no-strings (hfy-opt 'zap-string-links ))
2037 (cache-hash nil)
2038 (tags-list nil)
2039 (tags-rmap nil)
2040 (case-fold-search nil))
2041 ;; extract the tag mapping hashes (fwd and rev) and the tag list:
2042 (if (and (setq cache-hash (cadr cache-entry))
2043 (setq tags-rmap (cadr rmap-cache ))
2044 (setq tags-list (cadr list-cache )))
2045 (mapcar
2046 (lambda (TAG)
2047 (let* ((start nil)
2048 (stop nil)
2049 (href nil)
2050 (name nil)
2051 (case-fold-search nil)
2052 (tmp-point nil)
2053 (maybe-start nil)
2054 (face-at nil)
2055 (rmap-entry nil)
2056 (rnew-elt nil)
2057 (rmap-line nil)
2058 (tag-regex (hfy-word-regex TAG))
2059 (tag-map (gethash TAG cache-hash))
2060 (tag-files (mapcar #'car tag-map)))
2061 ;; find instances of TAG and do what needs to be done:
2062 (goto-char (point-min))
2063 (while (search-forward TAG nil 'NOERROR)
2064 (setq tmp-point (point)
2065 maybe-start (- (match-beginning 0) 1))
2066 (goto-char maybe-start)
2067 (if (not (looking-at tag-regex))
2068 nil
2069 (setq start (match-beginning 1))
2070 (setq stop (match-end 1))
2071 (setq face-at
2072 (and (or no-comment no-strings) (hfy-face-at start)))
2073 (if (listp face-at)
2074 (setq face-at (cadr (memq :inherit face-at))))
2075 (if (or (text-property-any start (1+ stop) 'hfy-linkp t)
2076 (and no-comment (eq 'font-lock-comment-face face-at))
2077 (and no-strings (eq 'font-lock-string-face face-at)))
2078 nil ;; already a link, NOOP
2079
2080 ;; set a reverse map entry:
2081 (setq rmap-line (line-number-at-pos)
2082 rmap-entry (gethash TAG tags-rmap)
2083 rnew-elt (list file rmap-line start)
2084 rmap-entry (cons rnew-elt rmap-entry)
2085 name (format "%s.%d" TAG rmap-line))
2086 (put-text-property start (1+ start) 'hfy-inst name)
2087 (puthash TAG rmap-entry tags-rmap)
2088
2089 ;; mark the link. link to index if the tag has > 1 def
2090 ;; add the line number to the #name if it does not:
2091 (setq href (hfy-href file tag-files TAG tag-map))
2092 (put-text-property start (1+ start) 'hfy-link href)
2093 (put-text-property stop (1+ stop ) 'hfy-endl t )
2094 (put-text-property start (1+ stop ) 'hfy-linkp t )))
2095 (goto-char tmp-point)) ))
2096 tags-list) )))
2097
2098 (defun hfy-shell ()
2099 "Return `shell-file-name', or \"/bin/sh\" if it is a non-Bourne shell."
2100 (if (string-match "\\<bash\\>\\|\\<sh\\>\\|\\<dash\\>" shell-file-name)
2101 shell-file-name
2102 (or hfy-shell-file-name "/bin/sh")))
2103
2104 ;; cache the #(tag => file line point) entries for files under srcdir
2105 ;; and cache the descending sorted list of tags in the relevant alist,
2106 ;; also keyed by srcdir:
2107 (defun hfy-load-tags-cache (srcdir)
2108 "Run `hfy-etags-cmd' on SRCDIR, then call `hfy-parse-tags-buffer'."
2109 ;;(message "hfy-load-tags-cache");;DBUG
2110 (let ((etags-buffer (get-buffer-create "*hfy-tags*"))
2111 (etags-command (format hfy-etags-cmd hfy-etags-bin))
2112 (shell-file-name (hfy-shell)))
2113 (cd srcdir)
2114 (shell-command etags-command etags-buffer)
2115 (hfy-parse-tags-buffer srcdir etags-buffer)) )
2116
2117 ;; break this out from `hfy-load-tags-cache' to make the tar file
2118 ;; functionality easier to implement.
2119 ;; ( tar file functionality not merged here because it requires a
2120 ;; hacked copy of etags capable of tagging stdin: if Francesco
2121 ;; Potortì accepts a patch, or otherwise implements stdin tagging,
2122 ;; then I will provide a `htmlfontify-tar-file' defun )
2123 (defun hfy-parse-tags-buffer (srcdir buffer)
2124 "Parse a BUFFER containing etags formatted output, loading the
2125 `hfy-tags-cache' and `hfy-tags-sortl' entries for SRCDIR."
2126 (let ((cache-entry (assoc srcdir hfy-tags-cache))
2127 (tlist-cache (assoc srcdir hfy-tags-sortl))
2128 (trmap-cache (assoc srcdir hfy-tags-rmap ))
2129 (cache-hash nil) (trmap-hash nil) (tags-list nil)
2130 (hash-entry nil) (tag-string nil) (tag-line nil)
2131 (tag-point nil) (new-entry nil) (etags-file nil))
2132
2133 ;; (re)initialize the tag reverse map:
2134 (if trmap-cache (setq trmap-hash (cadr trmap-cache))
2135 (setq trmap-hash (make-hash-table :test 'equal))
2136 (setq hfy-tags-rmap (list (list srcdir trmap-hash) hfy-tags-rmap)))
2137 (clrhash trmap-hash)
2138
2139 ;; (re)initialize the tag cache:
2140 (if cache-entry (setq cache-hash (cadr cache-entry))
2141 (setq cache-hash (make-hash-table :test 'equal))
2142 (setq hfy-tags-cache (list (list srcdir cache-hash) hfy-tags-cache)))
2143 (clrhash cache-hash)
2144
2145 ;; cache the TAG => ((file line point) (file line point) ... ) entries:
2146 (with-current-buffer buffer
2147 (goto-char (point-min))
2148
2149 (while (and (looking-at "^\x0c") (= 0 (forward-line 1)))
2150 ;;(message "^L boundary")
2151 (if (and (looking-at "^\\(.+\\),\\([0-9]+\\)$")
2152 (= 0 (forward-line 1)))
2153 (progn
2154 (setq etags-file (match-string 1))
2155 ;;(message "TAGS for file: %s" etags-file)
2156 (while (and (looking-at hfy-etag-regex) (= 0 (forward-line 1)))
2157 (setq tag-string (match-string 1))
2158 (if (= 0 (length tag-string)) nil ;; noop
2159 (setq tag-line (round (string-to-number (match-string 2))))
2160 (setq tag-point (round (string-to-number (match-string 3))))
2161 (setq hash-entry (gethash tag-string cache-hash))
2162 (setq new-entry (list etags-file tag-line tag-point))
2163 (push new-entry hash-entry)
2164 ;;(message "HASH-ENTRY %s %S" tag-string new-entry)
2165 (puthash tag-string hash-entry cache-hash)))) )))
2166
2167 ;; cache a list of tags in descending length order:
2168 (maphash (lambda (K _V) (push K tags-list)) cache-hash)
2169 (setq tags-list (sort tags-list (lambda (A B) (< (length B) (length A)))))
2170
2171 ;; put the tag list into the cache:
2172 (if tlist-cache (setcar (cdr tlist-cache) tags-list)
2173 (push (list srcdir tags-list) hfy-tags-sortl))
2174
2175 ;; return the number of tags found:
2176 (length tags-list) ))
2177
2178 (defun hfy-prepare-index-i (srcdir dstdir filename &optional stub map)
2179 "Prepare a tags index buffer for SRCDIR.
2180 `hfy-tags-cache' must already have an entry for SRCDIR for this to work.
2181 `hfy-page-header', `hfy-page-footer', `hfy-link-extn' and `hfy-extn'
2182 all play a part here.\n
2183 If STUB is set, prepare an (appropriately named) index buffer
2184 specifically for entries beginning with STUB.\n
2185 If MAP is set, use that instead of `hfy-tags-cache'.
2186 FILENAME is the name of the file being indexed.
2187 DSTDIR is the output directory, where files will be written."
2188 ;;(message "hfy-write-index");;DBUG
2189 (let ((cache-entry (assoc srcdir (or map hfy-tags-cache)))
2190 (cache-hash nil)
2191 (tag-list nil)
2192 (index-file
2193 (concat filename (if stub (concat "." stub) "") hfy-extn))
2194 (index-buf nil))
2195 (if (not (and cache-entry
2196 (setq cache-hash (cadr cache-entry))
2197 (setq index-buf (get-buffer-create index-file))))
2198 nil ;; noop
2199 (maphash (lambda (K _V) (push K tag-list)) cache-hash)
2200 (setq tag-list (sort tag-list 'string<))
2201 (set-buffer index-buf)
2202 (erase-buffer)
2203 (insert (funcall hfy-page-header filename "<!-- CSS -->"))
2204 (insert "<table class=\"index\">\n")
2205
2206 (dolist (TAG tag-list)
2207 (let ((tag-started nil))
2208 (dolist (DEF (gethash TAG cache-hash))
2209 (if (and stub (not (string-match (concat "^" stub) TAG)))
2210 nil ;; we have a stub and it didn't match: NOOP
2211 (let ((file (car DEF))
2212 (line (cadr DEF)))
2213 (insert
2214 (format
2215 (concat
2216 " <tr> \n"
2217 " <td>%s</td> \n"
2218 " <td><a href=\"%s%s\">%s</a></td> \n"
2219 " <td><a href=\"%s%s#%s.%d\">%d</a></td>\n"
2220 " </tr> \n")
2221 (if (string= TAG tag-started) "&nbsp;"
2222 (format "<a name=\"%s\">%s</a>" TAG TAG))
2223 file (or hfy-link-extn hfy-extn) file
2224 file (or hfy-link-extn hfy-extn) TAG line line))
2225 (setq tag-started TAG))))))
2226 (insert "</table>\n")
2227 (insert (funcall hfy-page-footer filename))
2228 (and dstdir (cd dstdir))
2229 (set-visited-file-name index-file)
2230 index-buf) ))
2231
2232 (defun hfy-prepare-index (srcdir dstdir)
2233 "Return a list of index buffer(s), as determined by `hfy-split-index'.
2234 SRCDIR and DSTDIR are the source and output directories respectively."
2235 (if (not hfy-split-index)
2236 (list (hfy-prepare-index-i srcdir dstdir hfy-index-file nil))
2237 (let ((stub-list nil)
2238 (cache-hash nil)
2239 (index-list nil)
2240 (cache-entry (assoc srcdir hfy-tags-cache)))
2241 (if (and cache-entry (setq cache-hash (cadr cache-entry)))
2242 (maphash
2243 (lambda (K _V)
2244 (let ((stub (upcase (substring K 0 1))))
2245 (if (member stub stub-list)
2246 nil ;; seen this already: NOOP
2247 (setq
2248 stub-list (cons stub stub-list)
2249 index-list (cons (hfy-prepare-index-i srcdir
2250 dstdir
2251 hfy-index-file
2252 stub)
2253 index-list)) )))
2254 cache-hash) )
2255 index-list)))
2256
2257 (defun hfy-prepare-tag-map (srcdir dstdir)
2258 "Prepare the counterpart(s) to the index buffer(s) - a list of buffers
2259 with the same structure, but listing (and linking to) instances of tags
2260 \(as opposed to their definitions).\n
2261 SRCDIR and DSTDIR are the source and output directories respectively.
2262 See also `hfy-prepare-index', `hfy-split-index'."
2263 (if (not hfy-split-index)
2264 (list (hfy-prepare-index-i srcdir
2265 dstdir
2266 hfy-instance-file
2267 nil
2268 hfy-tags-rmap))
2269 (let ((stub-list nil)
2270 (cache-hash nil)
2271 (index-list nil)
2272 (cache-entry (assoc srcdir hfy-tags-rmap)))
2273
2274 (if (and cache-entry (setq cache-hash (cadr cache-entry)))
2275 (maphash
2276 (lambda (K _V)
2277 (let ((stub (upcase (substring K 0 1))))
2278 (if (member stub stub-list)
2279 nil ;; seen this already: NOOP
2280 (setq
2281 stub-list (cons stub stub-list)
2282 index-list (cons (hfy-prepare-index-i srcdir
2283 dstdir
2284 hfy-instance-file
2285 stub
2286 hfy-tags-rmap)
2287 index-list)) )))
2288 cache-hash) )
2289 index-list)))
2290
2291 (defun hfy-subtract-maps (srcdir)
2292 "Internal function - strips definitions of tags from the instance map.
2293 SRCDIR is the directory being \"published\".
2294 See also `hfy-tags-cache', `hfy-tags-rmap'."
2295 (let ((new-list nil)
2296 (old-list nil)
2297 (def-list nil)
2298 (exc-list nil)
2299 (fwd-map (cadr (assoc srcdir hfy-tags-cache)))
2300 (rev-map (cadr (assoc srcdir hfy-tags-rmap )))
2301 (taglist (cadr (assoc srcdir hfy-tags-sortl))))
2302 (dolist (TAG taglist)
2303 (setq def-list (gethash TAG fwd-map)
2304 old-list (gethash TAG rev-map)
2305 exc-list (mapcar (lambda (P) (list (car P) (cadr P))) def-list)
2306 new-list nil)
2307 (dolist (P old-list)
2308 (or (member (list (car P) (cadr P)) exc-list)
2309 (push P new-list)))
2310 (puthash TAG new-list rev-map))))
2311
2312 (defun htmlfontify-run-etags (srcdir)
2313 "Load the etags cache for SRCDIR.
2314 See also `hfy-load-tags-cache'."
2315 (interactive "D source directory: ")
2316 (hfy-load-tags-cache (directory-file-name srcdir)))
2317
2318 ;;(defun hfy-test-read-args (foo bar)
2319 ;; (interactive "D source directory: \nD target directory: ")
2320 ;; (message "foo: %S\nbar: %S" foo bar))
2321
2322 (defun hfy-save-kill-buffers (buffer-list &optional dstdir)
2323 (dolist (B buffer-list)
2324 (set-buffer B)
2325 (and dstdir (file-directory-p dstdir) (cd dstdir))
2326 (save-buffer)
2327 (kill-buffer B)))
2328
2329 ;;;###autoload
2330 (defun htmlfontify-copy-and-link-dir (srcdir dstdir &optional f-ext l-ext)
2331 "Trawl SRCDIR and write fontified-and-hyperlinked output in DSTDIR.
2332 F-EXT and L-EXT specify values for `hfy-extn' and `hfy-link-extn'.\n
2333 You may also want to set `hfy-page-header' and `hfy-page-footer'."
2334 (interactive "D source directory: \nD output directory: ")
2335 ;;(message "htmlfontify-copy-and-link-dir")
2336 (setq srcdir (directory-file-name srcdir))
2337 (setq dstdir (directory-file-name dstdir))
2338 (let ((source-files "SETME: list of source files, relative to srcdir")
2339 (tr-cache (assoc srcdir hfy-tags-rmap))
2340 (hfy-extn (or f-ext ".html"))
2341 (hfy-link-extn (or l-ext ".html")))
2342 ;; oops, forgot to load etags for srcdir:
2343 (if tr-cache nil
2344 (message "autoload of tags cache")
2345 (hfy-load-tags-cache srcdir)
2346 (setq tr-cache (assoc srcdir hfy-tags-rmap)))
2347 ;; clear out the old cache:
2348 (clrhash (cadr tr-cache))
2349 (hfy-make-directory dstdir)
2350 (setq source-files (hfy-list-files srcdir))
2351 (dolist (file source-files)
2352 (hfy-copy-and-fontify-file srcdir dstdir file))
2353 (hfy-subtract-maps srcdir)
2354 (hfy-save-kill-buffers (hfy-prepare-index srcdir dstdir) dstdir)
2355 (hfy-save-kill-buffers (hfy-prepare-tag-map srcdir dstdir) dstdir) ))
2356
2357 ;; name of the init file we want:
2358 (defun hfy-initfile ()
2359 "Return the expected location of the htmlfontify specific init/custom file."
2360 (let* ((file (or (getenv "HFY_INITFILE") ".hfy.el")))
2361 (expand-file-name file "~") ))
2362
2363
2364 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2365 ;; incomplete as yet : transfer hook settings to hfy init file:
2366 ;; (defalias 'hfy-set-hooks 'custom-set-variables)
2367
2368 ;; (defun hfy-pp-hook (H)
2369 ;; (and (string-match "-hook\\'" (symbol-name H))
2370 ;; (boundp H)
2371 ;; (symbol-value H)
2372 ;; (insert (format "\n '(%S %S)" H (symbol-value H)))
2373 ;; )
2374 ;; )
2375
2376 ;; (defun hfy-save-hooks ()
2377 ;; (let ((custom-file (hfy-initfile)))
2378 ;; (custom-save-delete 'hfy-set-hooks)
2379 ;; (let ((standard-output (current-buffer)))
2380 ;; (princ "(hfy-set-hooks\n;;auto-generated, only one copy allowed\n")
2381 ;; (mapatoms 'hfy-pp-hook)
2382 ;; (insert "\n)")
2383 ;; )
2384 ;; )
2385 ;; )
2386 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2387
2388 (defalias 'hfy-init-progn 'progn)
2389
2390 (defun hfy-save-initvar (sym)
2391 (princ (format "(setq %s\n '" sym))
2392 (pp (symbol-value sym))
2393 (princ ")\n"))
2394
2395 (defun htmlfontify-save-initfile ()
2396 "Save the htmlfontify settings to the htmlfontify init file."
2397 (interactive)
2398 (let* ((start-pos nil)
2399 (custom-file (hfy-initfile))
2400 (standard-output (find-file-noselect custom-file 'nowarn)))
2401 (save-excursion
2402 (custom-save-delete 'hfy-init-progn)
2403 (setq start-pos (point))
2404 (princ "(hfy-init-progn\n;;auto-generated, only one copy allowed\n")
2405 ;; FIXME: This saving&restoring of global customization
2406 ;; variables can interfere with other customization settings for
2407 ;; those vars (in .emacs or in Customize).
2408 (mapc 'hfy-save-initvar
2409 '(auto-mode-alist interpreter-mode-alist))
2410 (princ ")\n")
2411 (indent-region start-pos (point) nil))
2412 (custom-save-all) ))
2413
2414 (defun htmlfontify-load-initfile ()
2415 "Load the htmlfontify specific init/custom file."
2416 (interactive)
2417 (let ((file (hfy-initfile)))
2418 (load file 'NOERROR nil nil) ))
2419
2420 \f
2421 ;;;### (autoloads nil "hfy-cmap" "hfy-cmap.el" "e644ddae915ddb98c9b2f16ffa5a74b2")
2422 ;;; Generated autoloads from hfy-cmap.el
2423
2424 (autoload 'htmlfontify-load-rgb-file "hfy-cmap" "\
2425 Load an X11 style rgb.txt FILE.
2426 Search `hfy-rgb-load-path' if FILE is not specified.
2427 Loads the variable `hfy-rgb-txt-colour-map', which is used by
2428 `hfy-fallback-colour-values'.
2429
2430 \(fn &optional FILE)" t nil)
2431
2432 (autoload 'hfy-fallback-colour-values "hfy-cmap" "\
2433 Use a fallback method for obtaining the rgb values for a color.
2434
2435 \(fn COLOUR-STRING)" nil nil)
2436
2437 ;;;***
2438 \f
2439
2440 (provide 'htmlfontify)
2441
2442 ;;; htmlfontify.el ends here