aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Monnier2009-11-19 20:21:01 +0000
committerStefan Monnier2009-11-19 20:21:01 +0000
commitacca02b053a103a93668d1d79fd0bcdc9a557aea (patch)
tree06700368a09088d27e8ddb40bacce8695f676311
parent042b7cc622ea041e7c06e9e467110b7a8f6e5f50 (diff)
downloademacs-acca02b053a103a93668d1d79fd0bcdc9a557aea.tar.gz
emacs-acca02b053a103a93668d1d79fd0bcdc9a557aea.zip
New files.
Diffstat
-rw-r--r--lisp/ChangeLog8
-rw-r--r--lisp/hfy-cmap.el854
-rw-r--r--lisp/htmlfontify.el2374
3 files changed, 3234 insertions, 2 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 741a72dd6e6..ede4c72f6a4 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,7 @@
12009-11-19 Vivek Dasmohapatra <vivek@etla.org>
2
3 * htmlfontify.el, hfy-cmap.el: New files.
4
12009-11-19 Juri Linkov <juri@jurta.org> 52009-11-19 Juri Linkov <juri@jurta.org>
2 6
3 * minibuffer.el (completions-format): New defcustom. 7 * minibuffer.el (completions-format): New defcustom.
@@ -25,8 +29,8 @@
25 29
262009-11-19 Michael Albinus <michael.albinus@gmx.de> 302009-11-19 Michael Albinus <michael.albinus@gmx.de>
27 31
28 * net/tramp.el (tramp-do-copy-or-rename-file-out-of-band): Set 32 * net/tramp.el (tramp-do-copy-or-rename-file-out-of-band):
29 variables for computing the prompt for reading password. 33 Set variables for computing the prompt for reading password.
30 34
312009-11-19 Glenn Morris <rgm@gnu.org> 352009-11-19 Glenn Morris <rgm@gnu.org>
32 36
diff --git a/lisp/hfy-cmap.el b/lisp/hfy-cmap.el
new file mode 100644
index 00000000000..62d09899611
--- /dev/null
+++ b/lisp/hfy-cmap.el
@@ -0,0 +1,854 @@
1;;; hfy-cmap.el --- Fallback colour name -> rgb mapping for `htmlfontify'
2
3;; Copyright (C) 2002, 2003, 2009 Free Software Foundation, Inc.
4
5;; Emacs Lisp Archive Entry
6;; Package: htmlfontify
7;; Filename: hfy-cmap.el
8;; Version: 0.20
9;; Keywords: colour, rgb
10;; Author: Vivek Dasmohapatra <vivek@etla.org>
11;; Maintainer: Vivek Dasmohapatra <vivek@etla.org>
12;; Created: 2002-01-20
13;; Description: fallback code for colour name -> rgb mapping
14;; URL: http://rtfm.etla.org/emacs/htmlfontify/
15;; Last-Updated: Sat 2003-02-15 03:49:32 +0000
16
17;; This file is part of GNU Emacs.
18
19;; GNU Emacs is free software: you can redistribute it and/or modify
20;; it under the terms of the GNU General Public License as published by
21;; the Free Software Foundation, either version 3 of the License, or
22;; (at your option) any later version.
23
24;; GNU Emacs is distributed in the hope that it will be useful,
25;; but WITHOUT ANY WARRANTY; without even the implied warranty of
26;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
27;; GNU General Public License for more details.
28
29;; You should have received a copy of the GNU General Public License
30;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
31
32;;; Commentary:
33
34;;; Code:
35
36(defconst hfy-fallback-colour-map
37 '(("snow" 65535 64250 64250)
38 ("ghost white" 63736 63736 65535)
39 ("GhostWhite" 63736 63736 65535)
40 ("white smoke" 62965 62965 62965)
41 ("WhiteSmoke" 62965 62965 62965)
42 ("gainsboro" 56540 56540 56540)
43 ("floral white" 65535 64250 61680)
44 ("FloralWhite" 65535 64250 61680)
45 ("old lace" 65021 62965 59110)
46 ("OldLace" 65021 62965 59110)
47 ("linen" 64250 61680 59110)
48 ("antique white" 64250 60395 55255)
49 ("AntiqueWhite" 64250 60395 55255)
50 ("papaya whip" 65535 61423 54741)
51 ("PapayaWhip" 65535 61423 54741)
52 ("blanched almond" 65535 60395 52685)
53 ("BlanchedAlmond" 65535 60395 52685)
54 ("bisque" 65535 58596 50372)
55 ("peach puff" 65535 56026 47545)
56 ("PeachPuff" 65535 56026 47545)
57 ("navajo white" 65535 57054 44461)
58 ("NavajoWhite" 65535 57054 44461)
59 ("moccasin" 65535 58596 46517)
60 ("cornsilk" 65535 63736 56540)
61 ("ivory" 65535 65535 61680)
62 ("lemon chiffon" 65535 64250 52685)
63 ("LemonChiffon" 65535 64250 52685)
64 ("seashell" 65535 62965 61166)
65 ("honeydew" 61680 65535 61680)
66 ("mint cream" 62965 65535 64250)
67 ("MintCream" 62965 65535 64250)
68 ("azure" 61680 65535 65535)
69 ("alice blue" 61680 63736 65535)
70 ("AliceBlue" 61680 63736 65535)
71 ("lavender" 59110 59110 64250)
72 ("lavender blush" 65535 61680 62965)
73 ("LavenderBlush" 65535 61680 62965)
74 ("misty rose" 65535 58596 57825)
75 ("MistyRose" 65535 58596 57825)
76 ("white" 65535 65535 65535)
77 ("black" 0 0 0)
78 ("dark slate gray" 12079 20303 20303)
79 ("DarkSlateGray" 12079 20303 20303)
80 ("dark slate grey" 12079 20303 20303)
81 ("DarkSlateGrey" 12079 20303 20303)
82 ("dim gray" 26985 26985 26985)
83 ("DimGray" 26985 26985 26985)
84 ("dim grey" 26985 26985 26985)
85 ("DimGrey" 26985 26985 26985)
86 ("slate gray" 28784 32896 37008)
87 ("SlateGray" 28784 32896 37008)
88 ("slate grey" 28784 32896 37008)
89 ("SlateGrey" 28784 32896 37008)
90 ("light slate gray" 30583 34952 39321)
91 ("LightSlateGray" 30583 34952 39321)
92 ("light slate grey" 30583 34952 39321)
93 ("LightSlateGrey" 30583 34952 39321)
94 ("gray" 48830 48830 48830)
95 ("grey" 48830 48830 48830)
96 ("light grey" 54227 54227 54227)
97 ("LightGrey" 54227 54227 54227)
98 ("light gray" 54227 54227 54227)
99 ("LightGray" 54227 54227 54227)
100 ("midnight blue" 6425 6425 28784)
101 ("MidnightBlue" 6425 6425 28784)
102 ("navy" 0 0 32896)
103 ("navy blue" 0 0 32896)
104 ("NavyBlue" 0 0 32896)
105 ("cornflower blue" 25700 38293 60909)
106 ("CornflowerBlue" 25700 38293 60909)
107 ("dark slate blue" 18504 15677 35723)
108 ("DarkSlateBlue" 18504 15677 35723)
109 ("slate blue" 27242 23130 52685)
110 ("SlateBlue" 27242 23130 52685)
111 ("medium slate blue" 31611 26728 61166)
112 ("MediumSlateBlue" 31611 26728 61166)
113 ("light slate blue" 33924 28784 65535)
114 ("LightSlateBlue" 33924 28784 65535)
115 ("medium blue" 0 0 52685)
116 ("MediumBlue" 0 0 52685)
117 ("royal blue" 16705 26985 57825)
118 ("RoyalBlue" 16705 26985 57825)
119 ("blue" 0 0 65535)
120 ("dodger blue" 7710 37008 65535)
121 ("DodgerBlue" 7710 37008 65535)
122 ("deep sky blue" 0 49087 65535)
123 ("DeepSkyBlue" 0 49087 65535)
124 ("sky blue" 34695 52942 60395)
125 ("SkyBlue" 34695 52942 60395)
126 ("light sky blue" 34695 52942 64250)
127 ("LightSkyBlue" 34695 52942 64250)
128 ("steel blue" 17990 33410 46260)
129 ("SteelBlue" 17990 33410 46260)
130 ("light steel blue" 45232 50372 57054)
131 ("LightSteelBlue" 45232 50372 57054)
132 ("light blue" 44461 55512 59110)
133 ("LightBlue" 44461 55512 59110)
134 ("powder blue" 45232 57568 59110)
135 ("PowderBlue" 45232 57568 59110)
136 ("pale turquoise" 44975 61166 61166)
137 ("PaleTurquoise" 44975 61166 61166)
138 ("dark turquoise" 0 52942 53713)
139 ("DarkTurquoise" 0 52942 53713)
140 ("medium turquoise" 18504 53713 52428)
141 ("MediumTurquoise" 18504 53713 52428)
142 ("turquoise" 16448 57568 53456)
143 ("cyan" 0 65535 65535)
144 ("light cyan" 57568 65535 65535)
145 ("LightCyan" 57568 65535 65535)
146 ("cadet blue" 24415 40606 41120)
147 ("CadetBlue" 24415 40606 41120)
148 ("medium aquamarine" 26214 52685 43690)
149 ("MediumAquamarine" 26214 52685 43690)
150 ("aquamarine" 32639 65535 54484)
151 ("dark green" 0 25700 0)
152 ("DarkGreen" 0 25700 0)
153 ("dark olive green" 21845 27499 12079)
154 ("DarkOliveGreen" 21845 27499 12079)
155 ("dark sea green" 36751 48316 36751)
156 ("DarkSeaGreen" 36751 48316 36751)
157 ("sea green" 11822 35723 22359)
158 ("SeaGreen" 11822 35723 22359)
159 ("medium sea green" 15420 46003 29041)
160 ("MediumSeaGreen" 15420 46003 29041)
161 ("light sea green" 8224 45746 43690)
162 ("LightSeaGreen" 8224 45746 43690)
163 ("pale green" 39064 64507 39064)
164 ("PaleGreen" 39064 64507 39064)
165 ("spring green" 0 65535 32639)
166 ("SpringGreen" 0 65535 32639)
167 ("lawn green" 31868 64764 0)
168 ("LawnGreen" 31868 64764 0)
169 ("green" 0 65535 0)
170 ("chartreuse" 32639 65535 0)
171 ("medium spring green" 0 64250 39578)
172 ("MediumSpringGreen" 0 64250 39578)
173 ("green yellow" 44461 65535 12079)
174 ("GreenYellow" 44461 65535 12079)
175 ("lime green" 12850 52685 12850)
176 ("LimeGreen" 12850 52685 12850)
177 ("yellow green" 39578 52685 12850)
178 ("YellowGreen" 39578 52685 12850)
179 ("forest green" 8738 35723 8738)
180 ("ForestGreen" 8738 35723 8738)
181 ("olive drab" 27499 36494 8995)
182 ("OliveDrab" 27499 36494 8995)
183 ("dark khaki" 48573 47031 27499)
184 ("DarkKhaki" 48573 47031 27499)
185 ("khaki" 61680 59110 35980)
186 ("pale goldenrod" 61166 59624 43690)
187 ("PaleGoldenrod" 61166 59624 43690)
188 ("light goldenrod yellow" 64250 64250 53970)
189 ("LightGoldenrodYellow" 64250 64250 53970)
190 ("light yellow" 65535 65535 57568)
191 ("LightYellow" 65535 65535 57568)
192 ("yellow" 65535 65535 0)
193 ("gold" 65535 55255 0)
194 ("light goldenrod" 61166 56797 33410)
195 ("LightGoldenrod" 61166 56797 33410)
196 ("goldenrod" 56026 42405 8224)
197 ("dark goldenrod" 47288 34438 2827)
198 ("DarkGoldenrod" 47288 34438 2827)
199 ("rosy brown" 48316 36751 36751)
200 ("RosyBrown" 48316 36751 36751)
201 ("indian red" 52685 23644 23644)
202 ("IndianRed" 52685 23644 23644)
203 ("saddle brown" 35723 17733 4883)
204 ("SaddleBrown" 35723 17733 4883)
205 ("sienna" 41120 21074 11565)
206 ("peru" 52685 34181 16191)
207 ("burlywood" 57054 47288 34695)
208 ("beige" 62965 62965 56540)
209 ("wheat" 62965 57054 46003)
210 ("sandy brown" 62708 42148 24672)
211 ("SandyBrown" 62708 42148 24672)
212 ("tan" 53970 46260 35980)
213 ("chocolate" 53970 26985 7710)
214 ("firebrick" 45746 8738 8738)
215 ("brown" 42405 10794 10794)
216 ("dark salmon" 59881 38550 31354)
217 ("DarkSalmon" 59881 38550 31354)
218 ("salmon" 64250 32896 29298)
219 ("light salmon" 65535 41120 31354)
220 ("LightSalmon" 65535 41120 31354)
221 ("orange" 65535 42405 0)
222 ("dark orange" 65535 35980 0)
223 ("DarkOrange" 65535 35980 0)
224 ("coral" 65535 32639 20560)
225 ("light coral" 61680 32896 32896)
226 ("LightCoral" 61680 32896 32896)
227 ("tomato" 65535 25443 18247)
228 ("orange red" 65535 17733 0)
229 ("OrangeRed" 65535 17733 0)
230 ("red" 65535 0 0)
231 ("hot pink" 65535 26985 46260)
232 ("HotPink" 65535 26985 46260)
233 ("deep pink" 65535 5140 37779)
234 ("DeepPink" 65535 5140 37779)
235 ("pink" 65535 49344 52171)
236 ("light pink" 65535 46774 49601)
237 ("LightPink" 65535 46774 49601)
238 ("pale violet red" 56283 28784 37779)
239 ("PaleVioletRed" 56283 28784 37779)
240 ("maroon" 45232 12336 24672)
241 ("medium violet red" 51143 5397 34181)
242 ("MediumVioletRed" 51143 5397 34181)
243 ("violet red" 53456 8224 37008)
244 ("VioletRed" 53456 8224 37008)
245 ("magenta" 65535 0 65535)
246 ("violet" 61166 33410 61166)
247 ("plum" 56797 41120 56797)
248 ("orchid" 56026 28784 54998)
249 ("medium orchid" 47802 21845 54227)
250 ("MediumOrchid" 47802 21845 54227)
251 ("dark orchid" 39321 12850 52428)
252 ("DarkOrchid" 39321 12850 52428)
253 ("dark violet" 38036 0 54227)
254 ("DarkViolet" 38036 0 54227)
255 ("blue violet" 35466 11051 58082)
256 ("BlueViolet" 35466 11051 58082)
257 ("purple" 41120 8224 61680)
258 ("medium purple" 37779 28784 56283)
259 ("MediumPurple" 37779 28784 56283)
260 ("thistle" 55512 49087 55512)
261 ("snow1" 65535 64250 64250)
262 ("snow2" 61166 59881 59881)
263 ("snow3" 52685 51657 51657)
264 ("snow4" 35723 35209 35209)
265 ("seashell1" 65535 62965 61166)
266 ("seashell2" 61166 58853 57054)
267 ("seashell3" 52685 50629 49087)
268 ("seashell4" 35723 34438 33410)
269 ("AntiqueWhite1" 65535 61423 56283)
270 ("AntiqueWhite2" 61166 57311 52428)
271 ("AntiqueWhite3" 52685 49344 45232)
272 ("AntiqueWhite4" 35723 33667 30840)
273 ("bisque1" 65535 58596 50372)
274 ("bisque2" 61166 54741 47031)
275 ("bisque3" 52685 47031 40606)
276 ("bisque4" 35723 32125 27499)
277 ("PeachPuff1" 65535 56026 47545)
278 ("PeachPuff2" 61166 52171 44461)
279 ("PeachPuff3" 52685 44975 38293)
280 ("PeachPuff4" 35723 30583 25957)
281 ("NavajoWhite1" 65535 57054 44461)
282 ("NavajoWhite2" 61166 53199 41377)
283 ("NavajoWhite3" 52685 46003 35723)
284 ("NavajoWhite4" 35723 31097 24158)
285 ("LemonChiffon1" 65535 64250 52685)
286 ("LemonChiffon2" 61166 59881 49087)
287 ("LemonChiffon3" 52685 51657 42405)
288 ("LemonChiffon4" 35723 35209 28784)
289 ("cornsilk1" 65535 63736 56540)
290 ("cornsilk2" 61166 59624 52685)
291 ("cornsilk3" 52685 51400 45489)
292 ("cornsilk4" 35723 34952 30840)
293 ("ivory1" 65535 65535 61680)
294 ("ivory2" 61166 61166 57568)
295 ("ivory3" 52685 52685 49601)
296 ("ivory4" 35723 35723 33667)
297 ("honeydew1" 61680 65535 61680)
298 ("honeydew2" 57568 61166 57568)
299 ("honeydew3" 49601 52685 49601)
300 ("honeydew4" 33667 35723 33667)
301 ("LavenderBlush1" 65535 61680 62965)
302 ("LavenderBlush2" 61166 57568 58853)
303 ("LavenderBlush3" 52685 49601 50629)
304 ("LavenderBlush4" 35723 33667 34438)
305 ("MistyRose1" 65535 58596 57825)
306 ("MistyRose2" 61166 54741 53970)
307 ("MistyRose3" 52685 47031 46517)
308 ("MistyRose4" 35723 32125 31611)
309 ("azure1" 61680 65535 65535)
310 ("azure2" 57568 61166 61166)
311 ("azure3" 49601 52685 52685)
312 ("azure4" 33667 35723 35723)
313 ("SlateBlue1" 33667 28527 65535)
314 ("SlateBlue2" 31354 26471 61166)
315 ("SlateBlue3" 26985 22873 52685)
316 ("SlateBlue4" 18247 15420 35723)
317 ("RoyalBlue1" 18504 30326 65535)
318 ("RoyalBlue2" 17219 28270 61166)
319 ("RoyalBlue3" 14906 24415 52685)
320 ("RoyalBlue4" 10023 16448 35723)
321 ("blue1" 0 0 65535)
322 ("blue2" 0 0 61166)
323 ("blue3" 0 0 52685)
324 ("blue4" 0 0 35723)
325 ("DodgerBlue1" 7710 37008 65535)
326 ("DodgerBlue2" 7196 34438 61166)
327 ("DodgerBlue3" 6168 29812 52685)
328 ("DodgerBlue4" 4112 20046 35723)
329 ("SteelBlue1" 25443 47288 65535)
330 ("SteelBlue2" 23644 44204 61166)
331 ("SteelBlue3" 20303 38036 52685)
332 ("SteelBlue4" 13878 25700 35723)
333 ("DeepSkyBlue1" 0 49087 65535)
334 ("DeepSkyBlue2" 0 45746 61166)
335 ("DeepSkyBlue3" 0 39578 52685)
336 ("DeepSkyBlue4" 0 26728 35723)
337 ("SkyBlue1" 34695 52942 65535)
338 ("SkyBlue2" 32382 49344 61166)
339 ("SkyBlue3" 27756 42662 52685)
340 ("SkyBlue4" 19018 28784 35723)
341 ("LightSkyBlue1" 45232 58082 65535)
342 ("LightSkyBlue2" 42148 54227 61166)
343 ("LightSkyBlue3" 36237 46774 52685)
344 ("LightSkyBlue4" 24672 31611 35723)
345 ("SlateGray1" 50886 58082 65535)
346 ("SlateGray2" 47545 54227 61166)
347 ("SlateGray3" 40863 46774 52685)
348 ("SlateGray4" 27756 31611 35723)
349 ("LightSteelBlue1" 51914 57825 65535)
350 ("LightSteelBlue2" 48316 53970 61166)
351 ("LightSteelBlue3" 41634 46517 52685)
352 ("LightSteelBlue4" 28270 31611 35723)
353 ("LightBlue1" 49087 61423 65535)
354 ("LightBlue2" 45746 57311 61166)
355 ("LightBlue3" 39578 49344 52685)
356 ("LightBlue4" 26728 33667 35723)
357 ("LightCyan1" 57568 65535 65535)
358 ("LightCyan2" 53713 61166 61166)
359 ("LightCyan3" 46260 52685 52685)
360 ("LightCyan4" 31354 35723 35723)
361 ("PaleTurquoise1" 48059 65535 65535)
362 ("PaleTurquoise2" 44718 61166 61166)
363 ("PaleTurquoise3" 38550 52685 52685)
364 ("PaleTurquoise4" 26214 35723 35723)
365 ("CadetBlue1" 39064 62965 65535)
366 ("CadetBlue2" 36494 58853 61166)
367 ("CadetBlue3" 31354 50629 52685)
368 ("CadetBlue4" 21331 34438 35723)
369 ("turquoise1" 0 62965 65535)
370 ("turquoise2" 0 58853 61166)
371 ("turquoise3" 0 50629 52685)
372 ("turquoise4" 0 34438 35723)
373 ("cyan1" 0 65535 65535)
374 ("cyan2" 0 61166 61166)
375 ("cyan3" 0 52685 52685)
376 ("cyan4" 0 35723 35723)
377 ("DarkSlateGray1" 38807 65535 65535)
378 ("DarkSlateGray2" 36237 61166 61166)
379 ("DarkSlateGray3" 31097 52685 52685)
380 ("DarkSlateGray4" 21074 35723 35723)
381 ("aquamarine1" 32639 65535 54484)
382 ("aquamarine2" 30326 61166 50886)
383 ("aquamarine3" 26214 52685 43690)
384 ("aquamarine4" 17733 35723 29812)
385 ("DarkSeaGreen1" 49601 65535 49601)
386 ("DarkSeaGreen2" 46260 61166 46260)
387 ("DarkSeaGreen3" 39835 52685 39835)
388 ("DarkSeaGreen4" 26985 35723 26985)
389 ("SeaGreen1" 21588 65535 40863)
390 ("SeaGreen2" 20046 61166 38036)
391 ("SeaGreen3" 17219 52685 32896)
392 ("SeaGreen4" 11822 35723 22359)
393 ("PaleGreen1" 39578 65535 39578)
394 ("PaleGreen2" 37008 61166 37008)
395 ("PaleGreen3" 31868 52685 31868)
396 ("PaleGreen4" 21588 35723 21588)
397 ("SpringGreen1" 0 65535 32639)
398 ("SpringGreen2" 0 61166 30326)
399 ("SpringGreen3" 0 52685 26214)
400 ("SpringGreen4" 0 35723 17733)
401 ("green1" 0 65535 0)
402 ("green2" 0 61166 0)
403 ("green3" 0 52685 0)
404 ("green4" 0 35723 0)
405 ("chartreuse1" 32639 65535 0)
406 ("chartreuse2" 30326 61166 0)
407 ("chartreuse3" 26214 52685 0)
408 ("chartreuse4" 17733 35723 0)
409 ("OliveDrab1" 49344 65535 15934)
410 ("OliveDrab2" 46003 61166 14906)
411 ("OliveDrab3" 39578 52685 12850)
412 ("OliveDrab4" 26985 35723 8738)
413 ("DarkOliveGreen1" 51914 65535 28784)
414 ("DarkOliveGreen2" 48316 61166 26728)
415 ("DarkOliveGreen3" 41634 52685 23130)
416 ("DarkOliveGreen4" 28270 35723 15677)
417 ("khaki1" 65535 63222 36751)
418 ("khaki2" 61166 59110 34181)
419 ("khaki3" 52685 50886 29555)
420 ("khaki4" 35723 34438 20046)
421 ("LightGoldenrod1" 65535 60652 35723)
422 ("LightGoldenrod2" 61166 56540 33410)
423 ("LightGoldenrod3" 52685 48830 28784)
424 ("LightGoldenrod4" 35723 33153 19532)
425 ("LightYellow1" 65535 65535 57568)
426 ("LightYellow2" 61166 61166 53713)
427 ("LightYellow3" 52685 52685 46260)
428 ("LightYellow4" 35723 35723 31354)
429 ("yellow1" 65535 65535 0)
430 ("yellow2" 61166 61166 0)
431 ("yellow3" 52685 52685 0)
432 ("yellow4" 35723 35723 0)
433 ("gold1" 65535 55255 0)
434 ("gold2" 61166 51657 0)
435 ("gold3" 52685 44461 0)
436 ("gold4" 35723 30069 0)
437 ("goldenrod1" 65535 49601 9509)
438 ("goldenrod2" 61166 46260 8738)
439 ("goldenrod3" 52685 39835 7453)
440 ("goldenrod4" 35723 26985 5140)
441 ("DarkGoldenrod1" 65535 47545 3855)
442 ("DarkGoldenrod2" 61166 44461 3598)
443 ("DarkGoldenrod3" 52685 38293 3084)
444 ("DarkGoldenrod4" 35723 25957 2056)
445 ("RosyBrown1" 65535 49601 49601)
446 ("RosyBrown2" 61166 46260 46260)
447 ("RosyBrown3" 52685 39835 39835)
448 ("RosyBrown4" 35723 26985 26985)
449 ("IndianRed1" 65535 27242 27242)
450 ("IndianRed2" 61166 25443 25443)
451 ("IndianRed3" 52685 21845 21845)
452 ("IndianRed4" 35723 14906 14906)
453 ("sienna1" 65535 33410 18247)
454 ("sienna2" 61166 31097 16962)
455 ("sienna3" 52685 26728 14649)
456 ("sienna4" 35723 18247 9766)
457 ("burlywood1" 65535 54227 39835)
458 ("burlywood2" 61166 50629 37265)
459 ("burlywood3" 52685 43690 32125)
460 ("burlywood4" 35723 29555 21845)
461 ("wheat1" 65535 59367 47802)
462 ("wheat2" 61166 55512 44718)
463 ("wheat3" 52685 47802 38550)
464 ("wheat4" 35723 32382 26214)
465 ("tan1" 65535 42405 20303)
466 ("tan2" 61166 39578 18761)
467 ("tan3" 52685 34181 16191)
468 ("tan4" 35723 23130 11051)
469 ("chocolate1" 65535 32639 9252)
470 ("chocolate2" 61166 30326 8481)
471 ("chocolate3" 52685 26214 7453)
472 ("chocolate4" 35723 17733 4883)
473 ("firebrick1" 65535 12336 12336)
474 ("firebrick2" 61166 11308 11308)
475 ("firebrick3" 52685 9766 9766)
476 ("firebrick4" 35723 6682 6682)
477 ("brown1" 65535 16448 16448)
478 ("brown2" 61166 15163 15163)
479 ("brown3" 52685 13107 13107)
480 ("brown4" 35723 8995 8995)
481 ("salmon1" 65535 35980 26985)
482 ("salmon2" 61166 33410 25186)
483 ("salmon3" 52685 28784 21588)
484 ("salmon4" 35723 19532 14649)
485 ("LightSalmon1" 65535 41120 31354)
486 ("LightSalmon2" 61166 38293 29298)
487 ("LightSalmon3" 52685 33153 25186)
488 ("LightSalmon4" 35723 22359 16962)
489 ("orange1" 65535 42405 0)
490 ("orange2" 61166 39578 0)
491 ("orange3" 52685 34181 0)
492 ("orange4" 35723 23130 0)
493 ("DarkOrange1" 65535 32639 0)
494 ("DarkOrange2" 61166 30326 0)
495 ("DarkOrange3" 52685 26214 0)
496 ("DarkOrange4" 35723 17733 0)
497 ("coral1" 65535 29298 22102)
498 ("coral2" 61166 27242 20560)
499 ("coral3" 52685 23387 17733)
500 ("coral4" 35723 15934 12079)
501 ("tomato1" 65535 25443 18247)
502 ("tomato2" 61166 23644 16962)
503 ("tomato3" 52685 20303 14649)
504 ("tomato4" 35723 13878 9766)
505 ("OrangeRed1" 65535 17733 0)
506 ("OrangeRed2" 61166 16448 0)
507 ("OrangeRed3" 52685 14135 0)
508 ("OrangeRed4" 35723 9509 0)
509 ("red1" 65535 0 0)
510 ("red2" 61166 0 0)
511 ("red3" 52685 0 0)
512 ("red4" 35723 0 0)
513 ("DeepPink1" 65535 5140 37779)
514 ("DeepPink2" 61166 4626 35209)
515 ("DeepPink3" 52685 4112 30326)
516 ("DeepPink4" 35723 2570 20560)
517 ("HotPink1" 65535 28270 46260)
518 ("HotPink2" 61166 27242 42919)
519 ("HotPink3" 52685 24672 37008)
520 ("HotPink4" 35723 14906 25186)
521 ("pink1" 65535 46517 50629)
522 ("pink2" 61166 43433 47288)
523 ("pink3" 52685 37265 40606)
524 ("pink4" 35723 25443 27756)
525 ("LightPink1" 65535 44718 47545)
526 ("LightPink2" 61166 41634 44461)
527 ("LightPink3" 52685 35980 38293)
528 ("LightPink4" 35723 24415 25957)
529 ("PaleVioletRed1" 65535 33410 43947)
530 ("PaleVioletRed2" 61166 31097 40863)
531 ("PaleVioletRed3" 52685 26728 35209)
532 ("PaleVioletRed4" 35723 18247 23901)
533 ("maroon1" 65535 13364 46003)
534 ("maroon2" 61166 12336 42919)
535 ("maroon3" 52685 10537 37008)
536 ("maroon4" 35723 7196 25186)
537 ("VioletRed1" 65535 15934 38550)
538 ("VioletRed2" 61166 14906 35980)
539 ("VioletRed3" 52685 12850 30840)
540 ("VioletRed4" 35723 8738 21074)
541 ("magenta1" 65535 0 65535)
542 ("magenta2" 61166 0 61166)
543 ("magenta3" 52685 0 52685)
544 ("magenta4" 35723 0 35723)
545 ("orchid1" 65535 33667 64250)
546 ("orchid2" 61166 31354 59881)
547 ("orchid3" 52685 26985 51657)
548 ("orchid4" 35723 18247 35209)
549 ("plum1" 65535 48059 65535)
550 ("plum2" 61166 44718 61166)
551 ("plum3" 52685 38550 52685)
552 ("plum4" 35723 26214 35723)
553 ("MediumOrchid1" 57568 26214 65535)
554 ("MediumOrchid2" 53713 24415 61166)
555 ("MediumOrchid3" 46260 21074 52685)
556 ("MediumOrchid4" 31354 14135 35723)
557 ("DarkOrchid1" 49087 15934 65535)
558 ("DarkOrchid2" 45746 14906 61166)
559 ("DarkOrchid3" 39578 12850 52685)
560 ("DarkOrchid4" 26728 8738 35723)
561 ("purple1" 39835 12336 65535)
562 ("purple2" 37265 11308 61166)
563 ("purple3" 32125 9766 52685)
564 ("purple4" 21845 6682 35723)
565 ("MediumPurple1" 43947 33410 65535)
566 ("MediumPurple2" 40863 31097 61166)
567 ("MediumPurple3" 35209 26728 52685)
568 ("MediumPurple4" 23901 18247 35723)
569 ("thistle1" 65535 57825 65535)
570 ("thistle2" 61166 53970 61166)
571 ("thistle3" 52685 46517 52685)
572 ("thistle4" 35723 31611 35723)
573 ("gray0" 0 0 0)
574 ("grey0" 0 0 0)
575 ("gray1" 771 771 771)
576 ("grey1" 771 771 771)
577 ("gray2" 1285 1285 1285)
578 ("grey2" 1285 1285 1285)
579 ("gray3" 2056 2056 2056)
580 ("grey3" 2056 2056 2056)
581 ("gray4" 2570 2570 2570)
582 ("grey4" 2570 2570 2570)
583 ("gray5" 3341 3341 3341)
584 ("grey5" 3341 3341 3341)
585 ("gray6" 3855 3855 3855)
586 ("grey6" 3855 3855 3855)
587 ("gray7" 4626 4626 4626)
588 ("grey7" 4626 4626 4626)
589 ("gray8" 5140 5140 5140)
590 ("grey8" 5140 5140 5140)
591 ("gray9" 5911 5911 5911)
592 ("grey9" 5911 5911 5911)
593 ("gray10" 6682 6682 6682)
594 ("grey10" 6682 6682 6682)
595 ("gray11" 7196 7196 7196)
596 ("grey11" 7196 7196 7196)
597 ("gray12" 7967 7967 7967)
598 ("grey12" 7967 7967 7967)
599 ("gray13" 8481 8481 8481)
600 ("grey13" 8481 8481 8481)
601 ("gray14" 9252 9252 9252)
602 ("grey14" 9252 9252 9252)
603 ("gray15" 9766 9766 9766)
604 ("grey15" 9766 9766 9766)
605 ("gray16" 10537 10537 10537)
606 ("grey16" 10537 10537 10537)
607 ("gray17" 11051 11051 11051)
608 ("grey17" 11051 11051 11051)
609 ("gray18" 11822 11822 11822)
610 ("grey18" 11822 11822 11822)
611 ("gray19" 12336 12336 12336)
612 ("grey19" 12336 12336 12336)
613 ("gray20" 13107 13107 13107)
614 ("grey20" 13107 13107 13107)
615 ("gray21" 13878 13878 13878)
616 ("grey21" 13878 13878 13878)
617 ("gray22" 14392 14392 14392)
618 ("grey22" 14392 14392 14392)
619 ("gray23" 15163 15163 15163)
620 ("grey23" 15163 15163 15163)
621 ("gray24" 15677 15677 15677)
622 ("grey24" 15677 15677 15677)
623 ("gray25" 16448 16448 16448)
624 ("grey25" 16448 16448 16448)
625 ("gray26" 16962 16962 16962)
626 ("grey26" 16962 16962 16962)
627 ("gray27" 17733 17733 17733)
628 ("grey27" 17733 17733 17733)
629 ("gray28" 18247 18247 18247)
630 ("grey28" 18247 18247 18247)
631 ("gray29" 19018 19018 19018)
632 ("grey29" 19018 19018 19018)
633 ("gray30" 19789 19789 19789)
634 ("grey30" 19789 19789 19789)
635 ("gray31" 20303 20303 20303)
636 ("grey31" 20303 20303 20303)
637 ("gray32" 21074 21074 21074)
638 ("grey32" 21074 21074 21074)
639 ("gray33" 21588 21588 21588)
640 ("grey33" 21588 21588 21588)
641 ("gray34" 22359 22359 22359)
642 ("grey34" 22359 22359 22359)
643 ("gray35" 22873 22873 22873)
644 ("grey35" 22873 22873 22873)
645 ("gray36" 23644 23644 23644)
646 ("grey36" 23644 23644 23644)
647 ("gray37" 24158 24158 24158)
648 ("grey37" 24158 24158 24158)
649 ("gray38" 24929 24929 24929)
650 ("grey38" 24929 24929 24929)
651 ("gray39" 25443 25443 25443)
652 ("grey39" 25443 25443 25443)
653 ("gray40" 26214 26214 26214)
654 ("grey40" 26214 26214 26214)
655 ("gray41" 26985 26985 26985)
656 ("grey41" 26985 26985 26985)
657 ("gray42" 27499 27499 27499)
658 ("grey42" 27499 27499 27499)
659 ("gray43" 28270 28270 28270)
660 ("grey43" 28270 28270 28270)
661 ("gray44" 28784 28784 28784)
662 ("grey44" 28784 28784 28784)
663 ("gray45" 29555 29555 29555)
664 ("grey45" 29555 29555 29555)
665 ("gray46" 30069 30069 30069)
666 ("grey46" 30069 30069 30069)
667 ("gray47" 30840 30840 30840)
668 ("grey47" 30840 30840 30840)
669 ("gray48" 31354 31354 31354)
670 ("grey48" 31354 31354 31354)
671 ("gray49" 32125 32125 32125)
672 ("grey49" 32125 32125 32125)
673 ("gray50" 32639 32639 32639)
674 ("grey50" 32639 32639 32639)
675 ("gray51" 33410 33410 33410)
676 ("grey51" 33410 33410 33410)
677 ("gray52" 34181 34181 34181)
678 ("grey52" 34181 34181 34181)
679 ("gray53" 34695 34695 34695)
680 ("grey53" 34695 34695 34695)
681 ("gray54" 35466 35466 35466)
682 ("grey54" 35466 35466 35466)
683 ("gray55" 35980 35980 35980)
684 ("grey55" 35980 35980 35980)
685 ("gray56" 36751 36751 36751)
686 ("grey56" 36751 36751 36751)
687 ("gray57" 37265 37265 37265)
688 ("grey57" 37265 37265 37265)
689 ("gray58" 38036 38036 38036)
690 ("grey58" 38036 38036 38036)
691 ("gray59" 38550 38550 38550)
692 ("grey59" 38550 38550 38550)
693 ("gray60" 39321 39321 39321)
694 ("grey60" 39321 39321 39321)
695 ("gray61" 40092 40092 40092)
696 ("grey61" 40092 40092 40092)
697 ("gray62" 40606 40606 40606)
698 ("grey62" 40606 40606 40606)
699 ("gray63" 41377 41377 41377)
700 ("grey63" 41377 41377 41377)
701 ("gray64" 41891 41891 41891)
702 ("grey64" 41891 41891 41891)
703 ("gray65" 42662 42662 42662)
704 ("grey65" 42662 42662 42662)
705 ("gray66" 43176 43176 43176)
706 ("grey66" 43176 43176 43176)
707 ("gray67" 43947 43947 43947)
708 ("grey67" 43947 43947 43947)
709 ("gray68" 44461 44461 44461)
710 ("grey68" 44461 44461 44461)
711 ("gray69" 45232 45232 45232)
712 ("grey69" 45232 45232 45232)
713 ("gray70" 46003 46003 46003)
714 ("grey70" 46003 46003 46003)
715 ("gray71" 46517 46517 46517)
716 ("grey71" 46517 46517 46517)
717 ("gray72" 47288 47288 47288)
718 ("grey72" 47288 47288 47288)
719 ("gray73" 47802 47802 47802)
720 ("grey73" 47802 47802 47802)
721 ("gray74" 48573 48573 48573)
722 ("grey74" 48573 48573 48573)
723 ("gray75" 49087 49087 49087)
724 ("grey75" 49087 49087 49087)
725 ("gray76" 49858 49858 49858)
726 ("grey76" 49858 49858 49858)
727 ("gray77" 50372 50372 50372)
728 ("grey77" 50372 50372 50372)
729 ("gray78" 51143 51143 51143)
730 ("grey78" 51143 51143 51143)
731 ("gray79" 51657 51657 51657)
732 ("grey79" 51657 51657 51657)
733 ("gray80" 52428 52428 52428)
734 ("grey80" 52428 52428 52428)
735 ("gray81" 53199 53199 53199)
736 ("grey81" 53199 53199 53199)
737 ("gray82" 53713 53713 53713)
738 ("grey82" 53713 53713 53713)
739 ("gray83" 54484 54484 54484)
740 ("grey83" 54484 54484 54484)
741 ("gray84" 54998 54998 54998)
742 ("grey84" 54998 54998 54998)
743 ("gray85" 55769 55769 55769)
744 ("grey85" 55769 55769 55769)
745 ("gray86" 56283 56283 56283)
746 ("grey86" 56283 56283 56283)
747 ("gray87" 57054 57054 57054)
748 ("grey87" 57054 57054 57054)
749 ("gray88" 57568 57568 57568)
750 ("grey88" 57568 57568 57568)
751 ("gray89" 58339 58339 58339)
752 ("grey89" 58339 58339 58339)
753 ("gray90" 58853 58853 58853)
754 ("grey90" 58853 58853 58853)
755 ("gray91" 59624 59624 59624)
756 ("grey91" 59624 59624 59624)
757 ("gray92" 60395 60395 60395)
758 ("grey92" 60395 60395 60395)
759 ("gray93" 60909 60909 60909)
760 ("grey93" 60909 60909 60909)
761 ("gray94" 61680 61680 61680)
762 ("grey94" 61680 61680 61680)
763 ("gray95" 62194 62194 62194)
764 ("grey95" 62194 62194 62194)
765 ("gray96" 62965 62965 62965)
766 ("grey96" 62965 62965 62965)
767 ("gray97" 63479 63479 63479)
768 ("grey97" 63479 63479 63479)
769 ("gray98" 64250 64250 64250)
770 ("grey98" 64250 64250 64250)
771 ("gray99" 64764 64764 64764)
772 ("grey99" 64764 64764 64764)
773 ("gray100" 65535 65535 65535)
774 ("grey100" 65535 65535 65535)
775 ("dark grey" 43433 43433 43433)
776 ("DarkGrey" 43433 43433 43433)
777 ("dark gray" 43433 43433 43433)
778 ("DarkGray" 43433 43433 43433)
779 ("dark blue" 0 0 35723)
780 ("DarkBlue" 0 0 35723)
781 ("dark cyan" 0 35723 35723)
782 ("DarkCyan" 0 35723 35723)
783 ("dark magenta" 35723 0 35723)
784 ("DarkMagenta" 35723 0 35723)
785 ("dark red" 35723 0 0)
786 ("DarkRed" 35723 0 0)
787 ("light green" 37008 61166 37008)
788 ("LightGreen" 37008 61166 37008)) )
789
790(defvar hfy-rgb-txt-colour-map nil)
791
792(defvar hfy-rgb-load-path
793 (list "/etc/X11"
794 (format "/usr/share/emacs/%d.%d/etc"
795 emacs-major-version
796 emacs-minor-version)
797 "/usr/X11R6/lib/X11"))
798
799(defun hfy-rgb-file ()
800 "Return a fully qualified path to the X11 style rgb.txt file."
801 (catch 'rgb-file
802 (mapcar
803 (lambda (DIR)
804 (let ((rgb-file (concat DIR "/rgb.txt")))
805 (if (file-readable-p rgb-file)
806 (throw 'rgb-file rgb-file) nil)) ) hfy-rgb-load-path) nil))
807
808(defconst hfy-rgb-regex
809 "^\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\(.+\\)\\s-*$")
810
811(defun htmlfontify-load-rgb-file (&optional file)
812 "Load an X11 style rgb.txt FILE.
813Search `hfy-rgb-load-path' if FILE is not specified.
814Loads the variable `hfy-rgb-txt-colour-map', which is used by
815`hfy-fallback-colour-values'."
816 (interactive
817 (list
818 (read-file-name "rgb.txt \(equivalent\) file: " "" nil t (hfy-rgb-file))))
819 (let ((rgb-buffer nil)
820 (end-of-rgb 0)
821 (rgb-txt nil)
822 (ff 255.0))
823 (if (and (setq rgb-txt (or file (hfy-rgb-file)))
824 (file-readable-p rgb-txt))
825 (save-excursion
826 (setq rgb-buffer (find-file-noselect rgb-txt 'nowarn))
827 (set-buffer rgb-buffer)
828 (goto-char (point-min))
829 (htmlfontify-unload-rgb-file)
830 (while (/= end-of-rgb 1)
831 (if (looking-at hfy-rgb-regex)
832 (setq hfy-rgb-txt-colour-map
833 (cons (list (match-string 4)
834 (string-to-int (match-string 1))
835 (string-to-int (match-string 2))
836 (string-to-int (match-string 3)))
837 hfy-rgb-txt-colour-map)) )
838 (setq end-of-rgb (forward-line)))
839 (kill-buffer rgb-buffer))
840 )
841 )
842 )
843
844(defun htmlfontify-unload-rgb-file ()
845 (interactive)
846 (setq hfy-rgb-txt-colour-map nil))
847
848(defun hfy-fallback-colour-values (colour-string)
849 (cdr (assoc-ignore-case colour-string (or hfy-rgb-txt-colour-map
850 hfy-fallback-colour-map))) )
851
852(provide 'hfy-cmap)
853;;; hfy-cmap.el ends here
854
diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el
new file mode 100644
index 00000000000..30695c44bc0
--- /dev/null
+++ b/lisp/htmlfontify.el
@@ -0,0 +1,2374 @@
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
142In order to:\n
143fontify a file you have open: M-x htmlfontify-buffer
144prepare the etags map for a directory: M-x htmlfontify-run-etags
145copy a directory, fontifying as you go: M-x htmlfontify-copy-and-link-dir\n
146The 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
148load an X11 style rgb.txt file: M-x htmlfontify-load-rgb-file
149unload the current rgb.txt file: M-x htmlfontify-unload-rgb-file\n
150And 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
155html-css-url := /css/red+black.css
156title := rtfm.etla.org \( %s / src/%s \)
157bodytag :=
158head <=STYLESHEET;\\n
159%s
160STYLESHEET
161main-title := rtfm / %s / src/%s\\n
162main-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
180files \(driven by etags\) if requested.\n
181See: `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
187level source directory being etag\'d and fontified), and a string containing
188the <style>...</style> text to embed in the document- the string returned will
189be used as the header for the htmlfontified version of the source file.\n
190See 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
197on the first letter of each tag. Useful when the index would otherwise
198be 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
230output files are going to be processed again, with a resulting change
231in file extension. If nil, then any code using this should fall back
232to `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
240its argument, altered so as to make any changes you want made for text which
241is a hyperlink, in addition to being in the class to which that style would
242normally 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
249fontification-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
256fontification-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
263which should be quoted with `hfy-html-quote' \(and `hfy-html-quote-map'\)
264to 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
271kludging necessary to get highlighting modes to bahave as you want, even
272when 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.
279These 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
288potentially non-current face information doesn\'t necessarily work for
289\'default\).\n
290Example: 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,
302in 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`;
320do
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;
348done;")
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
364Note that if etags is not in your path, you will need to alter the shell
365commands 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
385file for the whole source tree from there on down. The command should emit
386the etags output on stdout.\n
387Two canned commands are provided - they drive Emacs\' etags and
388exuberant-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
402or not. The command should emit a string containing the word \'text\' if
403the 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
417calculating a face\'s attributes. This is useful when, for example, you
418are running Emacs on a tty or in batch mode, and want htmlfontify to have
419access to the face spec you would use if you were connected to an X display.\n
420Some 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\)
429Multiple values for a tag may be combined, to indicate that any one or more
430of 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
438and 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
468Note: like compiler optimisations, these optimise the _output_ of the code,
469not the processing of the source itself, and are therefore likely to slow
470htmlfontify down, at least a little. Except for skip-refontification,
471which 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
485Each tag hash entry then contains entries of the form:\n
486\"tag_string\" => ((\"file/name.ext\" line char) ... )\n
487ie an alist mapping \(relative\) file paths to line and character offsets.\n
488See `hfy-load-tags-cache'.")
489
490(defvar hfy-tags-sortl nil
491 "Alist of the form \(\(\"/src/dir\" . (tag0 tag1 tag2)\) ... \)\n
492Where the tags are stored in descending order of length.\n
493See `hfy-load-tags-cache'.")
494
495(defvar hfy-tags-rmap nil
496 "Alist of the form \(\(\"/src/dir\" . tag-rmap-hash\)\)\n
497Where tag-rmap-hash has entries of the form:
498\"tag_string\" => ( \"file/name.ext\" line char )
499Unlike `hfy-tags-cache' these are the locations of occurrences of
500tagged 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.
504Properties may be repeated, In which case later properties should be
505treated as if they were inherited from a \'parent\' font.
506\(For some properties, only the first encountered value is of any importance,
507for others the values might be cumulative, and for others they might be
508cumulative in a complex way).\n
509Some 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\)
532and (point . 'end) elements, in descending order of point value
533\(ie from the file's end to its beginning\).\n
534The map is in reverse order because inserting a <style> tag \(or any other
535string) at POINT invalidates the map for all entries with a greater value of
536point. By traversing the map from greatest to least POINT, we still invalidate
537the map as we go, but only those points we have already dealt with \( and
538therefore 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
582list of 3 (16 bit) rgb values for said colour.\n
583If 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
601in 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'.
613FILE is the name of the file.
614STYLE 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'.
703FILE 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
708of 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.
724Uses the definition of \"white\" to map the numbers to the 0-255 range, so
725if you\'ve redefined white, \(esp if you've redefined it to have a triplet
726member lower than that of the colour you are processing, strange things
727may 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.
751Does not cope with the case where height is a function to be applied to
752the 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:
763CSS does not define the reverse-* styles, so just maps those to the
764regular 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.
813TAG is an Emacs font attribute key (eg :underline).
814VAL 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.
822Do something in CSS to make that happen.
823VAL 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.
828Entries resulting from customisation \(`custom-set-faces'\) will take
829precedence."
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.
838If CLASS is set, it must be a `defface' alist key \[see below\],
839in which case the first face specification returned by `hfy-combined-face-spec'
840which *doesn\'t* clash with CLASS is returned.\n
841\(A specification with a class of t is considered to match any class you
842specify - this matches Emacs\' behaviour when deciding on which face attributes
843to use, to the best of my understanding\).\n
844If CLASS is nil, then you just get get whatever `face-attr-construct' returns,
845ie the current specification in effect for FACE.\n
846*NOTE* This function forces any face that is not \'default and which has
847no :inherit property to inherit from \'default \( this is because \'default
848is magical in that Emacs' fonts behave as if they inherit implicitly from
849\'default, but no such behaviour exists in HTML/CSS \).\n
850See `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,
937as returned by `face-attr-construct' or `hfy-face-attr-for-class'. Note
938that this function does not get font-sizes right if they are based on
939inherited modifiers \(via the :inherit\) attribute, and any other
940modifiers that are cumulative if they appear multiple times need to be
941merged 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
989value. 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
1004any multiple attributes appropriately. Currently only font-size is merged
1005down to a single occurrence - others may need special handling, but I
1006haven\'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'\)
1026and return a `hfy-style-assoc'.\n
1027See 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'\)
1083and return a CSS style specification.\n
1084See 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
1106property, 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
1118property, 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.
1177POINT is the point inside the invisible region.
1178MAP 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.
1197If overlays are to be considered \(see `hfy-optimisations'\) then this may
1198return 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.
1330The 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
1355mode, but we want to know if we should fontify or raw copy, so in batch
1356mode we check for non-default face properties. Otherwise we test
1357variable `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,
1378this function merges adjacent style blocks which are of the same value
1379and 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
1383Returns 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.
1455The filename of this buffer is derived from the source \(current\) buffer\'s
1456variable `buffer-file-name', if it is set, plus `hfy-extn'.
1457Otherwise 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.
1477Uses `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[
1505function 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
1533See 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
1553using `hfy-html-quote'\n
1554See 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.
1565Do 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'.
1602SRCDIR, if set, is the directory being htmlfontified.
1603FILE, 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,
1793containing an inline css-stylesheet and formatted css-markup html
1794that reproduces the look of the current Emacs buffer as closely
1795as possible.
1796
1797Dangerous characters in the existing buffer are turned into html
1798entities, so you should even be able to do html-within-html
1799fontified display.
1800
1801You should, however, note that random control or eight-bit
1802characters such as ^L (\x0c) or ¤ (\xa4) won't get mapped yet.
1803
1804If the SRCDIR and FILE arguments are set, lookup etags derived
1805entries in the `hfy-tags-cache' and add html anchors and
1806hyperlinks 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.
1824Strips 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,
1835on the assumption that this will produce a relative directory name. Hardly
1836bombproof, 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
1860adding 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.
1890Looks 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
1905property, 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
1926tree depth \(as determined from FILE \(a filename\)\).
1927START 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:
1935If DEF-FILES \(list of files containing definitions for the tag in question\)
1936contains only one entry, the href should link straight to that file.
1937Otherwise, the link should be to the index file.\n
1938We are not yet concerned with the file extensions/tag line number and so on at
1939this point.\n
1940If `hfy-split-index' is set, and the href wil be to an index file rather than
1941a source file, append a .X to `hfy-index-file', where X is the uppercased
1942first character of TAG.\n
1943See 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
1953THIS-FILE `hfy-link-extn' `hfy-extn' DEF-FILES TAG and TAG-MAP\n
1954THIS-FILE is the current source file
1955DEF-FILES is a list of file containing possible link endpoints for TAG
1956TAG is the TAG in question
1957TAG-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
1967word 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
1974Mark href end points with the \'hfy-endl prop \(value t\)\n
1975Avoid overlapping links, and mark links in descending length of
1976tag name in order to prevent subtags from usurping supertags,
1977\(eg \"term\" for \"terminal\").
1978SRCDIR is the directory being \"published\".
1979FILE 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'
2132all play a part here.\n
2133If STUB is set, prepare an \(appropriately named\) index buffer
2134specifically for entries beginning with STUB.\n
2135If MAP is set, use that instead of `hfy-tags-cache'.
2136FILENAME is the name of the file being indexed.
2137DSTDIR 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'.
2187SRCDIR 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
2210with the same structure, but listing \( and linking to \) instances of tags
2211\( as opposed to their definitions \).\n
2212SRCDIR and DSTDIR are the source and output directories respectively.
2213See: `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.
2243SRCDIR is the directory being \"published\".
2244See: `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.
2269See `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.
2287F-EXT and L-EXT specify values for `hfy-extn' and `hfy-link-extn'.\n
2288You 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
generated by cgit v1.2.1 (git 2.18.0) at 2026-02-03 12:37:09 +0000