comparison lisp/htmlfontify.el @ 106126:10d66efa4c61

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