Mercurial > emacs
changeset 106126:10d66efa4c61
New files.
| author | Stefan Monnier <monnier@iro.umontreal.ca> |
|---|---|
| date | Thu, 19 Nov 2009 20:21:01 +0000 |
| parents | 805f90cb413e |
| children | e9b00d8b4756 |
| files | lisp/ChangeLog lisp/hfy-cmap.el lisp/htmlfontify.el |
| diffstat | 3 files changed, 3234 insertions(+), 2 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Thu Nov 19 17:40:14 2009 +0000 +++ b/lisp/ChangeLog Thu Nov 19 20:21:01 2009 +0000 @@ -1,3 +1,7 @@ +2009-11-19 Vivek Dasmohapatra <vivek@etla.org> + + * htmlfontify.el, hfy-cmap.el: New files. + 2009-11-19 Juri Linkov <juri@jurta.org> * minibuffer.el (completions-format): New defcustom. @@ -25,8 +29,8 @@ 2009-11-19 Michael Albinus <michael.albinus@gmx.de> - * net/tramp.el (tramp-do-copy-or-rename-file-out-of-band): Set - variables for computing the prompt for reading password. + * net/tramp.el (tramp-do-copy-or-rename-file-out-of-band): + Set variables for computing the prompt for reading password. 2009-11-19 Glenn Morris <rgm@gnu.org>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/hfy-cmap.el Thu Nov 19 20:21:01 2009 +0000 @@ -0,0 +1,854 @@ +;;; hfy-cmap.el --- Fallback colour name -> rgb mapping for `htmlfontify' + +;; Copyright (C) 2002, 2003, 2009 Free Software Foundation, Inc. + +;; Emacs Lisp Archive Entry +;; Package: htmlfontify +;; Filename: hfy-cmap.el +;; Version: 0.20 +;; Keywords: colour, rgb +;; Author: Vivek Dasmohapatra <vivek@etla.org> +;; Maintainer: Vivek Dasmohapatra <vivek@etla.org> +;; Created: 2002-01-20 +;; Description: fallback code for colour name -> rgb mapping +;; URL: http://rtfm.etla.org/emacs/htmlfontify/ +;; Last-Updated: Sat 2003-02-15 03:49:32 +0000 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(defconst hfy-fallback-colour-map + '(("snow" 65535 64250 64250) + ("ghost white" 63736 63736 65535) + ("GhostWhite" 63736 63736 65535) + ("white smoke" 62965 62965 62965) + ("WhiteSmoke" 62965 62965 62965) + ("gainsboro" 56540 56540 56540) + ("floral white" 65535 64250 61680) + ("FloralWhite" 65535 64250 61680) + ("old lace" 65021 62965 59110) + ("OldLace" 65021 62965 59110) + ("linen" 64250 61680 59110) + ("antique white" 64250 60395 55255) + ("AntiqueWhite" 64250 60395 55255) + ("papaya whip" 65535 61423 54741) + ("PapayaWhip" 65535 61423 54741) + ("blanched almond" 65535 60395 52685) + ("BlanchedAlmond" 65535 60395 52685) + ("bisque" 65535 58596 50372) + ("peach puff" 65535 56026 47545) + ("PeachPuff" 65535 56026 47545) + ("navajo white" 65535 57054 44461) + ("NavajoWhite" 65535 57054 44461) + ("moccasin" 65535 58596 46517) + ("cornsilk" 65535 63736 56540) + ("ivory" 65535 65535 61680) + ("lemon chiffon" 65535 64250 52685) + ("LemonChiffon" 65535 64250 52685) + ("seashell" 65535 62965 61166) + ("honeydew" 61680 65535 61680) + ("mint cream" 62965 65535 64250) + ("MintCream" 62965 65535 64250) + ("azure" 61680 65535 65535) + ("alice blue" 61680 63736 65535) + ("AliceBlue" 61680 63736 65535) + ("lavender" 59110 59110 64250) + ("lavender blush" 65535 61680 62965) + ("LavenderBlush" 65535 61680 62965) + ("misty rose" 65535 58596 57825) + ("MistyRose" 65535 58596 57825) + ("white" 65535 65535 65535) + ("black" 0 0 0) + ("dark slate gray" 12079 20303 20303) + ("DarkSlateGray" 12079 20303 20303) + ("dark slate grey" 12079 20303 20303) + ("DarkSlateGrey" 12079 20303 20303) + ("dim gray" 26985 26985 26985) + ("DimGray" 26985 26985 26985) + ("dim grey" 26985 26985 26985) + ("DimGrey" 26985 26985 26985) + ("slate gray" 28784 32896 37008) + ("SlateGray" 28784 32896 37008) + ("slate grey" 28784 32896 37008) + ("SlateGrey" 28784 32896 37008) + ("light slate gray" 30583 34952 39321) + ("LightSlateGray" 30583 34952 39321) + ("light slate grey" 30583 34952 39321) + ("LightSlateGrey" 30583 34952 39321) + ("gray" 48830 48830 48830) + ("grey" 48830 48830 48830) + ("light grey" 54227 54227 54227) + ("LightGrey" 54227 54227 54227) + ("light gray" 54227 54227 54227) + ("LightGray" 54227 54227 54227) + ("midnight blue" 6425 6425 28784) + ("MidnightBlue" 6425 6425 28784) + ("navy" 0 0 32896) + ("navy blue" 0 0 32896) + ("NavyBlue" 0 0 32896) + ("cornflower blue" 25700 38293 60909) + ("CornflowerBlue" 25700 38293 60909) + ("dark slate blue" 18504 15677 35723) + ("DarkSlateBlue" 18504 15677 35723) + ("slate blue" 27242 23130 52685) + ("SlateBlue" 27242 23130 52685) + ("medium slate blue" 31611 26728 61166) + ("MediumSlateBlue" 31611 26728 61166) + ("light slate blue" 33924 28784 65535) + ("LightSlateBlue" 33924 28784 65535) + ("medium blue" 0 0 52685) + ("MediumBlue" 0 0 52685) + ("royal blue" 16705 26985 57825) + ("RoyalBlue" 16705 26985 57825) + ("blue" 0 0 65535) + ("dodger blue" 7710 37008 65535) + ("DodgerBlue" 7710 37008 65535) + ("deep sky blue" 0 49087 65535) + ("DeepSkyBlue" 0 49087 65535) + ("sky blue" 34695 52942 60395) + ("SkyBlue" 34695 52942 60395) + ("light sky blue" 34695 52942 64250) + ("LightSkyBlue" 34695 52942 64250) + ("steel blue" 17990 33410 46260) + ("SteelBlue" 17990 33410 46260) + ("light steel blue" 45232 50372 57054) + ("LightSteelBlue" 45232 50372 57054) + ("light blue" 44461 55512 59110) + ("LightBlue" 44461 55512 59110) + ("powder blue" 45232 57568 59110) + ("PowderBlue" 45232 57568 59110) + ("pale turquoise" 44975 61166 61166) + ("PaleTurquoise" 44975 61166 61166) + ("dark turquoise" 0 52942 53713) + ("DarkTurquoise" 0 52942 53713) + ("medium turquoise" 18504 53713 52428) + ("MediumTurquoise" 18504 53713 52428) + ("turquoise" 16448 57568 53456) + ("cyan" 0 65535 65535) + ("light cyan" 57568 65535 65535) + ("LightCyan" 57568 65535 65535) + ("cadet blue" 24415 40606 41120) + ("CadetBlue" 24415 40606 41120) + ("medium aquamarine" 26214 52685 43690) + ("MediumAquamarine" 26214 52685 43690) + ("aquamarine" 32639 65535 54484) + ("dark green" 0 25700 0) + ("DarkGreen" 0 25700 0) + ("dark olive green" 21845 27499 12079) + ("DarkOliveGreen" 21845 27499 12079) + ("dark sea green" 36751 48316 36751) + ("DarkSeaGreen" 36751 48316 36751) + ("sea green" 11822 35723 22359) + ("SeaGreen" 11822 35723 22359) + ("medium sea green" 15420 46003 29041) + ("MediumSeaGreen" 15420 46003 29041) + ("light sea green" 8224 45746 43690) + ("LightSeaGreen" 8224 45746 43690) + ("pale green" 39064 64507 39064) + ("PaleGreen" 39064 64507 39064) + ("spring green" 0 65535 32639) + ("SpringGreen" 0 65535 32639) + ("lawn green" 31868 64764 0) + ("LawnGreen" 31868 64764 0) + ("green" 0 65535 0) + ("chartreuse" 32639 65535 0) + ("medium spring green" 0 64250 39578) + ("MediumSpringGreen" 0 64250 39578) + ("green yellow" 44461 65535 12079) + ("GreenYellow" 44461 65535 12079) + ("lime green" 12850 52685 12850) + ("LimeGreen" 12850 52685 12850) + ("yellow green" 39578 52685 12850) + ("YellowGreen" 39578 52685 12850) + ("forest green" 8738 35723 8738) + ("ForestGreen" 8738 35723 8738) + ("olive drab" 27499 36494 8995) + ("OliveDrab" 27499 36494 8995) + ("dark khaki" 48573 47031 27499) + ("DarkKhaki" 48573 47031 27499) + ("khaki" 61680 59110 35980) + ("pale goldenrod" 61166 59624 43690) + ("PaleGoldenrod" 61166 59624 43690) + ("light goldenrod yellow" 64250 64250 53970) + ("LightGoldenrodYellow" 64250 64250 53970) + ("light yellow" 65535 65535 57568) + ("LightYellow" 65535 65535 57568) + ("yellow" 65535 65535 0) + ("gold" 65535 55255 0) + ("light goldenrod" 61166 56797 33410) + ("LightGoldenrod" 61166 56797 33410) + ("goldenrod" 56026 42405 8224) + ("dark goldenrod" 47288 34438 2827) + ("DarkGoldenrod" 47288 34438 2827) + ("rosy brown" 48316 36751 36751) + ("RosyBrown" 48316 36751 36751) + ("indian red" 52685 23644 23644) + ("IndianRed" 52685 23644 23644) + ("saddle brown" 35723 17733 4883) + ("SaddleBrown" 35723 17733 4883) + ("sienna" 41120 21074 11565) + ("peru" 52685 34181 16191) + ("burlywood" 57054 47288 34695) + ("beige" 62965 62965 56540) + ("wheat" 62965 57054 46003) + ("sandy brown" 62708 42148 24672) + ("SandyBrown" 62708 42148 24672) + ("tan" 53970 46260 35980) + ("chocolate" 53970 26985 7710) + ("firebrick" 45746 8738 8738) + ("brown" 42405 10794 10794) + ("dark salmon" 59881 38550 31354) + ("DarkSalmon" 59881 38550 31354) + ("salmon" 64250 32896 29298) + ("light salmon" 65535 41120 31354) + ("LightSalmon" 65535 41120 31354) + ("orange" 65535 42405 0) + ("dark orange" 65535 35980 0) + ("DarkOrange" 65535 35980 0) + ("coral" 65535 32639 20560) + ("light coral" 61680 32896 32896) + ("LightCoral" 61680 32896 32896) + ("tomato" 65535 25443 18247) + ("orange red" 65535 17733 0) + ("OrangeRed" 65535 17733 0) + ("red" 65535 0 0) + ("hot pink" 65535 26985 46260) + ("HotPink" 65535 26985 46260) + ("deep pink" 65535 5140 37779) + ("DeepPink" 65535 5140 37779) + ("pink" 65535 49344 52171) + ("light pink" 65535 46774 49601) + ("LightPink" 65535 46774 49601) + ("pale violet red" 56283 28784 37779) + ("PaleVioletRed" 56283 28784 37779) + ("maroon" 45232 12336 24672) + ("medium violet red" 51143 5397 34181) + ("MediumVioletRed" 51143 5397 34181) + ("violet red" 53456 8224 37008) + ("VioletRed" 53456 8224 37008) + ("magenta" 65535 0 65535) + ("violet" 61166 33410 61166) + ("plum" 56797 41120 56797) + ("orchid" 56026 28784 54998) + ("medium orchid" 47802 21845 54227) + ("MediumOrchid" 47802 21845 54227) + ("dark orchid" 39321 12850 52428) + ("DarkOrchid" 39321 12850 52428) + ("dark violet" 38036 0 54227) + ("DarkViolet" 38036 0 54227) + ("blue violet" 35466 11051 58082) + ("BlueViolet" 35466 11051 58082) + ("purple" 41120 8224 61680) + ("medium purple" 37779 28784 56283) + ("MediumPurple" 37779 28784 56283) + ("thistle" 55512 49087 55512) + ("snow1" 65535 64250 64250) + ("snow2" 61166 59881 59881) + ("snow3" 52685 51657 51657) + ("snow4" 35723 35209 35209) + ("seashell1" 65535 62965 61166) + ("seashell2" 61166 58853 57054) + ("seashell3" 52685 50629 49087) + ("seashell4" 35723 34438 33410) + ("AntiqueWhite1" 65535 61423 56283) + ("AntiqueWhite2" 61166 57311 52428) + ("AntiqueWhite3" 52685 49344 45232) + ("AntiqueWhite4" 35723 33667 30840) + ("bisque1" 65535 58596 50372) + ("bisque2" 61166 54741 47031) + ("bisque3" 52685 47031 40606) + ("bisque4" 35723 32125 27499) + ("PeachPuff1" 65535 56026 47545) + ("PeachPuff2" 61166 52171 44461) + ("PeachPuff3" 52685 44975 38293) + ("PeachPuff4" 35723 30583 25957) + ("NavajoWhite1" 65535 57054 44461) + ("NavajoWhite2" 61166 53199 41377) + ("NavajoWhite3" 52685 46003 35723) + ("NavajoWhite4" 35723 31097 24158) + ("LemonChiffon1" 65535 64250 52685) + ("LemonChiffon2" 61166 59881 49087) + ("LemonChiffon3" 52685 51657 42405) + ("LemonChiffon4" 35723 35209 28784) + ("cornsilk1" 65535 63736 56540) + ("cornsilk2" 61166 59624 52685) + ("cornsilk3" 52685 51400 45489) + ("cornsilk4" 35723 34952 30840) + ("ivory1" 65535 65535 61680) + ("ivory2" 61166 61166 57568) + ("ivory3" 52685 52685 49601) + ("ivory4" 35723 35723 33667) + ("honeydew1" 61680 65535 61680) + ("honeydew2" 57568 61166 57568) + ("honeydew3" 49601 52685 49601) + ("honeydew4" 33667 35723 33667) + ("LavenderBlush1" 65535 61680 62965) + ("LavenderBlush2" 61166 57568 58853) + ("LavenderBlush3" 52685 49601 50629) + ("LavenderBlush4" 35723 33667 34438) + ("MistyRose1" 65535 58596 57825) + ("MistyRose2" 61166 54741 53970) + ("MistyRose3" 52685 47031 46517) + ("MistyRose4" 35723 32125 31611) + ("azure1" 61680 65535 65535) + ("azure2" 57568 61166 61166) + ("azure3" 49601 52685 52685) + ("azure4" 33667 35723 35723) + ("SlateBlue1" 33667 28527 65535) + ("SlateBlue2" 31354 26471 61166) + ("SlateBlue3" 26985 22873 52685) + ("SlateBlue4" 18247 15420 35723) + ("RoyalBlue1" 18504 30326 65535) + ("RoyalBlue2" 17219 28270 61166) + ("RoyalBlue3" 14906 24415 52685) + ("RoyalBlue4" 10023 16448 35723) + ("blue1" 0 0 65535) + ("blue2" 0 0 61166) + ("blue3" 0 0 52685) + ("blue4" 0 0 35723) + ("DodgerBlue1" 7710 37008 65535) + ("DodgerBlue2" 7196 34438 61166) + ("DodgerBlue3" 6168 29812 52685) + ("DodgerBlue4" 4112 20046 35723) + ("SteelBlue1" 25443 47288 65535) + ("SteelBlue2" 23644 44204 61166) + ("SteelBlue3" 20303 38036 52685) + ("SteelBlue4" 13878 25700 35723) + ("DeepSkyBlue1" 0 49087 65535) + ("DeepSkyBlue2" 0 45746 61166) + ("DeepSkyBlue3" 0 39578 52685) + ("DeepSkyBlue4" 0 26728 35723) + ("SkyBlue1" 34695 52942 65535) + ("SkyBlue2" 32382 49344 61166) + ("SkyBlue3" 27756 42662 52685) + ("SkyBlue4" 19018 28784 35723) + ("LightSkyBlue1" 45232 58082 65535) + ("LightSkyBlue2" 42148 54227 61166) + ("LightSkyBlue3" 36237 46774 52685) + ("LightSkyBlue4" 24672 31611 35723) + ("SlateGray1" 50886 58082 65535) + ("SlateGray2" 47545 54227 61166) + ("SlateGray3" 40863 46774 52685) + ("SlateGray4" 27756 31611 35723) + ("LightSteelBlue1" 51914 57825 65535) + ("LightSteelBlue2" 48316 53970 61166) + ("LightSteelBlue3" 41634 46517 52685) + ("LightSteelBlue4" 28270 31611 35723) + ("LightBlue1" 49087 61423 65535) + ("LightBlue2" 45746 57311 61166) + ("LightBlue3" 39578 49344 52685) + ("LightBlue4" 26728 33667 35723) + ("LightCyan1" 57568 65535 65535) + ("LightCyan2" 53713 61166 61166) + ("LightCyan3" 46260 52685 52685) + ("LightCyan4" 31354 35723 35723) + ("PaleTurquoise1" 48059 65535 65535) + ("PaleTurquoise2" 44718 61166 61166) + ("PaleTurquoise3" 38550 52685 52685) + ("PaleTurquoise4" 26214 35723 35723) + ("CadetBlue1" 39064 62965 65535) + ("CadetBlue2" 36494 58853 61166) + ("CadetBlue3" 31354 50629 52685) + ("CadetBlue4" 21331 34438 35723) + ("turquoise1" 0 62965 65535) + ("turquoise2" 0 58853 61166) + ("turquoise3" 0 50629 52685) + ("turquoise4" 0 34438 35723) + ("cyan1" 0 65535 65535) + ("cyan2" 0 61166 61166) + ("cyan3" 0 52685 52685) + ("cyan4" 0 35723 35723) + ("DarkSlateGray1" 38807 65535 65535) + ("DarkSlateGray2" 36237 61166 61166) + ("DarkSlateGray3" 31097 52685 52685) + ("DarkSlateGray4" 21074 35723 35723) + ("aquamarine1" 32639 65535 54484) + ("aquamarine2" 30326 61166 50886) + ("aquamarine3" 26214 52685 43690) + ("aquamarine4" 17733 35723 29812) + ("DarkSeaGreen1" 49601 65535 49601) + ("DarkSeaGreen2" 46260 61166 46260) + ("DarkSeaGreen3" 39835 52685 39835) + ("DarkSeaGreen4" 26985 35723 26985) + ("SeaGreen1" 21588 65535 40863) + ("SeaGreen2" 20046 61166 38036) + ("SeaGreen3" 17219 52685 32896) + ("SeaGreen4" 11822 35723 22359) + ("PaleGreen1" 39578 65535 39578) + ("PaleGreen2" 37008 61166 37008) + ("PaleGreen3" 31868 52685 31868) + ("PaleGreen4" 21588 35723 21588) + ("SpringGreen1" 0 65535 32639) + ("SpringGreen2" 0 61166 30326) + ("SpringGreen3" 0 52685 26214) + ("SpringGreen4" 0 35723 17733) + ("green1" 0 65535 0) + ("green2" 0 61166 0) + ("green3" 0 52685 0) + ("green4" 0 35723 0) + ("chartreuse1" 32639 65535 0) + ("chartreuse2" 30326 61166 0) + ("chartreuse3" 26214 52685 0) + ("chartreuse4" 17733 35723 0) + ("OliveDrab1" 49344 65535 15934) + ("OliveDrab2" 46003 61166 14906) + ("OliveDrab3" 39578 52685 12850) + ("OliveDrab4" 26985 35723 8738) + ("DarkOliveGreen1" 51914 65535 28784) + ("DarkOliveGreen2" 48316 61166 26728) + ("DarkOliveGreen3" 41634 52685 23130) + ("DarkOliveGreen4" 28270 35723 15677) + ("khaki1" 65535 63222 36751) + ("khaki2" 61166 59110 34181) + ("khaki3" 52685 50886 29555) + ("khaki4" 35723 34438 20046) + ("LightGoldenrod1" 65535 60652 35723) + ("LightGoldenrod2" 61166 56540 33410) + ("LightGoldenrod3" 52685 48830 28784) + ("LightGoldenrod4" 35723 33153 19532) + ("LightYellow1" 65535 65535 57568) + ("LightYellow2" 61166 61166 53713) + ("LightYellow3" 52685 52685 46260) + ("LightYellow4" 35723 35723 31354) + ("yellow1" 65535 65535 0) + ("yellow2" 61166 61166 0) + ("yellow3" 52685 52685 0) + ("yellow4" 35723 35723 0) + ("gold1" 65535 55255 0) + ("gold2" 61166 51657 0) + ("gold3" 52685 44461 0) + ("gold4" 35723 30069 0) + ("goldenrod1" 65535 49601 9509) + ("goldenrod2" 61166 46260 8738) + ("goldenrod3" 52685 39835 7453) + ("goldenrod4" 35723 26985 5140) + ("DarkGoldenrod1" 65535 47545 3855) + ("DarkGoldenrod2" 61166 44461 3598) + ("DarkGoldenrod3" 52685 38293 3084) + ("DarkGoldenrod4" 35723 25957 2056) + ("RosyBrown1" 65535 49601 49601) + ("RosyBrown2" 61166 46260 46260) + ("RosyBrown3" 52685 39835 39835) + ("RosyBrown4" 35723 26985 26985) + ("IndianRed1" 65535 27242 27242) + ("IndianRed2" 61166 25443 25443) + ("IndianRed3" 52685 21845 21845) + ("IndianRed4" 35723 14906 14906) + ("sienna1" 65535 33410 18247) + ("sienna2" 61166 31097 16962) + ("sienna3" 52685 26728 14649) + ("sienna4" 35723 18247 9766) + ("burlywood1" 65535 54227 39835) + ("burlywood2" 61166 50629 37265) + ("burlywood3" 52685 43690 32125) + ("burlywood4" 35723 29555 21845) + ("wheat1" 65535 59367 47802) + ("wheat2" 61166 55512 44718) + ("wheat3" 52685 47802 38550) + ("wheat4" 35723 32382 26214) + ("tan1" 65535 42405 20303) + ("tan2" 61166 39578 18761) + ("tan3" 52685 34181 16191) + ("tan4" 35723 23130 11051) + ("chocolate1" 65535 32639 9252) + ("chocolate2" 61166 30326 8481) + ("chocolate3" 52685 26214 7453) + ("chocolate4" 35723 17733 4883) + ("firebrick1" 65535 12336 12336) + ("firebrick2" 61166 11308 11308) + ("firebrick3" 52685 9766 9766) + ("firebrick4" 35723 6682 6682) + ("brown1" 65535 16448 16448) + ("brown2" 61166 15163 15163) + ("brown3" 52685 13107 13107) + ("brown4" 35723 8995 8995) + ("salmon1" 65535 35980 26985) + ("salmon2" 61166 33410 25186) + ("salmon3" 52685 28784 21588) + ("salmon4" 35723 19532 14649) + ("LightSalmon1" 65535 41120 31354) + ("LightSalmon2" 61166 38293 29298) + ("LightSalmon3" 52685 33153 25186) + ("LightSalmon4" 35723 22359 16962) + ("orange1" 65535 42405 0) + ("orange2" 61166 39578 0) + ("orange3" 52685 34181 0) + ("orange4" 35723 23130 0) + ("DarkOrange1" 65535 32639 0) + ("DarkOrange2" 61166 30326 0) + ("DarkOrange3" 52685 26214 0) + ("DarkOrange4" 35723 17733 0) + ("coral1" 65535 29298 22102) + ("coral2" 61166 27242 20560) + ("coral3" 52685 23387 17733) + ("coral4" 35723 15934 12079) + ("tomato1" 65535 25443 18247) + ("tomato2" 61166 23644 16962) + ("tomato3" 52685 20303 14649) + ("tomato4" 35723 13878 9766) + ("OrangeRed1" 65535 17733 0) + ("OrangeRed2" 61166 16448 0) + ("OrangeRed3" 52685 14135 0) + ("OrangeRed4" 35723 9509 0) + ("red1" 65535 0 0) + ("red2" 61166 0 0) + ("red3" 52685 0 0) + ("red4" 35723 0 0) + ("DeepPink1" 65535 5140 37779) + ("DeepPink2" 61166 4626 35209) + ("DeepPink3" 52685 4112 30326) + ("DeepPink4" 35723 2570 20560) + ("HotPink1" 65535 28270 46260) + ("HotPink2" 61166 27242 42919) + ("HotPink3" 52685 24672 37008) + ("HotPink4" 35723 14906 25186) + ("pink1" 65535 46517 50629) + ("pink2" 61166 43433 47288) + ("pink3" 52685 37265 40606) + ("pink4" 35723 25443 27756) + ("LightPink1" 65535 44718 47545) + ("LightPink2" 61166 41634 44461) + ("LightPink3" 52685 35980 38293) + ("LightPink4" 35723 24415 25957) + ("PaleVioletRed1" 65535 33410 43947) + ("PaleVioletRed2" 61166 31097 40863) + ("PaleVioletRed3" 52685 26728 35209) + ("PaleVioletRed4" 35723 18247 23901) + ("maroon1" 65535 13364 46003) + ("maroon2" 61166 12336 42919) + ("maroon3" 52685 10537 37008) + ("maroon4" 35723 7196 25186) + ("VioletRed1" 65535 15934 38550) + ("VioletRed2" 61166 14906 35980) + ("VioletRed3" 52685 12850 30840) + ("VioletRed4" 35723 8738 21074) + ("magenta1" 65535 0 65535) + ("magenta2" 61166 0 61166) + ("magenta3" 52685 0 52685) + ("magenta4" 35723 0 35723) + ("orchid1" 65535 33667 64250) + ("orchid2" 61166 31354 59881) + ("orchid3" 52685 26985 51657) + ("orchid4" 35723 18247 35209) + ("plum1" 65535 48059 65535) + ("plum2" 61166 44718 61166) + ("plum3" 52685 38550 52685) + ("plum4" 35723 26214 35723) + ("MediumOrchid1" 57568 26214 65535) + ("MediumOrchid2" 53713 24415 61166) + ("MediumOrchid3" 46260 21074 52685) + ("MediumOrchid4" 31354 14135 35723) + ("DarkOrchid1" 49087 15934 65535) + ("DarkOrchid2" 45746 14906 61166) + ("DarkOrchid3" 39578 12850 52685) + ("DarkOrchid4" 26728 8738 35723) + ("purple1" 39835 12336 65535) + ("purple2" 37265 11308 61166) + ("purple3" 32125 9766 52685) + ("purple4" 21845 6682 35723) + ("MediumPurple1" 43947 33410 65535) + ("MediumPurple2" 40863 31097 61166) + ("MediumPurple3" 35209 26728 52685) + ("MediumPurple4" 23901 18247 35723) + ("thistle1" 65535 57825 65535) + ("thistle2" 61166 53970 61166) + ("thistle3" 52685 46517 52685) + ("thistle4" 35723 31611 35723) + ("gray0" 0 0 0) + ("grey0" 0 0 0) + ("gray1" 771 771 771) + ("grey1" 771 771 771) + ("gray2" 1285 1285 1285) + ("grey2" 1285 1285 1285) + ("gray3" 2056 2056 2056) + ("grey3" 2056 2056 2056) + ("gray4" 2570 2570 2570) + ("grey4" 2570 2570 2570) + ("gray5" 3341 3341 3341) + ("grey5" 3341 3341 3341) + ("gray6" 3855 3855 3855) + ("grey6" 3855 3855 3855) + ("gray7" 4626 4626 4626) + ("grey7" 4626 4626 4626) + ("gray8" 5140 5140 5140) + ("grey8" 5140 5140 5140) + ("gray9" 5911 5911 5911) + ("grey9" 5911 5911 5911) + ("gray10" 6682 6682 6682) + ("grey10" 6682 6682 6682) + ("gray11" 7196 7196 7196) + ("grey11" 7196 7196 7196) + ("gray12" 7967 7967 7967) + ("grey12" 7967 7967 7967) + ("gray13" 8481 8481 8481) + ("grey13" 8481 8481 8481) + ("gray14" 9252 9252 9252) + ("grey14" 9252 9252 9252) + ("gray15" 9766 9766 9766) + ("grey15" 9766 9766 9766) + ("gray16" 10537 10537 10537) + ("grey16" 10537 10537 10537) + ("gray17" 11051 11051 11051) + ("grey17" 11051 11051 11051) + ("gray18" 11822 11822 11822) + ("grey18" 11822 11822 11822) + ("gray19" 12336 12336 12336) + ("grey19" 12336 12336 12336) + ("gray20" 13107 13107 13107) + ("grey20" 13107 13107 13107) + ("gray21" 13878 13878 13878) + ("grey21" 13878 13878 13878) + ("gray22" 14392 14392 14392) + ("grey22" 14392 14392 14392) + ("gray23" 15163 15163 15163) + ("grey23" 15163 15163 15163) + ("gray24" 15677 15677 15677) + ("grey24" 15677 15677 15677) + ("gray25" 16448 16448 16448) + ("grey25" 16448 16448 16448) + ("gray26" 16962 16962 16962) + ("grey26" 16962 16962 16962) + ("gray27" 17733 17733 17733) + ("grey27" 17733 17733 17733) + ("gray28" 18247 18247 18247) + ("grey28" 18247 18247 18247) + ("gray29" 19018 19018 19018) + ("grey29" 19018 19018 19018) + ("gray30" 19789 19789 19789) + ("grey30" 19789 19789 19789) + ("gray31" 20303 20303 20303) + ("grey31" 20303 20303 20303) + ("gray32" 21074 21074 21074) + ("grey32" 21074 21074 21074) + ("gray33" 21588 21588 21588) + ("grey33" 21588 21588 21588) + ("gray34" 22359 22359 22359) + ("grey34" 22359 22359 22359) + ("gray35" 22873 22873 22873) + ("grey35" 22873 22873 22873) + ("gray36" 23644 23644 23644) + ("grey36" 23644 23644 23644) + ("gray37" 24158 24158 24158) + ("grey37" 24158 24158 24158) + ("gray38" 24929 24929 24929) + ("grey38" 24929 24929 24929) + ("gray39" 25443 25443 25443) + ("grey39" 25443 25443 25443) + ("gray40" 26214 26214 26214) + ("grey40" 26214 26214 26214) + ("gray41" 26985 26985 26985) + ("grey41" 26985 26985 26985) + ("gray42" 27499 27499 27499) + ("grey42" 27499 27499 27499) + ("gray43" 28270 28270 28270) + ("grey43" 28270 28270 28270) + ("gray44" 28784 28784 28784) + ("grey44" 28784 28784 28784) + ("gray45" 29555 29555 29555) + ("grey45" 29555 29555 29555) + ("gray46" 30069 30069 30069) + ("grey46" 30069 30069 30069) + ("gray47" 30840 30840 30840) + ("grey47" 30840 30840 30840) + ("gray48" 31354 31354 31354) + ("grey48" 31354 31354 31354) + ("gray49" 32125 32125 32125) + ("grey49" 32125 32125 32125) + ("gray50" 32639 32639 32639) + ("grey50" 32639 32639 32639) + ("gray51" 33410 33410 33410) + ("grey51" 33410 33410 33410) + ("gray52" 34181 34181 34181) + ("grey52" 34181 34181 34181) + ("gray53" 34695 34695 34695) + ("grey53" 34695 34695 34695) + ("gray54" 35466 35466 35466) + ("grey54" 35466 35466 35466) + ("gray55" 35980 35980 35980) + ("grey55" 35980 35980 35980) + ("gray56" 36751 36751 36751) + ("grey56" 36751 36751 36751) + ("gray57" 37265 37265 37265) + ("grey57" 37265 37265 37265) + ("gray58" 38036 38036 38036) + ("grey58" 38036 38036 38036) + ("gray59" 38550 38550 38550) + ("grey59" 38550 38550 38550) + ("gray60" 39321 39321 39321) + ("grey60" 39321 39321 39321) + ("gray61" 40092 40092 40092) + ("grey61" 40092 40092 40092) + ("gray62" 40606 40606 40606) + ("grey62" 40606 40606 40606) + ("gray63" 41377 41377 41377) + ("grey63" 41377 41377 41377) + ("gray64" 41891 41891 41891) + ("grey64" 41891 41891 41891) + ("gray65" 42662 42662 42662) + ("grey65" 42662 42662 42662) + ("gray66" 43176 43176 43176) + ("grey66" 43176 43176 43176) + ("gray67" 43947 43947 43947) + ("grey67" 43947 43947 43947) + ("gray68" 44461 44461 44461) + ("grey68" 44461 44461 44461) + ("gray69" 45232 45232 45232) + ("grey69" 45232 45232 45232) + ("gray70" 46003 46003 46003) + ("grey70" 46003 46003 46003) + ("gray71" 46517 46517 46517) + ("grey71" 46517 46517 46517) + ("gray72" 47288 47288 47288) + ("grey72" 47288 47288 47288) + ("gray73" 47802 47802 47802) + ("grey73" 47802 47802 47802) + ("gray74" 48573 48573 48573) + ("grey74" 48573 48573 48573) + ("gray75" 49087 49087 49087) + ("grey75" 49087 49087 49087) + ("gray76" 49858 49858 49858) + ("grey76" 49858 49858 49858) + ("gray77" 50372 50372 50372) + ("grey77" 50372 50372 50372) + ("gray78" 51143 51143 51143) + ("grey78" 51143 51143 51143) + ("gray79" 51657 51657 51657) + ("grey79" 51657 51657 51657) + ("gray80" 52428 52428 52428) + ("grey80" 52428 52428 52428) + ("gray81" 53199 53199 53199) + ("grey81" 53199 53199 53199) + ("gray82" 53713 53713 53713) + ("grey82" 53713 53713 53713) + ("gray83" 54484 54484 54484) + ("grey83" 54484 54484 54484) + ("gray84" 54998 54998 54998) + ("grey84" 54998 54998 54998) + ("gray85" 55769 55769 55769) + ("grey85" 55769 55769 55769) + ("gray86" 56283 56283 56283) + ("grey86" 56283 56283 56283) + ("gray87" 57054 57054 57054) + ("grey87" 57054 57054 57054) + ("gray88" 57568 57568 57568) + ("grey88" 57568 57568 57568) + ("gray89" 58339 58339 58339) + ("grey89" 58339 58339 58339) + ("gray90" 58853 58853 58853) + ("grey90" 58853 58853 58853) + ("gray91" 59624 59624 59624) + ("grey91" 59624 59624 59624) + ("gray92" 60395 60395 60395) + ("grey92" 60395 60395 60395) + ("gray93" 60909 60909 60909) + ("grey93" 60909 60909 60909) + ("gray94" 61680 61680 61680) + ("grey94" 61680 61680 61680) + ("gray95" 62194 62194 62194) + ("grey95" 62194 62194 62194) + ("gray96" 62965 62965 62965) + ("grey96" 62965 62965 62965) + ("gray97" 63479 63479 63479) + ("grey97" 63479 63479 63479) + ("gray98" 64250 64250 64250) + ("grey98" 64250 64250 64250) + ("gray99" 64764 64764 64764) + ("grey99" 64764 64764 64764) + ("gray100" 65535 65535 65535) + ("grey100" 65535 65535 65535) + ("dark grey" 43433 43433 43433) + ("DarkGrey" 43433 43433 43433) + ("dark gray" 43433 43433 43433) + ("DarkGray" 43433 43433 43433) + ("dark blue" 0 0 35723) + ("DarkBlue" 0 0 35723) + ("dark cyan" 0 35723 35723) + ("DarkCyan" 0 35723 35723) + ("dark magenta" 35723 0 35723) + ("DarkMagenta" 35723 0 35723) + ("dark red" 35723 0 0) + ("DarkRed" 35723 0 0) + ("light green" 37008 61166 37008) + ("LightGreen" 37008 61166 37008)) ) + +(defvar hfy-rgb-txt-colour-map nil) + +(defvar hfy-rgb-load-path + (list "/etc/X11" + (format "/usr/share/emacs/%d.%d/etc" + emacs-major-version + emacs-minor-version) + "/usr/X11R6/lib/X11")) + +(defun hfy-rgb-file () + "Return a fully qualified path to the X11 style rgb.txt file." + (catch 'rgb-file + (mapcar + (lambda (DIR) + (let ((rgb-file (concat DIR "/rgb.txt"))) + (if (file-readable-p rgb-file) + (throw 'rgb-file rgb-file) nil)) ) hfy-rgb-load-path) nil)) + +(defconst hfy-rgb-regex + "^\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\(.+\\)\\s-*$") + +(defun htmlfontify-load-rgb-file (&optional file) + "Load an X11 style rgb.txt FILE. +Search `hfy-rgb-load-path' if FILE is not specified. +Loads the variable `hfy-rgb-txt-colour-map', which is used by +`hfy-fallback-colour-values'." + (interactive + (list + (read-file-name "rgb.txt \(equivalent\) file: " "" nil t (hfy-rgb-file)))) + (let ((rgb-buffer nil) + (end-of-rgb 0) + (rgb-txt nil) + (ff 255.0)) + (if (and (setq rgb-txt (or file (hfy-rgb-file))) + (file-readable-p rgb-txt)) + (save-excursion + (setq rgb-buffer (find-file-noselect rgb-txt 'nowarn)) + (set-buffer rgb-buffer) + (goto-char (point-min)) + (htmlfontify-unload-rgb-file) + (while (/= end-of-rgb 1) + (if (looking-at hfy-rgb-regex) + (setq hfy-rgb-txt-colour-map + (cons (list (match-string 4) + (string-to-int (match-string 1)) + (string-to-int (match-string 2)) + (string-to-int (match-string 3))) + hfy-rgb-txt-colour-map)) ) + (setq end-of-rgb (forward-line))) + (kill-buffer rgb-buffer)) + ) + ) + ) + +(defun htmlfontify-unload-rgb-file () + (interactive) + (setq hfy-rgb-txt-colour-map nil)) + +(defun hfy-fallback-colour-values (colour-string) + (cdr (assoc-ignore-case colour-string (or hfy-rgb-txt-colour-map + hfy-fallback-colour-map))) ) + +(provide 'hfy-cmap) +;;; hfy-cmap.el ends here +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/htmlfontify.el Thu Nov 19 20:21:01 2009 +0000 @@ -0,0 +1,2374 @@ +;;; htmlfontify.el --- htmlise a buffer/source tree with optional hyperlinks + +;; Copyright (C) 2002, 2003, 2009 Free Software Foundation, Inc. + +;; Emacs Lisp Archive Entry +;; Package: htmlfontify +;; Filename: htmlfontify.el +;; Version: 0.21 +;; Keywords: html, hypermedia, markup, etags +;; Author: Vivek Dasmohapatra <vivek@etla.org> +;; Maintainer: Vivek Dasmohapatra <vivek@etla.org> +;; Created: 2002-01-05 +;; Description: htmlise a buffer/source tree with optional hyperlinks +;; URL: http://rtfm.etla.org/emacs/htmlfontify/ +;; Compatibility: Emacs23, Emacs22 +;; Incompatibility: Emacs19, Emacs20, Emacs21 +;; Last Updated: Thu 2009-11-19 01:31:21 +0000 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; I have made some changes to make it work for Emacs 22. A lot of +;; small bug fixes related to the format of text and overlay +;; properties (which might have changed since the beginning of 2003 +;; when this file was originally written). +;; +;; The function `hfy-face-at' currently carries much of the burden of +;; my lacking understanding of the formats mentioned above and should +;; need some knowledgeable help. +;; +;; Another thing that maybe could be fixed is that overlay background +;; colors which are now only seen where there is text (in the XHTML +;; output). A bit of CSS tweaking is necessary there. +;; +;; The face 'default has a value :background "SystemWindow" for the +;; background color. There is no explicit notion that this should be +;; considered transparent, but I have assumed that it could be handled +;; like if it was here. (I am unsure that background and foreground +;; priorities are handled ok, but it looks ok in my tests now.) +;; +;; 2007-12-27 Lennart Borgman +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Here's some elisp code to html-pretty-print an Emacs buffer, preserving +;; the Emacs syntax/whatever highlighting. It also knows how to drive etags +;; (exuberant-ctags or Emacs etags) and hyperlink the code according +;; to its (etags') output. + +;; NOTE: Currently the hyperlinking code only knows how to drive GNU find +;; and the exuberant and GNU variants of etags : I do not know of any other +;; etags variants, but mechanisms have been provided to allow htmlfontify +;; to be taught how to drive them. As long as your version of find has +;; the -path test and is reasonably sane, you should be fine. + +;; A sample of the htmlfontified / hyperlinked output of this module can be +;; found at http://rtfm.etla.org/sql/dbishell/src/ - it's not perfect, but +;; it's a hell of a lot faster and more thorough than I could hope to be +;; doing this by hand. + +;; some user / horrified onlooker comments: +;; What? No! There's something deeply wrong here... (R. Shufflebotham) +;; You're a freak. (D. Silverstone) +;; Aren't we giving you enough to do? (J. Busuttil) +;; You're almost as messed up as Lexx is! (N. Graves-Morris) + +;;; History: +;; Changes: moved to changelog (CHANGES) file. + +;;; Code: +(eval-when-compile (require 'cl)) +(require 'faces) +;; (`facep' `face-attr-construct' `x-color-values' `color-values' `face-name') +(require 'custom) +;; (`defgroup' `defcustom') +(require 'font-lock) +;; (`font-lock-fontify-region') +(require 'cus-edit) + +(eval-and-compile + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; I want these - can't be bothered requiring all of cl though. + (if (not (fboundp 'caddr)) + (defun caddr (list) + "Return the `car' of the `cddr' of LIST." + (car (cddr list)))) + + (if (not (fboundp 'cadddr)) + (defun cadddr (list) + "Return the `cadr' of the `cddr' of LIST." + (cadr (cddr list)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (autoload + 'htmlfontify-load-rgb-file + "hfy-cmap" + "Load an rgb.txt file for colour name -> rgb translation purposes." + 'interactive) + + (autoload + 'htmlfontify-unload-rgb-file + "hfy-cmap" + "Unload the current colour name -> rgb translation map." + 'interactive) + + (autoload + 'hfy-fallback-colour-values + "hfy-cmap" + "Use a fallback method for obtaining the rgb values for a colour." + 'interactive) + ) + +(defconst htmlfontify-version 0.21) + +(defconst hfy-meta-tags + (format "<meta name=\"generator\" content=\"emacs %s; htmlfontify %0.2f\" />" + emacs-version htmlfontify-version) + "The generator meta tag for this version of htmlfontify.") + +(defconst htmlfontify-manual "Htmlfontify Manual" + "Copy and convert buffers and files to html, adding hyperlinks between files +\(driven by etags\) if requested. +\nInteractive functions: + `htmlfontify-buffer' + `htmlfontify-run-etags' + `htmlfontify-copy-and-link-dir' + `htmlfontify-load-rgb-file' + `htmlfontify-unload-rgb-file'\n +In order to:\n +fontify a file you have open: M-x htmlfontify-buffer +prepare the etags map for a directory: M-x htmlfontify-run-etags +copy a directory, fontifying as you go: M-x htmlfontify-copy-and-link-dir\n +The following might be useful when running non-windowed or in batch mode: +\(note that they shouldn't be necessary - we have a built in map\)\n +load an X11 style rgb.txt file: M-x htmlfontify-load-rgb-file +unload the current rgb.txt file: M-x htmlfontify-unload-rgb-file\n +And here's a programmatic example:\n +\(defun rtfm-build-page-header \(file style\) + \(format \"#define TEMPLATE red+black.html +#define DEBUG 1 +#include <build/menu-dirlist|>\\n +html-css-url := /css/red+black.css +title := rtfm.etla.org \( %s / src/%s \) +bodytag := +head <=STYLESHEET;\\n +%s +STYLESHEET +main-title := rtfm / %s / src/%s\\n +main-content <=MAIN_CONTENT;\\n\" rtfm-section file style rtfm-section file\)\) + +\(defun rtfm-build-page-footer \(file\) \"\\nMAIN_CONTENT\\n\"\) + +\(defun rtfm-build-source-docs \(section srcdir destdir\) + \(interactive + \"s section[eg- emacs / p4-blame]:\\nD source-dir: \\nD output-dir: \"\) + \(require 'htmlfontify\) + \(hfy-load-tags-cache srcdir\) + \(let \(\(hfy-page-header 'rtfm-build-page-header\) + \(hfy-page-footer 'rtfm-build-page-footer\) + \(rtfm-section section\) + \(hfy-index-file \"index\"\)\) + \(htmlfontify-run-etags srcdir\) + \(htmlfontify-copy-and-link-dir srcdir destdir \".src\" \".html\"\)\)\)") + +(defgroup htmlfontify nil + "Copy and convert buffers and files to html, adding hyperlinks between +files \(driven by etags\) if requested.\n +See: `htmlfontify-manual'" + :group 'applications + :prefix "hfy-") + +(defcustom hfy-page-header 'hfy-default-header + "*Function called with two arguments \(the filename relative to the top +level source directory being etag\'d and fontified), and a string containing +the <style>...</style> text to embed in the document- the string returned will +be used as the header for the htmlfontified version of the source file.\n +See also: `hfy-page-footer'" + :group 'htmlfontify + :tag "page-header" + :type '(function)) + +(defcustom hfy-split-index nil + "*Whether or not to split the index `hfy-index-file' alphabetically +on the first letter of each tag. Useful when the index would otherwise +be large and take a long time to render or be difficult to navigate." + :group 'htmlfontify + :tag "split-index" + :type '(boolean)) + +(defcustom hfy-page-footer 'hfy-default-footer + "*As `hfy-page-header', but generates the output footer +\(and takes only 1 argument, the filename\)." + :group 'htmlfontify + :tag "page-footer" + :type '(function)) + +(defcustom hfy-extn ".html" + "*File extension used for output files." + :group 'htmlfontify + :tag "extension" + :type '(string)) + +(defcustom hfy-src-doc-link-style "text-decoration: underline;" + "*String to add to the \'<style> a\' variant of an htmlfontify css class." + :group 'htmlfontify + :tag "src-doc-link-style" + :type '(string)) + +(defcustom hfy-src-doc-link-unstyle " text-decoration: none;" + "*Regex to remove from the <style> a variant of an htmlfontify css class." + :group 'htmlfontify + :tag "src-doc-link-unstyle" + :type '(string)) + +(defcustom hfy-link-extn nil + "*File extension used for href links - Useful where the htmlfontify +output files are going to be processed again, with a resulting change +in file extension. If nil, then any code using this should fall back +to `hfy-extn'." + :group 'htmlfontify + :tag "link-extension" + :type '(choice string (const nil))) + +(defcustom hfy-link-style-fun 'hfy-link-style-string + "*Set this to a function, which will be called with one argument +\(a \"{ foo: bar; ...}\" css style-string\) - it should return a copy of +its argument, altered so as to make any changes you want made for text which +is a hyperlink, in addition to being in the class to which that style would +normally be applied." + :group 'htmlfontify + :tag "link-style-function" + :type '(function)) + +(defcustom hfy-index-file "hfy-index" + "*Name \(sans extension\) of the tag definition index file produced during +fontification-and-hyperlinking." + :group 'htmlfontify + :tag "index-file" + :type '(string)) + +(defcustom hfy-instance-file "hfy-instance" + "*Name \(sans extension\) of the tag usage index file produced during +fontification-and-hyperlinking." + :group 'htmlfontify + :tag "instance-file" + :type '(string)) + +(defcustom hfy-html-quote-regex "\\(<\\|\"\\|&\\|>\\)" + "*Regex to match \(with a single back-reference per match\) strings in HTML +which should be quoted with `hfy-html-quote' \(and `hfy-html-quote-map'\) +to make them safe." + :group 'htmlfontify + :tag "html-quote-regex" + :type '(regexp)) + +(defcustom hfy-init-kludge-hooks '(hfy-kludge-cperl-mode) + "*List of functions to call when starting htmlfontify-buffer to do any +kludging necessary to get highlighting modes to bahave as you want, even +when not running under a window system." + :group 'htmlfontify + :tag "init-kludge-hooks" + :type '(hook)) + +(defcustom hfy-post-html-hooks nil + "*List of functions to call after creating and filling the html buffer. +These functions will be called with the html buffer as the current buffer" + :group 'htmlfontify + :tag "post-html-hooks" + :options '(set-auto-mode) + :type '(hook)) + +(defcustom hfy-default-face-def nil + "*Fallback `defface' specification for the face \'default, used when +`hfy-display-class' has been set \(the normal htmlfontify way of extracting +potentially non-current face information doesn\'t necessarily work for +\'default\).\n +Example: I customise this to:\n +\(\(t :background \"black\" :foreground \"white\" :family \"misc-fixed\"\)\)" + :group 'htmlfontify + :tag "default-face-definition" + :type '(alist)) + +(defcustom hfy-etag-regex (concat ".*" + "\x7f" "\\([^\x01\n]+\\)" + "\x01" "\\([0-9]+\\)" + "," "\\([0-9]+\\)$" + "\\|" ".*\x7f[0-9]+,[0-9]+$") + "*Regex used to parse an etags entry: must have 3 subexps, corresponding, +in order, to:\n + 1 - The tag + 2 - The line + 3 - The char \(point\) at which the tag occurs." + :group 'htmlfontify + :tag "etag-regex" + :type '(regexp)) + +(defcustom hfy-html-quote-map '(("\"" """) + ("<" "<" ) + ("&" "&" ) + (">" ">" )) + "*Alist of char -> entity mappings used to make the text html-safe." + :group 'htmlfontify + :tag "html-quote-map" + :type '(alist :key-type (string))) +(eval-and-compile + (defconst hfy-e2x-etags-cmd "for src in `find . -type f`; +do + ETAGS=%s; + case ${src} in + *.ad[absm]|*.[CFHMSacfhlmpsty]|*.def|*.in[cs]|*.s[as]|*.src|*.cc|\\ + *.hh|*.[chy]++|*.[ch]pp|*.[chy]xx|*.pdb|*.[ch]s|*.[Cc][Oo][Bb]|\\ + *.[eh]rl|*.f90|*.for|*.java|*.[cem]l|*.clisp|*.lisp|*.[Ll][Ss][Pp]|\\ + [Mm]akefile*|*.pas|*.[Pp][LlMm]|*.psw|*.lm|*.pc|*.prolog|*.oak|\\ + *.p[sy]|*.sch|*.scheme|*.[Ss][Cc][Mm]|*.[Ss][Mm]|*.bib|*.cl[os]|\\ + *.ltx|*.sty|*.TeX|*.tex|*.texi|*.texinfo|*.txi|*.x[bp]m|*.yy|\\ + *.[Ss][Qq][Ll]) + ${ETAGS} -o- ${src}; + ;; + *) + FTYPE=`file ${src}`; + case ${FTYPE} in + *script*text*) + ${ETAGS} -o- ${src}; + ;; + *text*) + SHEBANG=`head -n1 ${src} | grep '#!' -c`; + if [ ${SHEBANG} -eq 1 ]; + then + ${ETAGS} -o- ${src}; + fi; + ;; + esac; + ;; + esac; +done;") + + (defconst hfy-etags-cmd-alist-default + `(("emacs etags" . ,hfy-e2x-etags-cmd) + ("exuberant ctags" . "%s -R -f -" ))) + + (defcustom hfy-etags-cmd-alist + hfy-etags-cmd-alist-default + "*Alist of possible shell commands that will generate etags output that +`htmlfontify' can use. \'%s\' will be replaced by `hfy-etags-bin'." + :group 'htmlfontify + :tag "etags-cmd-alist" + :type '(alist :key-type (string) :value-type (string)) )) + +(defcustom hfy-etags-bin "etags" + "*Location of etags binary (we begin by assuming it\'s in your path).\n +Note that if etags is not in your path, you will need to alter the shell +commands in `hfy-etags-cmd-alist'." + :group 'htmlfontify + :tag "etags-bin" + :type '(file)) + +(defcustom hfy-shell-file-name "/bin/sh" + "*Shell (bourne or compatible) to invoke for complex shell operations." + :group 'htmlfontify + :tag "shell-file-name" + :type '(file)) + +(defun hfy-which-etags () + "Return a string indicating which flavour of etags we are using." + (let ((v (shell-command-to-string (concat hfy-etags-bin " --version")))) + (cond ((string-match "exube" v) "exuberant ctags") + ((string-match "GNU E" v) "emacs etags" )) )) + +(defcustom hfy-etags-cmd + (eval-and-compile (cdr (assoc (hfy-which-etags) hfy-etags-cmd-alist))) + "*The etags equivalent command to run in a source directory to generate a tags +file for the whole source tree from there on down. The command should emit +the etags output on stdout.\n +Two canned commands are provided - they drive Emacs\' etags and +exuberant-ctags\' etags respectively." + :group 'htmlfontify + :tag "etags-command" + :type (eval-and-compile + (let ((clist (list '(string)))) + (mapc + (lambda (C) + (setq clist + (cons (list 'const :tag (car C) (cdr C)) clist))) + hfy-etags-cmd-alist) + (cons 'choice clist)) )) + +(defcustom hfy-istext-command "file %s | sed -e 's@^[^:]*:[ \t]*@@'" + "*Command to run with the name of a file, to see whether it is a text file +or not. The command should emit a string containing the word \'text\' if +the file is a text file, and a string not containing \'text\' otherwise." + :group 'htmlfontify + :tag "istext-command" + :type '(string)) + +(defcustom hfy-find-cmd + "find . -type f \\! -name \\*~ \\! -name \\*.flc \\! -path \\*/CVS/\\*" + "*Find command used to harvest a list of files to attempt to fontify." + :group 'htmlfontify + :tag "find-command" + :type '(string)) + +(defcustom hfy-display-class nil + "*Display class to use to determine which display class to use when +calculating a face\'s attributes. This is useful when, for example, you +are running Emacs on a tty or in batch mode, and want htmlfontify to have +access to the face spec you would use if you were connected to an X display.\n +Some valid class specification elements are:\n + \'\(class color\) + \'\(class grayscale\) + \'\(background dark\) + \'\(background light\) + \'\(type x-toolkit\) + \'\(type tty\) + \'\(type motif\) + \'\(type lucid\) +Multiple values for a tag may be combined, to indicate that any one or more +of these values in the specification key constitutes a match, eg:\n +\'\(\(class color grayscale\) \(type tty\)\) would match any of:\n + \'\(\(class color\)\) + \'\(\(class grayscale\)\) + \'\(\(class color grayscale\)\)\) + \'\(\(class color foo\)\) + \'\(\(type tty\)\) + \'\(\(type tty\) \(class color\)\)\n +and so on." + :type '(alist :key-type (symbol) :value-type (symbol)) + :group 'htmlfontify + :tag "display-class" + :options '((type (choice (const :tag "X11" x-toolkit) + (const :tag "Terminal" tty ) + (const :tag "Lucid Toolkit" lucid ) + (const :tag "Motif Toolkit" motif ))) + + (class (choice (const :tag "Colour" color ) + (const :tag "Greyscale" grayscale))) + + (background (choice (const :tag "Dark" dark ) + (const :tag "Bright" light ))) )) + +(defcustom hfy-optimisations (list 'keep-overlays) + "*Optimisations to turn on: So far, the following have been implemented:\n + merge-adjacent-tags: If two (or more) span tags are adjacent, identical and + separated by nothing more than whitespace, they will + be merged into one span. + zap-comment-links : Suppress hyperlinking of tags found in comments. + zap-string-links : Suppress hyperlinking of tags found in strings. + div-wrapper : Add <div class=\"default\"> </div> tags around the + output. + keep-overlays : More of a bell \(or possibly whistle\) than an + optimisation - If on, preserve overlay highlighting + \(cf ediff or goo-font-lock\) as well as basic faces\n + And the following are planned but not yet available:\n + kill-context-leak : Suppress hyperlinking between files highlighted by + different modes.\n +Note: like compiler optimisations, these optimise the _output_ of the code, +not the processing of the source itself, and are therefore likely to slow +htmlfontify down, at least a little. Except for skip-refontification, +which can never slow you down, but may result in incomplete fontification." + :type '(set (const :tag "merge-adjacent-tags" merge-adjacent-tags ) + (const :tag "zap-comment-links" zap-comment-links ) + (const :tag "zap-string-links" zap-string-links ) + (const :tag "skip-refontification" skip-refontification) + (const :tag "kill-context-leak" kill-context-leak ) + (const :tag "div-wrapper" div-wrapper ) + (const :tag "keep-overlays" keep-overlays )) + :group 'htmlfontify + :tag "optimisations") + +(defvar hfy-tags-cache nil + "Alist of the form:\n +\(\(\"/src/dir/0\" . tag-hash0\) \(\"/src/dir/1\" tag-hash1\) ...\)\n +Each tag hash entry then contains entries of the form:\n +\"tag_string\" => ((\"file/name.ext\" line char) ... )\n +ie an alist mapping \(relative\) file paths to line and character offsets.\n +See `hfy-load-tags-cache'.") + +(defvar hfy-tags-sortl nil + "Alist of the form \(\(\"/src/dir\" . (tag0 tag1 tag2)\) ... \)\n +Where the tags are stored in descending order of length.\n +See `hfy-load-tags-cache'.") + +(defvar hfy-tags-rmap nil + "Alist of the form \(\(\"/src/dir\" . tag-rmap-hash\)\)\n +Where tag-rmap-hash has entries of the form: +\"tag_string\" => ( \"file/name.ext\" line char ) +Unlike `hfy-tags-cache' these are the locations of occurrences of +tagged items, not the locations of their definitions.") + +(defvar hfy-style-assoc 'please-ignore-this-line + "An assoc representing/describing an Emacs face. +Properties may be repeated, In which case later properties should be +treated as if they were inherited from a \'parent\' font. +\(For some properties, only the first encountered value is of any importance, +for others the values might be cumulative, and for others they might be +cumulative in a complex way).\n +Some examples:\n +\(hfy-face-to-style 'default\) => + \(\(\"background\" . \"rgb\(0, 0, 0\)\"\) + \(\"color\" . \"rgb\(255, 255, 255\)\"\) + \(\"font-style\" . \"normal\"\) + \(\"font-weight\" . \"500\"\) + \(\"font-stretch\" . \"normal\"\) + \(\"font-family\" . \"misc-fixed\"\) + \(\"font-size\" . \"13pt\"\) + \(\"text-decoration\" . \"none\"\)\)\n +\(hfy-face-to-style 'Info-title-3-face\) => + \(\(\"font-weight\" . \"700\"\) + \(\"font-family\" . \"helv\"\) + \(\"font-size\" . \"120%\"\) + \(\"text-decoration\" . \"none\"\)\)\n") + +(defvar hfy-sheet-assoc 'please-ignore-this-line + "An assoc with elements of the form (face-name style-name . stlye-string):\n +'\(\(default \"default\" . \"{background: black;color: white}\"\) + \(font-lock-string-face \"string\" . \"{color: rgb\(64,224,208\)}\"\)\)" ) + +(defvar hfy-facemap-assoc 'please-ignore-this-line + "An assoc of \(point . FACE-SYMBOL\) or \(point . DEFFACE-LIST\) +and (point . 'end) elements, in descending order of point value +\(ie from the file's end to its beginning\).\n +The map is in reverse order because inserting a <style> tag \(or any other +string) at POINT invalidates the map for all entries with a greater value of +point. By traversing the map from greatest to least POINT, we still invalidate +the map as we go, but only those points we have already dealt with \( and +therefore no longer care about \) will be invalid at any time.\n +'\(\(64820 . end\) + \(64744 . font-lock-comment-face\) + \(64736 . end\) + \(64722 . font-lock-string-face\) + \(64630 . end\) + \(64623 . font-lock-string-face\) + \(64449 . end\) + \(64446 . font-lock-keyword-face\) + \(64406 . end\) + \(64395 . font-lock-constant-face\) + \(64393 . end\) + \(64386 . font-lock-keyword-face\) + \(64379 . end\) + ;; big similar section elided. You get the idea. + \(4285 . font-lock-constant-face\) + \(4285 . end\) + \(4221 . font-lock-comment-face\) + \(4221 . end\) + \(4197 . font-lock-constant-face\) + \(4197 . end\) + \(1 . font-lock-comment-face\)\)") + +(defvar hfy-tmpfont-stack nil + "An alist of derived fonts resulting from overlays.") + +(defconst hfy-hex-regex "[0-9A-Fa-f]") + +(defconst hfy-triplet-regex + (concat + "\\(" hfy-hex-regex hfy-hex-regex "\\)" + "\\(" hfy-hex-regex hfy-hex-regex "\\)" + "\\(" hfy-hex-regex hfy-hex-regex "\\)")) + +(defun hfy-interq (set-a set-b) + "Return the intersection \(using `eq'\) of 2 lists SET-A and SET-B." + (let ((sa set-a) (interq nil) (elt nil)) + (while sa + (setq elt (car sa) + sa (cdr sa)) + (if (memq elt set-b) (setq interq (cons elt interq)))) interq)) + +(defun hfy-colour-vals (colour) + "Where COLOUR is a colour name or #XXXXXX style triplet, return a +list of 3 (16 bit) rgb values for said colour.\n +If a window system is unavailable, calls `hfy-fallback-colour-values'." + (if (string-match hfy-triplet-regex colour) + (mapcar + (lambda (x) + (* (string-to-number (match-string x colour) 16) 257)) '(1 2 3)) + ;;(message ">> %s" colour) + (if window-system + (if (fboundp 'color-values) + (color-values colour) + ;;(message "[%S]" window-system) + (x-color-values colour)) + ;; blarg - tty colours are no good - go fetch some X colours: + (hfy-fallback-colour-values colour)))) + +(defvar hfy-cperl-mode-kludged-p nil) + +(defun hfy-kludge-cperl-mode () + "CPerl mode does its damndest not to do some of its fontification when not +in a windowing system - try to trick it..." + (if (not hfy-cperl-mode-kludged-p) + (progn (if (not window-system) + (let ((window-system 'htmlfontify)) + (eval-and-compile (require 'cperl-mode)) + (setq cperl-syntaxify-by-font-lock t))) + (setq hfy-cperl-mode-kludged-p t))) ) + +(defun hfy-opt (symbol) "Is option SYMBOL set." (memq symbol hfy-optimisations)) + +(defun hfy-default-header (file style) + "Default value for `hfy-page-header'. +FILE is the name of the file. +STYLE is the inline CSS stylesheet (or tag referring to an external sheet)." +;; (format "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"> +;; <html>\n <head>\n <title>%s</title>\n %s\n </head>\n <body>\n" file style)) + (format "<?xml version=\"1.0\" encoding=\"utf-8\"?> +<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" +\"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\"> +<html xmlns=\"http://www.w3.org/1999/xhtml\"> + <head> + <title>%s</title> +%s + <script type=\"text/javascript\"><!-- + // this function is needed to work around + // a bug in IE related to element attributes + function hasClass(obj) + { + var result = false; + if (obj.getAttributeNode(\"class\") != null) + { + result = obj.getAttributeNode(\"class\").value; + } + return result; + } + + function stripe(id) + { + // the flag we'll use to keep track of + // whether the current row is odd or even + var even = false; + + // if arguments are provided to specify the colours + // of the even & odd rows, then use the them; + // otherwise use the following defaults: + var evenColor = arguments[1] ? arguments[1] : \"#fff\"; + var oddColor = arguments[2] ? arguments[2] : \"#ddd\"; + + // obtain a reference to the desired table + // if no such table exists, abort + var table = document.getElementById(id); + if (! table) { return; } + + // by definition, tables can have more than one tbody + // element, so we'll have to get the list of child + // <tbody>s + var tbodies = table.getElementsByTagName(\"tbody\"); + + // and iterate through them... + for (var h = 0; h < tbodies.length; h++) + { + // find all the <tr> elements... + var trs = tbodies[h].getElementsByTagName(\"tr\"); + + // ... and iterate through them + for (var i = 0; i < trs.length; i++) + { + // avoid rows that have a class attribute + // or backgroundColor style + if (! hasClass(trs[i]) && + ! trs[i].style.backgroundColor) + { + // get all the cells in this row... + var tds = trs[i].getElementsByTagName(\"td\"); + + // and iterate through them... + for (var j = 0; j < tds.length; j++) + { + var mytd = tds[j]; + + // avoid cells that have a class attribute + // or backgroundColor style + if (! hasClass(mytd) && + ! mytd.style.backgroundColor) + { + mytd.style.backgroundColor = + even ? evenColor : oddColor; + } + } + } + // flip from odd to even, or vice-versa + even = ! even; + } + } + } +--> </script> + </head> + <body onload=\"stripe('index'); return true;\">\n" + file style)) + +(defun hfy-default-footer (file) + "Default value for `hfy-page-footer'. +FILE is the name of the file being rendered, in case it is needed." + "\n </body>\n</html>\n") + +(defun hfy-link-style-string (style-string) + "Replace the end of a css style declaration STYLE-STRING with the contents +of the variable `hfy-src-doc-link-style', removing text matching the regex +`hfy-src-doc-link-unstyle' first, if necessary." + ;;(message "hfy-colour-vals");;DBUG + (if (string-match hfy-src-doc-link-unstyle style-string) + (setq style-string (replace-match "" 'fixed-case 'literal style-string))) + (if (and (not (string-match hfy-src-doc-link-style style-string)) + (string-match "} *$" style-string)) + (concat (replace-match hfy-src-doc-link-style + 'fixed-case + 'literal + style-string) " }") style-string)) + +;; utility functions - cast emacs style specification values into their +;; css2 equivalents: +(defun hfy-triplet (colour) + "Takes a COLOUR name \(string\) and return a CSS rgb(R, G, B) triplet string. +Uses the definition of \"white\" to map the numbers to the 0-255 range, so +if you\'ve redefined white, \(esp if you've redefined it to have a triplet +member lower than that of the colour you are processing, strange things +may happen\)." + ;;(message "hfy-colour-vals");;DBUG + (let ((white (mapcar (lambda (I) (float (1+ I))) (hfy-colour-vals "white"))) + (rgb16 (mapcar (lambda (I) (float (1+ I))) (hfy-colour-vals colour)))) + (if rgb16 + ;;(apply 'format "rgb(%d, %d, %d)" + ;; Use #rrggbb instead, it is smaller + (apply 'format "#%02x%02x%02x" + (mapcar (lambda (X) + (* (/ (nth X rgb16) + (nth X white)) 255)) '(0 1 2))))) ) + +(defun hfy-family (family) (list (cons "font-family" family))) +(defun hfy-bgcol (colour) (list (cons "background" (hfy-triplet colour)))) +(defun hfy-colour (colour) (list (cons "color" (hfy-triplet colour)))) +(defun hfy-width (width) (list (cons "font-stretch" (symbol-name width)))) + +(defcustom hfy-font-zoom 1.05 + "Font scaling from Emacs to HTML." + :type 'float + :group 'htmlfontify) + +(defun hfy-size (height) + "Derive a CSS font-size specifier from an Emacs font :height attribute HEIGHT. +Does not cope with the case where height is a function to be applied to +the height of the underlying font." + (list + (cond + ;;(t (cons "font-size" ": 1em")) + ((floatp height) + (cons "font-size" (format "%d%%" (* (* hfy-font-zoom height) 100)))) + ((integerp height) + (cons "font-size" (format "%dpt" (/ (* hfy-font-zoom height) 10 )))) )) ) + +(defun hfy-slant (slant) + "Derive a font-style css specifier from the Emacs :slant attribute SLANT: +CSS does not define the reverse-* styles, so just maps those to the +regular specifiers." + (list (cons "font-style" (cond ((eq 'italic slant) "italic" ) + ((eq 'reverse-italic slant) "italic" ) + ((eq 'oblique slant) "oblique") + ((eq 'reverse-oblique slant) "oblique") + (t "normal" )))) ) + +(defun hfy-weight (weight) + "Derive a font-weight css specifier from an Emacs weight spec symbol WEIGHT." + (list (cons "font-weight" (cond ((eq 'ultra-bold weight) "900") + ((eq 'extra-bold weight) "800") + ((eq 'bold weight) "700") + ((eq 'semi-bold weight) "600") + ((eq 'normal weight) "500") + ((eq 'semi-light weight) "400") + ((eq 'light weight) "300") + ((eq 'extra-light weight) "200") + ((eq 'ultra-light weight) "100")))) ) + +(defun hfy-box-to-border-assoc (spec) + (if spec + (let ((tag (car spec)) + (val (cadr spec))) + (cons (cond ((eq tag :color) (cons "colour" val)) + ((eq tag :width) (cons "width" val)) + ((eq tag :style) (cons "style" val))) + (hfy-box-to-border-assoc (cddr spec))))) ) + +(defun hfy-box-to-style (spec) + (let* ((css (hfy-box-to-border-assoc spec)) + (col (cdr (assoc "colour" css))) + (s (cdr (assoc "style" css)))) + (list + (if col (cons "border-color" (cdr (assoc "colour" css)))) + (cons "border-width" (format "%dpx" (or (cdr (assoc "width" css)) 1))) + (cons "border-style" (cond ((eq s 'released-button) "outset") + ((eq s 'pressed-button ) "inset" ) + (t "solid" ))))) ) + +(defun hfy-box (box) + "Derive CSS border-* attributes from the Emacs :box attribute BOX." + (if box + (cond + ((integerp box) (list (cons "border-width" (format "%dpx" box)))) + ((stringp box) (list (cons "border" (format "solid %s 1px" box)))) + ((listp box) (hfy-box-to-style box) ))) ) + +(defun hfy-decor (tag val) + "Derive CSS text-decoration specifiers from various Emacs font attributes. +TAG is an Emacs font attribute key (eg :underline). +VAL is ignored." + (list + (cond ((eq tag :underline ) (cons "text-decoration" "underline" )) + ((eq tag :overline ) (cons "text-decoration" "overline" )) + ((eq tag :strike-through) (cons "text-decoration" "line-through"))))) + +(defun hfy-invisible (&optional val) + "This text should be invisible. +Do something in CSS to make that happen. +VAL is ignored here." + '(("display" . "none"))) + +(defun hfy-combined-face-spec (face) + "Return a `defface' style alist of possible specifications for FACE. +Entries resulting from customisation \(`custom-set-faces'\) will take +precedence." + (let ((spec nil)) + (setq spec (append (or (get face 'saved-face) (list)) + (or (get face 'face-defface-spec) (list)))) + (if (and hfy-display-class hfy-default-face-def (eq face 'default)) + (setq spec (append hfy-default-face-def spec))) spec)) + +(defun hfy-face-attr-for-class (face &optional class) + "Return the face attributes for FACE. +If CLASS is set, it must be a `defface' alist key \[see below\], +in which case the first face specification returned by `hfy-combined-face-spec' +which *doesn\'t* clash with CLASS is returned.\n +\(A specification with a class of t is considered to match any class you +specify - this matches Emacs\' behaviour when deciding on which face attributes +to use, to the best of my understanding\).\n +If CLASS is nil, then you just get get whatever `face-attr-construct' returns, +ie the current specification in effect for FACE.\n +*NOTE* This function forces any face that is not \'default and which has +no :inherit property to inherit from \'default \( this is because \'default +is magical in that Emacs' fonts behave as if they inherit implicitly from +\'default, but no such behaviour exists in HTML/CSS \).\n +See `hfy-display-class' for details of valid values for CLASS." + (let ((face-spec nil)) + (setq + face-spec + (if class + (let ((face-props (hfy-combined-face-spec face)) + (face-specn nil) + (face-class nil) + (face-attrs nil) + (face-score -1) + (face-match nil)) + (while face-props + (setq face-specn (car face-props) + face-class (car face-specn) + face-attrs (cdr face-specn) + face-props (cdr face-props)) + ;; if the current element CEL of CLASS is t we match + ;; if the current face-class is t, we match + ;; if the cdr of CEL has a non-nil + ;; intersection with the cdr of the first member of + ;; the current face-class with the same car as CEL, we match + ;; if we actually clash, then we can't match + (let ((cbuf class) + (cel nil) + (key nil) + (val nil) + (x nil) + (next nil) + (score 0)) + (while (and cbuf (not next)) + (setq cel (car cbuf) + cbuf (cdr cbuf) + key (car cel) + val (cdr cel) + val (if (listp val) val (list val))) + (cond + ((or (eq cel t) (memq face-class '(t default)));;default match + (setq score 0) (ignore "t match")) + ((not (cdr (assq key face-class))) ;; neither good nor bad + nil (ignore "non match, non collision")) + ((setq x (hfy-interq val (cdr (assq key face-class)))) + (setq score (+ score (length x))) + (ignore "intersection")) + (t ;; nope. + (setq next t score -10) (ignore "collision")) )) + (if (> score face-score) + (progn + (setq face-match face-attrs + face-score score ) + (ignore "%d << %S/%S" score face-class class)) + (ignore "--- %d ---- (insufficient)" score)) )) + ;; matched ? last attrs : nil + (if face-match + (if (listp (car face-match)) (car face-match) face-match) nil)) + ;; Unfortunately the default face returns a + ;; :background. Fortunately we can remove it, but how do we do + ;; that in a non-system specific way? + (let ((spec (face-attr-construct face)) + (new-spec nil)) + (if (not (memq :background spec)) + spec + (while spec + (let ((a (nth 0 spec)) + (b (nth 1 spec))) + (unless (and (eq a :background) + (stringp b) + (string= b "SystemWindow")) + (setq new-spec (cons a (cons b new-spec))))) + (setq spec (cddr spec))) + new-spec)) )) + (if (or (memq :inherit face-spec) (eq 'default face)) + face-spec + (nconc face-spec (list :inherit 'default))) )) + +;; construct an assoc of (css-tag-name . css-tag-value) pairs +;; from a face or assoc of face attributes: + +;; Some tests etc: +;; (mumamo-message-with-face "testing face" 'highlight) +;; (mumamo-message-with-face "testing face" '(:foreground "red" :background "yellow")) +;; (hfy-face-to-style-i '(:inherit default foreground-color "red")) +;; default face=(:stipple nil :background "SystemWindow" :foreground +;; "SystemWindowText" :inverse-video nil :box nil :strike-through +;; nil :overline nil :underline nil :slant normal :weight normal +;; :height 98 :width normal :family "outline-courier new") +(defun hfy-face-to-style-i (fn) + "The guts of `hfy-face-to-style': FN should be a `defface' font spec, +as returned by `face-attr-construct' or `hfy-face-attr-for-class'. Note +that this function does not get font-sizes right if they are based on +inherited modifiers \(via the :inherit\) attribute, and any other +modifiers that are cumulative if they appear multiple times need to be +merged by the user - `hfy-flatten-style' should do this." + ;;(message "hfy-face-to-style-i");;DBUG + + ;; fn's value could be something like + ;; (:inherit + ;; ((foreground-color . "blue")) + ;; (foreground-color . "blue") + ;; nil) + + (when fn + (let ((key (car fn)) + (val (cadr fn)) + (next (cddr fn)) + (that nil) + (this nil) + (parent nil)) + (if (eq key :inherit) + (let ((vs (if (listp val) val (list val)))) + ;; (let ((x '(a b))) (setq x (append '(c d) x))) + ;; (let ((x '(a b))) (setq x (append '(c d) x))) + (dolist (v vs) + (setq parent + (append + parent + (hfy-face-to-style-i + (hfy-face-attr-for-class v hfy-display-class)) )))) + (setq this + (if val (cond + ((eq key :family ) (hfy-family val)) + ((eq key :width ) (hfy-width val)) + ((eq key :weight ) (hfy-weight val)) + ((eq key :slant ) (hfy-slant val)) + ((eq key :foreground ) (hfy-colour val)) + ((eq key :background ) (hfy-bgcol val)) + ((eq key :box ) (hfy-box val)) + ((eq key :height ) (hfy-size val)) + ((eq key :underline ) (hfy-decor key val)) + ((eq key :overline ) (hfy-decor key val)) + ((eq key :strike-through) (hfy-decor key val)) + ((eq key :invisible ) (hfy-invisible val)) + ((eq key :bold ) (hfy-weight 'bold)) + ((eq key :italic ) (hfy-slant 'italic)))))) + (setq that (hfy-face-to-style-i next)) + ;;(lwarn t :warning "%S => %S" fn (nconc this that parent)) + (nconc this that parent))) ) + +(defun hfy-size-to-int (spec) + "Convert SPEC, a css font-size specifier, back to an Emacs :height attribute +value. Used while merging multiple font-size attributes." + ;;(message "hfy-size-to-int");;DBUG + (list + (if (string-match "\\([0-9]+\\)\\(%\\|pt\\)" spec) + (cond ((string= "%" (match-string 2 spec)) + (/ (string-to-number (match-string 1 spec)) 100.0)) + ((string= "pt" (match-string 2 spec)) + (* (string-to-number (match-string 1 spec)) 10))) + (string-to-number spec))) ) + +;; size is different, in that in order to get it right at all, +;; we have to trawl the inheritance path, accumulating modifiers, +;; _until_ we get to an absolute (pt) specifier, then combine the lot +(defun hfy-flatten-style (style) + "Take STYLE (see `hfy-face-to-style-i', `hfy-face-to-style') and merge +any multiple attributes appropriately. Currently only font-size is merged +down to a single occurrence - others may need special handling, but I +haven\'t encountered them yet. Returns a `hfy-style-assoc'." + ;;(message "(hfy-flatten-style %S)" style) ;;DBUG + (let ((n 0) + (m (list 1)) + (x nil) + (r nil)) + (mapc + (lambda (css) + (if (string= (car css) "font-size") + (progn + (when (not x) (setq m (nconc m (hfy-size-to-int (cdr css))))) + (when (string-match "pt" (cdr css)) (setq x t))) + (setq r (nconc r (list css))) )) style) + ;;(message "r: %S" r) + (setq n (apply '* m)) + (nconc r (hfy-size (if x (round n) (* n 1.0)))) )) + +(defun hfy-face-to-style (fn) + "Take FN, a font or `defface' style font specification, +\(as returned by `face-attr-construct' or `hfy-face-attr-for-class'\) +and return a `hfy-style-assoc'.\n +See also: `hfy-face-to-style-i', `hfy-flatten-style'." + ;;(message "hfy-face-to-style");;DBUG + (let ((face-def (if (facep fn) + (hfy-face-attr-for-class fn hfy-display-class) fn)) + (final-style nil)) + + (setq final-style (hfy-flatten-style (hfy-face-to-style-i face-def))) + ;;(message "%S" final-style) + (if (not (assoc "text-decoration" final-style)) + (progn (setq final-style + ;; Fix-me: there is no need for this since + ;; text-decoration is not inherited. + ;; but it's not wrong and if this ever changes it will + ;; be needed, so I think it's better to leave it in? -- v + (nconc final-style '(("text-decoration"."none")))))) + final-style)) + +;; strip redundant bits from a name. Technically, this could result in +;; a collision, but it is pretty unlikely - will fix later... +;; also handle ephemeral fonts created by overlays, which don't actually +;; have names: +(defun hfy-face-or-def-to-name (fn) + "Render a font symbol or `defface' font spec FN into a name \(string\)." + ;;(message "generating name for %s" fn) + (if (not (listp fn)) + (format "%s" fn) + (let* ((key (format "%s" fn)) + (entry (assoc key hfy-tmpfont-stack)) + (base (cadr (memq :inherit fn))) + (tag (cdr entry))) + ;;(message "checking for key ยซ%sยป in font stack [%d]" + ;; key (if entry 1 0)) + (if entry nil ;; noop + (setq tag (format "%04d" (length hfy-tmpfont-stack)) + entry (cons key tag) + hfy-tmpfont-stack (cons entry hfy-tmpfont-stack))) + ;;(message " -> name: %s-%s" (or base 'default) tag) + (format "%s-%s" (or base 'default) tag)) )) + +(defun hfy-css-name (fn) + "Strip the boring bits from a font-name FN and return a CSS style name." + ;;(message "hfy-css-name");;DBUG + (let ((face-name (hfy-face-or-def-to-name fn))) + (if (or (string-match "font-lock-\\(.*\\)" face-name) + (string-match "cperl-\\(.*\\)" face-name) + (string-match "^[Ii]nfo-\\(.*\\)" face-name)) + (progn + (setq face-name (match-string 1 face-name)) + (if (string-match "\\(.*\\)-face$" face-name) + (setq face-name (match-string 1 face-name))) face-name) + face-name)) ) + +;; construct an assoc of (stripped-name . "{ css-stuff-here }") pairs +;; from a face: +(defun hfy-face-to-css (fn) + "Take FN, a font or `defface' specification \(cf `face-attr-construct'\) +and return a CSS style specification.\n +See also: `hfy-face-to-style'" + ;;(message "hfy-face-to-css");;DBUG + (let ((css-list nil) + (css-text nil) + (style nil) + (seen nil)) + ;;(message "(hfy-face-to-style %S)" fn) + (setq css-list (hfy-face-to-style fn)) + (setq css-text + (nconc + (mapcar + (lambda (E) + (if (car E) + (if (not (member (car E) seen)) + (progn + (setq seen (cons (car E) seen)) + (format " %s: %s; " (car E) (cdr E)))))) css-list))) + (cons (hfy-css-name fn) (format "{%s}" (apply 'concat css-text)))) ) + +;; extract a face from a list of char properties, if there is one: +(defun hfy-p-to-face (props) + "Given PROPS, a list of text-properties, return the value of the face +property, or nil." + (if props + (if (string= (car props) "face") + (let ((propval (cadr props))) + (if (and (listp propval) (not (cdr propval))) + (car propval) + propval)) + (hfy-p-to-face (cddr props))) + nil)) + +(defun hfy-p-to-face-lennart (props) + "Given PROPS, a list of text-properties, return the value of the face +property, or nil." + (when props + (let ((face (plist-get props 'face)) + (font-lock-face (plist-get props 'font-lock-face)) + (button (plist-get props 'button)) + ;;(face-rec (memq 'face props)) + ;;(button-rec (memq 'button props))) + ) + (if button + (let* ((category (plist-get props 'category)) + (face (when category (plist-get (symbol-plist category) 'face)))) + face) + (if font-lock-face + font-lock-face + face))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (defun hfy-get-face-at (pos) +;; ;; (let ((face (get-char-property-and-overlay pos 'face))) +;; ;; (when (and face (listp face)) (setq face (car face))) +;; ;; (unless (listp face) +;; ;; face))) +;; ;;(get-char-property pos 'face) +;; ;; Overlays are handled later +;; (if (or (not show-trailing-whitespace) +;; (not (get-text-property pos 'hfy-show-trailing-whitespace))) +;; (get-text-property pos 'face) +;; (list 'trailing-whitespace (get-text-property pos 'face))) +;; ) + +(defun hfy-prop-invisible-p (prop) + "Is text property PROP an active invisibility property?" + (or (and (eq buffer-invisibility-spec t) prop) + (or (memq prop buffer-invisibility-spec) + (assq prop buffer-invisibility-spec)))) + +(defun hfy-find-invisible-ranges () + "Return a list of (start-point . end-point) cons cells of invisible regions." + (let (invisible p i e s) ;; return-value pos invisible end start + (save-excursion + (setq p (goto-char (point-min))) + (when (invisible-p p) (setq s p i t)) + (while (< p (point-max)) + (if i ;; currently invisible + (when (not (invisible-p p)) ;; but became visible + (setq e p + i nil + invisible (cons (cons s e) invisible))) + ;; currently visible: + (when (invisible-p p) ;; but have become invisible + (setq s p i t))) + (setq p (next-char-property-change p))) + ;; still invisible at buffer end? + (when i + (setq e (point-max) + invisible (cons (cons s e) invisible))) ) invisible)) + +(defun hfy-invisible-name (point map) + "Generate a CSS style name for an invisible section of the buffer. +POINT is the point inside the invisible region. +MAP is the invisibility map as returned by `hfy-find-invisible-ranges'." + ;;(message "(hfy-invisible-name %S %S)" point map) + (let (name) + (mapc + (lambda (range) + (when (and (>= point (car range)) + (< point (cdr range))) + (setq name (format "invisible-%S-%S" (car range) (cdr range))))) map) + name)) + +;; Fix-me: This function needs some cleanup by someone who understand +;; all the formats that face properties can have. +;; +;; overlay handling should be fine. haven't tested multiple stacked overlapping +;; overlays recently, but the common case of a text property face + an overlay +;; face produces the correct merged css style (or as close to it as css can get) +;; -- v +(defun hfy-face-at (p) + "Find face in effect at point P. +If overlays are to be considered \(see `hfy-optimisations'\) then this may +return a defface style list of face properties instead of a face symbol." + ;;(message "hfy-face-at");;DBUG + ;; Fix-me: clean up, remove face-name etc + ;; not sure why we'd want to remove face-name? -- v + (let ((overlay-data nil) + (base-face nil) + ;; restored hfy-p-to-face as it handles faces like (bold) as + ;; well as face like 'bold - hfy-get-face-at doesn't dtrt -- v + (face-name (hfy-p-to-face (text-properties-at p))) + ;; (face-name (hfy-get-face-at p)) + (prop-seen nil) + (found-face nil) + (extra-props nil) + (text-props (text-properties-at p))) + ;;(message "face-name: %S" face-name) + (when (and face-name (listp face-name) (facep (car face-name))) + ;;(message "face-name is a list %S" face-name) + ;;(setq text-props (cons 'face face-name)) + (dolist (f face-name) + (if (listp f) ;; for things like (variable-pitch (:foreground "red")) + (setq extra-props (cons f extra-props)) + (setq extra-props (cons :inherit (cons f extra-props))))) + (setq face-name nil)) + ;; text-properties-at => (face (:foreground "red" ...)) + ;; or => (face (compilation-info underline)) list of faces + ;; overlay-properties + ;; format= (evaporate t face ((foreground-color . "red"))) + + ;; SO: if we have turned overlays off, + ;; or if there's no overlay data + ;; just bail out and return whatever face data we've accumulated so far + (if (or (not (hfy-opt 'keep-overlays)) + (not (setq overlay-data (hfy-overlay-props-at p)))) + (progn + ;;(message "ยท %d: %s; %S; %s" + ;; p face-name extra-props text-props) + face-name) ;; no overlays or extra properties + ;; collect any face data and any overlay data for processing: + (when text-props + (setq overlay-data (cons text-props overlay-data))) + (setq overlay-data (nreverse overlay-data)) + ;;(message "- %d: %s; %S; %s; %s" + ;; p face-name extra-props text-props overlay-data) + ;; remember the basic face name so we don't keep repeating its specs: + (when face-name (setq base-face face-name)) + (mapc + (lambda (P) + (let ((iprops (cadr (memq 'invisible P)))) + ;;(message "(hfy-prop-invisible-p %S)" iprops) + (when (hfy-prop-invisible-p iprops) + (setq extra-props + (cons :invisible (cons t extra-props))) )) + (let ((fprops (cadr (or (memq 'face P) + (memq 'font-lock-face P))))) + ;;(message "overlay face: %s" fprops) + (if (not (listp fprops)) + (let ((this-face (if (stringp fprops) (intern fprops) fprops))) + (when (not (eq this-face base-face)) + (setq extra-props + (cons :inherit + (cons this-face extra-props))) )) + (while fprops + (if (facep (car fprops)) + (let ((face (car fprops))) + (when (stringp face) (setq face (intern fprops))) + (setq extra-props + (cons :inherit + (cons face + extra-props))) + (setq fprops (cdr fprops))) + (let (p v) + ;; Sigh. + (if (listp (car fprops)) + (if (nlistp (cdr (car fprops))) + (progn + ;; ((prop . val)) + (setq p (caar fprops)) + (setq v (cdar fprops)) + (setq fprops (cdr fprops))) + ;; ((prop val)) + (setq p (caar fprops)) + (setq v (cadar fprops)) + (setq fprops (cdr fprops))) + (if (listp (cdr fprops)) + (progn + ;; (:prop val :prop val ...) + (setq p (car fprops)) + (setq v (cadr fprops)) + (setq fprops (cddr fprops))) + (if (and (listp fprops) + (not (listp (cdr fprops)))) + ;;(and (consp x) (cdr (last x))) + (progn + ;; (prop . val) + (setq p (car fprops)) + (setq v (cdr fprops)) + (setq fprops nil)) + (error "Eh... another format! fprops=%s" fprops) ))) + (setq p (case p + ;; These are all the properties handled + ;; in `hfy-face-to-style-i'. + ;; + ;; Are these translations right? + ;; yes, they are -- v + ('family :family ) + ('width :width ) + ('height :height ) + ('weight :weight ) + ('slant :slant ) + ('underline :underline ) + ('overline :overline ) + ('strike-through :strike-through) + ('box :box ) + ('foreground-color :foreground) + ('background-color :background) + ('bold :bold ) + ('italic :italic ) + (t p))) + (if (memq p prop-seen) nil ;; noop + (setq prop-seen (cons p prop-seen) + found-face t + extra-props (cons p (cons v extra-props)))) )))))) + overlay-data) + ;;(message "+ %d: %s; %S" p face-name extra-props) + (if extra-props + (if (listp face-name) + (nconc extra-props face-name) + (nconc extra-props (face-attr-construct face-name))) + face-name)) )) + +(defun hfy-overlay-props-at (p) + "Grab overlay properties at point P. +The plists are returned in descending priority order." + (sort (mapcar (lambda (O) (overlay-properties O)) (overlays-at p)) + (lambda (A B) (> (or (cadr (memq 'priority A)) 0) + (or (cadr (memq 'priority B)) 0)) ) ) ) + +;; construct an assoc of (face-name . (css-name . "{ css-style }")) elements: +(defun hfy-compile-stylesheet () + "Trawl the current buffer, construct and return a `hfy-sheet-assoc'." + ;;(message "hfy-compile-stylesheet");;DBUG + (let ((pt (point-min)) + ;; Make the font stack stay: + ;;(hfy-tmpfont-stack nil) + (fn nil) + (css nil) + (style nil)) + (save-excursion + (goto-char pt) + (while (< pt (point-max)) + (if (and (setq fn (hfy-face-at pt)) (not (assoc fn style))) + (setq style (cons (cons fn (hfy-face-to-css fn)) style))) + (setq pt (next-char-property-change pt))) ) + (setq style (cons (cons 'default (hfy-face-to-css 'default)) style))) ) + +(defun hfy-fontified-p () + "`font-lock' doesn't like to say it\'s been fontified when in batch +mode, but we want to know if we should fontify or raw copy, so in batch +mode we check for non-default face properties. Otherwise we test +variable `font-lock-mode' and variable `font-lock-fontified' for truth." + ;;(message "font-lock-fontified: %S" font-lock-fontified) + ;;(message "noninteractive : %S" noninteractive) + ;;(message "font-lock-mode : %S" font-lock-mode) + (and font-lock-fontified + (if noninteractive + (let ((pt (point-min)) + (face-name nil)) + (save-excursion + (goto-char pt) + (while (and (< pt (point-max)) (not face-name)) + (setq face-name (hfy-face-at pt)) + (setq pt (next-char-property-change pt)))) face-name) + font-lock-mode))) + +;; remember, the map is in reverse point order: +;; I wrote this while suffering the effects of a cold, and maybe a +;; mild fever - I think it's correct, but it might be a little warped +;; as my minfd keeps ... where was I? Oh yes, the bunnies... +(defun hfy-merge-adjacent-spans (face-map) + "Where FACE-MAP is a `hfy-facemap-assoc' for the current buffer, +this function merges adjacent style blocks which are of the same value +and are separated by nothing more interesting than whitespace.\n + <span class=\"foo\">narf</span> <span class=\"foo\">brain</span>\n +\(as interpreted from FACE-MAP\) would become:\n + <span class=\"foo\">narf brain</span>\n +Returns a modified copy of FACE-MAP." + (let ((tmp-map face-map) + (map-buf nil) + (first-start nil) + (first-stop nil) + (last-start nil) + (last-stop nil) + (span-stop nil) + (span-start nil) + (reduced-map nil)) + ;;(setq reduced-map (cons (car tmp-map) reduced-map)) + ;;(setq reduced-map (cons (cadr tmp-map) reduced-map)) + (while tmp-map + (setq first-start (cadddr tmp-map) + first-stop (caddr tmp-map) + last-start (cadr tmp-map) + last-stop (car tmp-map) + map-buf tmp-map + span-start last-start + span-stop last-stop ) + (while (and (equal (cdr first-start) + (cdr last-start)) + (save-excursion + (goto-char (car first-stop)) + (not (re-search-forward "[^ \t\n\r]" (car last-start) t)))) + (setq map-buf (cddr map-buf) + span-start first-start + first-start (cadddr map-buf) + first-stop (caddr map-buf) + last-start (cadr map-buf) + last-stop (car map-buf))) + (setq reduced-map (cons span-stop reduced-map)) + (setq reduced-map (cons span-start reduced-map)) + (setq tmp-map (memq last-start tmp-map)) + (setq tmp-map (cdr tmp-map))) + (setq reduced-map (nreverse reduced-map)))) + +;; remember to generate 'synthetic' </span> entries - +;; emacs copes by just having a stack of styles in effect +;; and only using the top one: html has a more simplistic approach - +;; we have to explicitly end a style, there's no way of temporarily +;; overriding it w. another one... (afaik) +(defun hfy-compile-face-map () +;; no need for special <a> version. +;; IME hyperlinks don't get underlined, esp when you htmlfontify a whole +;; source tree, so the <a> version is needed -- v +;; Fix-me: save table for multi-buffer + "Compile and return a `hfy-facemap-assoc' for the current buffer." + ;;(message "hfy-compile-face-map");;DBUG + (let ((pt (point-min)) + (pt-narrow 1) + (fn nil) + (map nil) + (prev-tag nil)) ;; t if the last tag-point was a span-start + ;; nil if it was a span-stop + (save-excursion + (goto-char pt) + (while (< pt (point-max)) + (if (setq fn (hfy-face-at pt)) + (progn (if prev-tag (setq map (cons (cons pt-narrow 'end) map))) + (setq map (cons (cons pt-narrow fn) map)) + (setq prev-tag t)) + (if prev-tag (setq map (cons (cons pt-narrow 'end) map))) + (setq prev-tag nil)) + (setq pt (next-char-property-change pt)) + (setq pt-narrow (1+ (- pt (point-min))))) + (if (and map (not (eq 'end (cdar map)))) + (setq map (cons (cons (- (point-max) (point-min)) 'end) map)))) + (if (hfy-opt 'merge-adjacent-tags) (hfy-merge-adjacent-spans map) map))) + +(defun hfy-buffer () + "Generate a buffer to hold the html output. +The filename of this buffer is derived from the source \(current\) buffer\'s +variable `buffer-file-name', if it is set, plus `hfy-extn'. +Otherwise a plausible filename is constructed from `default-directory', +`buffer-name' and `hfy-extn'." + (let* ((name (concat (buffer-name) hfy-extn)) + (src (buffer-file-name)) + (buf (get-buffer-create name))) + (save-excursion + (set-buffer buf) + (if src (setq buffer-file-name (concat src hfy-extn)) + (if (string-match "^.*/\\([^/]*\\)$" name) + (setq buffer-file-name + (concat default-directory "/" (match-string 1 name))) + (setq buffer-file-name (concat default-directory "/" name) ))) + buf))) + +(defun hfy-lookup (face style) + "Get a CSS style name for FACE from STYLE." + (cadr (assoc face style))) + +(defun hfy-link-style (style-string) + "Copy, alter and return a STYLE-STRING to make it suitable for a hyperlink. +Uses `hfy-link-style-fun' to do this." + (if (functionp hfy-link-style-fun) + (funcall hfy-link-style-fun style-string) + style-string)) + +(defun hfy-sprintf-stylesheet (css file) + "Return the inline CSS style sheet for FILE as a string." + (let ((stylesheet nil)) + (setq stylesheet + (concat + hfy-meta-tags + "\n<style type=\"text/css\"><!-- \n" + ;; Fix-me: Add handling of page breaks here + scan for ^L + ;; where appropriate. + (format "body %s\n" (cddr (assq 'default css))) + (apply 'concat + (mapcar + (lambda (style) + (format + "span.%s %s\nspan.%s a %s\n" + (cadr style) (cddr style) + (cadr style) (hfy-link-style (cddr style)))) css)) + " --></style>\n")) + (funcall hfy-page-header file stylesheet))) + +(defconst hfy-javascript " + <script type=\"text/javascript\"> + // <![CDATA[ +function toggle_invis( name ) +{ + var filter = + { acceptNode: + function( node ) + { var classname = node.id; + if( classname ) + { var classbase = classname.substr( 0, name.length ); + if( classbase == name ) { return NodeFilter.FILTER_ACCEPT; } } + return NodeFilter.FILTER_SKIP; } }; + var walker = document.createTreeWalker( document.body , + NodeFilter.SHOW_ELEMENT , + filter , + false ); + while( walker.nextNode() ) + { + var e = walker.currentNode; + if( e.style.display == \"none\" ) { e.style.display = \"inline\"; } + else { e.style.display = \"none\"; } + } +} + // ]]> + </script>\n") + +;; tag all the dangerous characters we want to escape +;; (ie any "<> chars we _didn't_ put there explicitly for css markup) +(defun hfy-html-enkludge-buffer () + "Mark dangerous [\"\<\>] characters with the \'hfy-quoteme property.\n +See also `hfy-html-dekludge-buffer'." + ;;(message "hfy-html-enkludge-buffer");;DBUG + (save-excursion + (goto-char (point-min)) + (while (re-search-forward hfy-html-quote-regex nil t) + (put-text-property (match-beginning 0) (point) 'hfy-quoteme t))) ) + +;; dangerous char -> &entity; +(defun hfy-html-quote (char-string) + "Map CHAR-STRING to an html safe string (entity) if need be." + ;;(message "hfy-html-quote");;DBUG + (or (cadr (assoc char-string hfy-html-quote-map)) char-string) ) + +;; actually entity-ise dangerous chars. +;; note that we can't do this until _after_ we have inserted the css +;; markup, since we use a position-based map to insert this, and if we +;; enter any other text before we do this, we'd have to track another +;; map of offsets, which would be tedious... +(defun hfy-html-dekludge-buffer () + "Transform all dangerous characters marked with the \'hfy-quoteme property +using `hfy-html-quote'\n +See also `hfy-html-enkludge-buffer'." + ;;(message "hfy-html-dekludge-buffer");;DBUG + (save-excursion + (goto-char (point-min)) + (while (re-search-forward hfy-html-quote-regex nil t) + (if (get-text-property (match-beginning 0) 'hfy-quoteme) + (replace-match (hfy-html-quote (match-string 1))) )) )) + +;; Borrowed from font-lock.el +(defmacro hfy-save-buffer-state (varlist &rest body) + "Bind variables according to VARLIST and eval BODY restoring buffer state. +Do not record undo information during evaluation of BODY." + (declare (indent 1) (debug let)) + (let ((modified (make-symbol "modified"))) + `(let* ,(append varlist + `((,modified (buffer-modified-p)) + (buffer-undo-list t) + (inhibit-read-only t) + (inhibit-point-motion-hooks t) + (inhibit-modification-hooks t) + deactivate-mark + buffer-file-name + buffer-file-truename)) + (progn + ,@body) + (unless ,modified + (restore-buffer-modified-p nil))))) + +(defun hfy-mark-trailing-whitespace () + "Tag trailing whitespace with a hfy property if it is currently highlighted." + (when show-trailing-whitespace + (let ((inhibit-read-only t)) + (save-excursion + (goto-char (point-min)) + (hfy-save-buffer-state nil + (while (re-search-forward "[ \t]+$" nil t) + (put-text-property (match-beginning 0) (match-end 0) + 'hfy-show-trailing-whitespace t))))))) + +(defun hfy-unmark-trailing-whitespace () + "Undo the effect of `hfy-mark-trailing-whitespace'." + (when show-trailing-whitespace + (hfy-save-buffer-state nil + (remove-text-properties (point-min) (point-max) + '(hfy-show-trailing-whitespace))))) + +(defun hfy-fontify-buffer (&optional srcdir file) + "Implement the guts of `htmlfontify-buffer'. +SRCDIR, if set, is the directory being htmlfontified. +FILE, if set, is the file name." + (if srcdir (setq srcdir (directory-file-name srcdir))) + (let* ( (in-style nil) + (invis-buttons nil) + (orig-buffer (current-buffer)) + (html-buffer (hfy-buffer)) + (css-sheet nil) + (css-map nil) + (invis-ranges nil) + (rovl nil) + (orig-ovls (overlays-in (point-min) (point-max))) + (rmin (when mark-active (region-beginning))) + (rmax (when mark-active (region-end ))) ) + (when (and mark-active + transient-mark-mode) + (unless (and (= rmin (point-min)) + (= rmax (point-max))) + (setq rovl (make-overlay rmin rmax)) + (overlay-put rovl 'priority 1000) + (overlay-put rovl 'face 'region))) + ;; copy the buffer, including fontification, and switch to it: + (hfy-mark-trailing-whitespace) + (setq css-sheet (hfy-compile-stylesheet ) + css-map (hfy-compile-face-map ) + invis-ranges (hfy-find-invisible-ranges)) + (hfy-unmark-trailing-whitespace) + (when rovl + (delete-overlay rovl)) + (copy-to-buffer html-buffer (point-min) (point-max)) + (set-buffer html-buffer) + ;; Apply overlay invisible spec + (setq orig-ovls + (sort orig-ovls + (lambda (A B) + (> (or (cadr (memq 'priority (overlay-properties A))) 0) + (or (cadr (memq 'priority (overlay-properties B))) 0))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; at this point, html-buffer retains the fontification of the parent: + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; we don't really need or want text in the html buffer to be invisible, as + ;; that can make it look like we've rendered invalid xhtml when all that's + ;; happened is some tags are in the invisible portions of the buffer: + (setq buffer-invisibility-spec nil) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; ##################################################################### + ;; if we are in etags mode, add properties to mark the anchors and links + (if (and srcdir file) + (progn + (hfy-mark-tag-names srcdir file) ;; mark anchors + (hfy-mark-tag-hrefs srcdir file))) ;; mark links + ;; ##################################################################### + ;; mark the 'dangerous' characters + ;;(message "marking dangerous characters") + (hfy-html-enkludge-buffer) + ;; trawl the position-based face-map, inserting span tags as we go + ;; note that we cannot change any character positions before this point + ;; or we will invalidate the map: + ;; NB: This also means we have to trawl the map in descending file-offset + ;; order, obviously. + ;; --------------------------------------------------------------------- + ;; Remember, inserting pushes properties to the right, which we don't + ;; actually want to happen for link properties, so we have to flag + ;; them and move them by hand - if you don't, you end up with + ;; + ;; <span class="foo"><a href="bar">texta</span><span class="bletch"></a>... + ;; + ;; instead of: + ;; + ;; <span class="foo"><a href="bar">texta</a></span><span class="bletch">... + ;; + ;; If my analysis of the problem is correct, we can detect link-ness by + ;; either hfy-linkp or hfy-endl properties at the insertion point, but I + ;; think we only need to relocate the hfy-endl property, as the hfy-linkp + ;; property has already served its main purpose by this point. + ;;(message "mapcar over the CSS-MAP") + (message "invis-ranges:\n%S" invis-ranges) + (mapc + (lambda (point-face) + (let ((pt (car point-face)) + (fn (cdr point-face)) + (move-link nil)) + (goto-char pt) + (setq move-link + (or (get-text-property pt 'hfy-linkp) + (get-text-property pt 'hfy-endl ))) + (if (eq 'end fn) + (insert "</span>") + (if (not (and srcdir file)) + nil + (when move-link + (remove-text-properties (point) (1+ (point)) '(hfy-endl nil)) + (put-text-property pt (1+ pt) 'hfy-endl t) )) + ;; if we have invisible blocks, we need to do some extra magic: + (if invis-ranges + (let ((iname (hfy-invisible-name pt invis-ranges)) + (fname (hfy-lookup fn css-sheet ))) + (when (assq pt invis-ranges) + (insert + (format "<span onclick=\"toggle_invis('%s');\">" iname)) + (insert "โฆ</span>")) + (insert + (format "<span class=\"%s\" id=\"%s-%d\">" fname iname pt))) + (insert (format "<span class=\"%s\">" (hfy-lookup fn css-sheet)))) + (if (not move-link) nil + ;;(message "removing prop2 @ %d" (point)) + (if (remove-text-properties (point) (1+ (point)) '(hfy-endl nil)) + (put-text-property pt (1+ pt) 'hfy-endl t))) ))) + css-map) + ;; ##################################################################### + ;; Invisibility + ;; Maybe just make the text invisible in XHTML? + ;; DONE -- big block of obsolete invisibility code elided here -- v + ;; ##################################################################### + ;; (message "checking to see whether we should link...") + (if (and srcdir file) + (let ((lp 'hfy-link) + (pt nil) + (pr nil) + (rr nil)) + ;; (message " yes we should.") + ;; translate 'hfy-anchor properties to anchors + (setq pt (point-min)) + (while (setq pt (next-single-property-change pt 'hfy-anchor)) + (if (setq pr (get-text-property pt 'hfy-anchor)) + (progn (goto-char pt) + (remove-text-properties pt (1+ pt) '(hfy-anchor nil)) + (insert (concat "<a name=\"" pr "\"></a>"))))) + ;; translate alternate 'hfy-link and 'hfy-endl props to opening + ;; and closing links. (this should avoid those spurious closes + ;; we sometimes get by generating only paired tags) + (setq pt (point-min)) + (while (setq pt (next-single-property-change pt lp)) + (if (not (setq pr (get-text-property pt lp))) nil + (goto-char pt) + (remove-text-properties pt (1+ pt) (list lp nil)) + (cond + ((eq lp 'hfy-link) + (if (setq rr (get-text-property pt 'hfy-inst)) + (insert (format "<a name=\"%s\"></a>" rr))) + (insert (format "<a href=\"%s\">" pr)) + (setq lp 'hfy-endl)) + ((eq lp 'hfy-endl) + (insert "</a>") (setq lp 'hfy-link)) ))) )) + + ;; ##################################################################### + ;; transform the dangerous chars. This changes character positions + ;; since entities have > char length. + ;; note that this deletes the dangerous characters, and therefore + ;; destroys any properties they may contain (such as 'hfy-endl), + ;; so we have to do this after we use said properties: + ;; (message "munging dangerous characters") + (hfy-html-dekludge-buffer) + ;; insert the stylesheet at the top: + (goto-char (point-min)) + ;;(message "inserting stylesheet") + (insert (hfy-sprintf-stylesheet css-sheet file)) + (insert hfy-javascript) + (if (hfy-opt 'div-wrapper) (insert "<div class=\"default\">")) + (insert "\n<pre>") + (goto-char (point-max)) + (insert "</pre>\n") + (if (hfy-opt 'div-wrapper) (insert "</div>")) + ;;(message "inserting footer") + (insert (funcall hfy-page-footer file)) + ;; call any post html-generation hooks: + (run-hooks 'hfy-post-html-hooks) + ;; return the html buffer + (set-buffer-modified-p nil) + html-buffer)) + +(defun hfy-force-fontification () + "Try to force font-locking even when it is optimised away." + (mapc (lambda (fun) (funcall fun)) hfy-init-kludge-hooks) + (eval-and-compile (require 'font-lock)) + (if (boundp 'font-lock-cache-position) + (or font-lock-cache-position + (set 'font-lock-cache-position (make-marker)))) + (if (not noninteractive) + (progn + (message "hfy interactive mode (%S %S)" window-system major-mode) + (when (and font-lock-defaults + font-lock-mode) + (font-lock-fontify-region (point-min) (point-max) nil))) + (message "hfy batch mode (%s:%S)" + (or (buffer-file-name) (buffer-name)) major-mode) + (when font-lock-defaults + (font-lock-fontify-buffer)) )) + +(defun htmlfontify-buffer (&optional srcdir file) + "Create a new buffer, named for the current buffer + a .html extension, +containing an inline css-stylesheet and formatted css-markup html +that reproduces the look of the current Emacs buffer as closely +as possible. + +Dangerous characters in the existing buffer are turned into html +entities, so you should even be able to do html-within-html +fontified display. + +You should, however, note that random control or eight-bit +characters such as ^L (\x0c) or ยค (\xa4) won't get mapped yet. + +If the SRCDIR and FILE arguments are set, lookup etags derived +entries in the `hfy-tags-cache' and add html anchors and +hyperlinks as appropriate." + (interactive) + ;; pick up the file name in case we didn't receive it + (if (not file) + (progn (setq file (or (buffer-file-name) (buffer-name))) + (if (string-match "/\\([^/]*\\)$" file) + (setq file (match-string 1 file)))) ) + + (if (not (hfy-opt 'skip-refontification)) + (save-excursion ;; Keep region + (hfy-force-fontification))) + (if (interactive-p) ;; display the buffer in interactive mode: + (switch-to-buffer (hfy-fontify-buffer srcdir file)) + (hfy-fontify-buffer srcdir file))) + +;; recursive file listing +(defun hfy-list-files (directory) + "Return a list of files under DIRECTORY. +Strips any leading \"./\" from each filename." + ;;(message "hfy-list-files");;DBUG + (cd directory) + (mapcar (lambda (F) (if (string-match "^./\\(.*\\)" F) (match-string 1 F) F)) + (split-string (shell-command-to-string hfy-find-cmd))) ) + +;; strip the filename off, return a directiry name +;; not a particularly thorough implementaion, but it will be +;; fed pretty carefully, so it should be Ok: +(defun hfy-dirname (file) + "Return everything preceding the last \"/\" from a relative filename FILE, +on the assumption that this will produce a relative directory name. Hardly +bombproof, but good enough in the context in which it is being used." + ;;(message "hfy-dirname");;DBUG + (let ((f (directory-file-name file))) + (and (string-match "^\\(.*\\)/" f) (match-string 1 f)))) + +;; create a directory, cf mkdir -p +(defun hfy-make-directory (dir) + "Approx equivalent of mkdir -p DIR." + ;;(message "hfy-make-directory");;DBUG + (if (file-exists-p dir) + (if (file-directory-p dir) t) + (make-directory dir t))) + +(defun hfy-text-p (srcdir file) + "Is SRCDIR/FILE text? Uses `hfy-istext-command' to determine this." + (let (cmd rsp) + (setq cmd (format hfy-istext-command (concat srcdir "/" file)) + rsp (shell-command-to-string cmd)) + (if (string-match "text" rsp) t nil))) + +;; open a file, check fontification, if fontified, write a fontified copy +;; to the destination directory, otherwise just copy the file: +(defun hfy-copy-and-fontify-file (srcdir dstdir file) + "Open FILE in SRCDIR - if fontified, write a fontified copy to DSTDIR +adding an extension of `hfy-extn'. Fontification is actually done by +`htmlfontify-buffer'. If the buffer is not fontified, just copy it." + ;;(message "hfy-copy-and-fontify-file");;DBUG + (let (;;(fast-lock-minimum-size hfy-fast-lock-save) + ;;(font-lock-support-mode 'fast-lock-mode) + ;;(window-system (or window-system 'htmlfontify)) + (target nil) + (source nil) + (html nil)) + (cd srcdir) + (save-excursion + (setq source (find-file-noselect file)) + (set-buffer source) + (setq target (concat dstdir "/" file)) + (hfy-make-directory (hfy-dirname target)) + (if (not (hfy-opt 'skip-refontification)) (hfy-force-fontification)) + (if (or (hfy-fontified-p) (hfy-text-p srcdir file)) + (progn (setq html (hfy-fontify-buffer srcdir file)) + (set-buffer html) + (write-file (concat target hfy-extn)) + (kill-buffer html)) + ;; #o0200 == 128, but emacs20 doesn't know that + (if (and (file-exists-p target) (not (file-writable-p target))) + (set-file-modes target (logior (file-modes target) 128))) + (copy-file (buffer-file-name source) target 'overwrite)) + (kill-buffer source)) )) + +;; list of tags in file in srcdir +(defun hfy-tags-for-file (srcdir file) + "List of etags tags that have definitions in this FILE. +Looks up the tags cache in `hfy-tags-cache' using SRCDIR as the key." + ;;(message "hfy-tags-for-file");;DBUG + (let ((cache-entry (assoc srcdir hfy-tags-cache)) + (cache-hash nil) + (tag-list nil)) + (if (setq cache-hash (cadr cache-entry)) + (maphash + (lambda (K V) + (if (assoc file V) + (setq tag-list (cons K tag-list)))) cache-hash)) + tag-list)) + +;; mark the tags native to this file for anchors +(defun hfy-mark-tag-names (srcdir file) + "Mark tags in FILE (lookup SRCDIR in `hfy-tags-cache') with the \'hfy-anchor +property, with a value of \"tag.line-number\"." + ;;(message "(hfy-mark-tag-names %s %s)" srcdir file);;DBUG + (let ((cache-entry (assoc srcdir hfy-tags-cache)) + (cache-hash nil)) + (if (setq cache-hash (cadr cache-entry)) + (mapcar + (lambda (TAG) + (mapcar + (lambda (TLIST) + (if (string= file (car TLIST)) + (let* ((line (cadr TLIST) ) + (chr (caddr TLIST) ) + (link (format "%s.%d" TAG line) )) + (put-text-property (+ 1 chr) + (+ 2 chr) + 'hfy-anchor link)))) + (gethash TAG cache-hash))) + (hfy-tags-for-file srcdir file))))) + +(defun hfy-relstub (file &optional start) + "Return a \"../\" stub of the appropriate length for the current source +tree depth \(as determined from FILE \(a filename\)\). +START is the offset at which to start looking for the / character in FILE." + ;;(message "hfy-relstub");;DBUG + (let ((c "")) + (while (setq start (string-match "/" file start)) + (setq start (1+ start)) (setq c (concat c "../"))) c)) + +(defun hfy-href-stub (this-file def-files tag) + "Return an href stub for a tag href i THIS-FILE: +If DEF-FILES \(list of files containing definitions for the tag in question\) +contains only one entry, the href should link straight to that file. +Otherwise, the link should be to the index file.\n +We are not yet concerned with the file extensions/tag line number and so on at +this point.\n +If `hfy-split-index' is set, and the href wil be to an index file rather than +a source file, append a .X to `hfy-index-file', where X is the uppercased +first character of TAG.\n +See also: `hfy-relstub', `hfy-index-file'`'." + ;;(message "hfy-href-stub");;DBUG + (concat + (hfy-relstub this-file) + (if (= 1 (length def-files)) (car def-files) + (if (not hfy-split-index) hfy-index-file + (concat hfy-index-file "." (upcase (substring tag 0 1)))))) ) + +(defun hfy-href (this-file def-files tag tag-map) + "Return a relative href to the tag in question, based on\n +THIS-FILE `hfy-link-extn' `hfy-extn' DEF-FILES TAG and TAG-MAP\n +THIS-FILE is the current source file +DEF-FILES is a list of file containing possible link endpoints for TAG +TAG is the TAG in question +TAG-MAP is the entry in `hfy-tags-cache'." + ;;(message "hfy-href");;DBUG + (concat + (hfy-href-stub this-file def-files tag) + (or hfy-link-extn hfy-extn) "#" tag ;;(.src -> .html) + (if (= 1 (length def-files)) + (concat "." (format "%d" (cadr (assoc (car def-files) tag-map)))))) ) + +(defun hfy-word-regex (string) + "Return a regex that matches STRING as the first `match-string', with non +word characters on either side." + (concat "[^$A-Za-z_0-9]\\(" (regexp-quote string) "\\)[^A-Za-z_0-9]")) + +;; mark all tags for hyperlinking, except the tags at +;; their own points of definition, iyswim: +(defun hfy-mark-tag-hrefs (srcdir file) + "Mark href start points with the \'hfy-link prop \(value: href string\)\n +Mark href end points with the \'hfy-endl prop \(value t\)\n +Avoid overlapping links, and mark links in descending length of +tag name in order to prevent subtags from usurping supertags, +\(eg \"term\" for \"terminal\"). +SRCDIR is the directory being \"published\". +FILE is the specific file we are rendering." + ;;(message "hfy-mark-tag-hrefs");;DBUG + (let ((cache-entry (assoc srcdir hfy-tags-cache)) + (list-cache (assoc srcdir hfy-tags-sortl)) + (rmap-cache (assoc srcdir hfy-tags-rmap )) + (no-comment (hfy-opt 'zap-comment-links)) + (no-strings (hfy-opt 'zap-string-links )) + (cache-hash nil) + (tags-list nil) + (tags-rmap nil) + (case-fold-search nil)) + ;; extract the tag mapping hashes (fwd and rev) and the tag list: + (if (and (setq cache-hash (cadr cache-entry)) + (setq tags-rmap (cadr rmap-cache )) + (setq tags-list (cadr list-cache ))) + (mapcar + (lambda (TAG) + (let* ((start nil) + (stop nil) + (href nil) + (name nil) + (case-fold-search nil) + (tmp-point nil) + (maybe-start nil) + (face-at nil) + (rmap-entry nil) + (rnew-elt nil) + (rmap-line nil) + (tag-regex (hfy-word-regex TAG)) + (tag-map (gethash TAG cache-hash)) + (tag-files (mapcar (lambda (X) (car X)) tag-map))) + ;; find instances of TAG and do what needs to be done: + (goto-char (point-min)) + (while (search-forward TAG nil 'NOERROR) + (setq tmp-point (point) + maybe-start (- (match-beginning 0) 1)) + (goto-char maybe-start) + (if (not (looking-at tag-regex)) + nil + (setq start (match-beginning 1)) + (setq stop (match-end 1)) + (setq face-at + (and (or no-comment no-strings) (hfy-face-at start))) + (if (listp face-at) + (setq face-at (cadr (memq :inherit face-at)))) + (if (or (text-property-any start (1+ stop) 'hfy-linkp t) + (and no-comment (eq 'font-lock-comment-face face-at)) + (and no-strings (eq 'font-lock-string-face face-at))) + nil ;; already a link, NOOP + + ;; set a reverse map entry: + (setq rmap-line (line-number-at-pos) + rmap-entry (gethash TAG tags-rmap) + rnew-elt (list file rmap-line start) + rmap-entry (cons rnew-elt rmap-entry) + name (format "%s.%d" TAG rmap-line)) + (put-text-property start (1+ start) 'hfy-inst name) + (puthash TAG rmap-entry tags-rmap) + + ;; mark the link. link to index if the tag has > 1 def + ;; add the line number to the #name if it does not: + (setq href (hfy-href file tag-files TAG tag-map)) + (put-text-property start (1+ start) 'hfy-link href) + (put-text-property stop (1+ stop ) 'hfy-endl t ) + (put-text-property start (1+ stop ) 'hfy-linkp t ))) + (goto-char tmp-point)) )) + tags-list) ))) + +(defun hfy-shell () + "Return `shell-file-name', or \"/bin/sh\" if it is a non-bourne shell." + (if (string-match "\\<bash\\>\\|\\<sh\\>\\|\\<dash\\>" shell-file-name) + shell-file-name + (or hfy-shell-file-name "/bin/sh"))) + +;; cache the #(tag => file line point) entries for files under srcdir +;; and cache the descending sorted list of tags in the relevant alist, +;; also keyed by srcdir: +(defun hfy-load-tags-cache (srcdir) + "Run `hfy-etags-cmd' on SRCDIR, then call `hfy-parse-tags-buffer'." + ;;(message "hfy-load-tags-cache");;DBUG + (let ((etags-buffer (get-buffer-create "*hfy-tags*")) + (etags-command (format hfy-etags-cmd hfy-etags-bin)) + (shell-file-name (hfy-shell))) + (cd srcdir) + (shell-command etags-command etags-buffer) + (hfy-parse-tags-buffer srcdir etags-buffer)) ) + +;; break this out from `hfy-load-tags-cache' to make the tar file +;; functionality easier to implement. +;; ( tar file functionality not merged here because it requires a +;; hacked copy of etags capable of tagging stdin: if Francesco +;; Potorti accepts a patch, or otherwise implements stdin tagging, +;; then I will provide a `htmlfontify-tar-file' defun ) +(defun hfy-parse-tags-buffer (srcdir buffer) + "Parse a BUFFER containing etags formatted output, loading the +`hfy-tags-cache' and `hfy-tags-sortl' entries for SRCDIR." + (let ((cache-entry (assoc srcdir hfy-tags-cache)) + (tlist-cache (assoc srcdir hfy-tags-sortl)) + (trmap-cache (assoc srcdir hfy-tags-rmap )) + (cache-hash nil) (trmap-hash nil) (tags-list nil) + (hash-entry nil) (tag-string nil) (tag-line nil) + (tag-point nil) (new-entry nil) (etags-file nil)) + + ;; (re)initialise the tag reverse map: + (if trmap-cache (setq trmap-hash (cadr trmap-cache)) + (setq trmap-hash (make-hash-table :test 'equal)) + (setq hfy-tags-rmap (list (list srcdir trmap-hash) hfy-tags-rmap))) + (clrhash trmap-hash) + + ;; (re)initialise the tag cache: + (if cache-entry (setq cache-hash (cadr cache-entry)) + (setq cache-hash (make-hash-table :test 'equal)) + (setq hfy-tags-cache (list (list srcdir cache-hash) hfy-tags-cache))) + (clrhash cache-hash) + + ;; cache the TAG => ((file line point) (file line point) ... ) entries: + (save-excursion + (set-buffer buffer) + (goto-char (point-min)) + + (while (and (looking-at "^\x0c") (= 0 (forward-line 1))) + ;;(message "^L boundary") + (if (and (looking-at "^\\(.+\\),\\([0-9]+\\)$") + (= 0 (forward-line 1))) + (progn + (setq etags-file (match-string 1)) + ;;(message "TAGS for file: %s" etags-file) + (while (and (looking-at hfy-etag-regex) (= 0 (forward-line 1))) + (setq tag-string (match-string 1)) + (if (= 0 (length tag-string)) nil ;; noop + (setq tag-line (round (string-to-number (match-string 2)))) + (setq tag-point (round (string-to-number (match-string 3)))) + (setq hash-entry (gethash tag-string cache-hash)) + (setq new-entry (list etags-file tag-line tag-point)) + (setq hash-entry (cons new-entry hash-entry)) + ;;(message "HASH-ENTRY %s %S" tag-string new-entry) + (puthash tag-string hash-entry cache-hash)))) ))) + + ;; cache a list of tags in descending length order: + (maphash (lambda (K V) (setq tags-list (cons K tags-list))) cache-hash) + (setq tags-list (sort tags-list (lambda (A B) (< (length B) (length A))))) + + ;; put the tag list into the cache: + (if tlist-cache (setcar (cdr tlist-cache) tags-list) + (setq hfy-tags-sortl (cons (list srcdir tags-list) hfy-tags-sortl))) + + ;; return the number of tags found: + (length tags-list) )) + +(defun hfy-prepare-index-i (srcdir dstdir filename &optional stub map) + "Prepare a tags index buffer for SRCDIR. +`hfy-tags-cache' must already have an entry for SRCDIR for this to work. +`hfy-page-header', `hfy-page-footer', `hfy-link-extn' and `hfy-extn' +all play a part here.\n +If STUB is set, prepare an \(appropriately named\) index buffer +specifically for entries beginning with STUB.\n +If MAP is set, use that instead of `hfy-tags-cache'. +FILENAME is the name of the file being indexed. +DSTDIR is the output directory, where files will be written." + ;;(message "hfy-write-index");;DBUG + (let ((cache-entry (assoc srcdir (or map hfy-tags-cache))) + (cache-hash nil) + (tag-list nil) + (index-file + (concat filename (if stub (concat "." stub) "") hfy-extn)) + (index-buf nil)) + (if (not (and cache-entry + (setq cache-hash (cadr cache-entry)) + (setq index-buf (get-buffer-create index-file)))) + nil ;; noop + (maphash (lambda (K V) (setq tag-list (cons K tag-list))) cache-hash) + (setq tag-list (sort tag-list 'string<)) + (set-buffer index-buf) + (erase-buffer) + (insert (funcall hfy-page-header filename "<!-- CSS -->")) + (insert "<table class=\"index\">\n") + + (mapc + (lambda (TAG) + (let ((tag-started nil)) + (mapc + (lambda (DEF) + (if (and stub (not (string-match (concat "^" stub) TAG))) + nil ;; we have a stub and it didn't match: NOOP + (let ((file (car DEF)) + (line (cadr DEF))) + (insert + (format + (concat + " <tr> \n" + " <td>%s</td> \n" + " <td><a href=\"%s%s\">%s</a></td> \n" + " <td><a href=\"%s%s#%s.%d\">%d</a></td>\n" + " </tr> \n") + (if (string= TAG tag-started) " " + (format "<a name=\"%s\">%s</a>" TAG TAG)) + file (or hfy-link-extn hfy-extn) file + file (or hfy-link-extn hfy-extn) TAG line line)) + (setq tag-started TAG)))) + (gethash TAG cache-hash)))) tag-list) + (insert "</table>\n") + (insert (funcall hfy-page-footer filename)) + (and dstdir (cd dstdir)) + (set-visited-file-name index-file) + index-buf) )) + +(defun hfy-prepare-index (srcdir dstdir) + "Return a list of index buffer\(s\), as determined by `hfy-split-index'. +SRCDIR and DSTDIR are the source and output directories respectively." + (if (not hfy-split-index) + (list (hfy-prepare-index-i srcdir dstdir hfy-index-file nil)) + (let ((stub-list nil) + (cache-hash nil) + (index-list nil) + (cache-entry (assoc srcdir hfy-tags-cache))) + (if (and cache-entry (setq cache-hash (cadr cache-entry))) + (maphash + (lambda (K V) + (let ((stub (upcase (substring K 0 1)))) + (if (member stub stub-list) + nil ;; seen this already: NOOP + (setq + stub-list (cons stub stub-list) + index-list (cons (hfy-prepare-index-i srcdir + dstdir + hfy-index-file + stub) + index-list)) ))) cache-hash) ) index-list))) + +(defun hfy-prepare-tag-map (srcdir dstdir) + "Prepare the counterpart\(s\) to the index buffer\(s\) - a list of buffers +with the same structure, but listing \( and linking to \) instances of tags +\( as opposed to their definitions \).\n +SRCDIR and DSTDIR are the source and output directories respectively. +See: `hfy-prepare-index' + `hfy-split-index'." + (if (not hfy-split-index) + (list (hfy-prepare-index-i srcdir + dstdir + hfy-instance-file + nil + hfy-tags-rmap)) + (let ((stub-list nil) + (cache-hash nil) + (index-list nil) + (cache-entry (assoc srcdir hfy-tags-rmap))) + + (if (and cache-entry (setq cache-hash (cadr cache-entry))) + (maphash + (lambda (K V) + (let ((stub (upcase (substring K 0 1)))) + (if (member stub stub-list) + nil ;; seen this already: NOOP + (setq + stub-list (cons stub stub-list) + index-list (cons (hfy-prepare-index-i srcdir + dstdir + hfy-instance-file + stub + hfy-tags-rmap) + index-list)) ))) cache-hash) ) index-list))) + +(defun hfy-subtract-maps (srcdir) + "Internal function - strips definitions of tags from the instance map. +SRCDIR is the directory being \"published\". +See: `hfy-tags-cache' and `hfy-tags-rmap'" + (let ((new-list nil) + (old-list nil) + (def-list nil) + (exc-list nil) + (fwd-map (cadr (assoc srcdir hfy-tags-cache))) + (rev-map (cadr (assoc srcdir hfy-tags-rmap ))) + (taglist (cadr (assoc srcdir hfy-tags-sortl)))) + (mapc + (lambda (TAG) + (setq def-list (gethash TAG fwd-map) + old-list (gethash TAG rev-map) + new-list nil + exc-list nil) + (mapc + (lambda (P) + (setq exc-list (cons (list (car P) (cadr P)) exc-list))) def-list) + (mapc + (lambda (P) + (or (member (list (car P) (cadr P)) exc-list) + (setq new-list (cons P new-list)))) old-list) + (puthash TAG new-list rev-map)) taglist) )) + +(defun htmlfontify-run-etags (srcdir) + "Load the etags cache for SRCDIR. +See `hfy-load-tags-cache'." + (interactive "D source directory: ") + (setq srcdir (directory-file-name srcdir)) + (hfy-load-tags-cache srcdir)) + +;;(defun hfy-test-read-args (foo bar) +;; (interactive "D source directory: \nD target directory: ") +;; (message "foo: %S\nbar: %S" foo bar)) + +(defun hfy-save-kill-buffers (buffer-list &optional dstdir) + (mapc (lambda (B) + (set-buffer B) + (and dstdir (file-directory-p dstdir) (cd dstdir)) + (save-buffer) + (kill-buffer B)) buffer-list) ) + +(defun htmlfontify-copy-and-link-dir (srcdir dstdir &optional f-ext l-ext) + "Trawl SRCDIR and write fontified-and-hyperlinked output in DSTDIR. +F-EXT and L-EXT specify values for `hfy-extn' and `hfy-link-extn'.\n +You may also want to set `hfy-page-header' and `hfy-page-footer'." + (interactive "D source directory: \nD output directory: ") + ;;(message "htmlfontify-copy-and-link-dir") + (setq srcdir (directory-file-name srcdir)) + (setq dstdir (directory-file-name dstdir)) + (let ((source-files "SETME: list of source files, relative to srcdir") + (tr-cache (assoc srcdir hfy-tags-rmap)) + (hfy-extn (or f-ext ".html")) + (hfy-link-extn (or l-ext ".html"))) + ;; oops, forgot to load etags for srcdir: + (if tr-cache nil + (message "autoload of tags cache") + (hfy-load-tags-cache srcdir) + (setq tr-cache (assoc srcdir hfy-tags-rmap))) + ;; clear out the old cache: + (clrhash (cadr tr-cache)) + (hfy-make-directory dstdir) + (setq source-files (hfy-list-files srcdir)) + (mapc (lambda (file) + (hfy-copy-and-fontify-file srcdir dstdir file)) source-files) + (hfy-subtract-maps srcdir) + (hfy-save-kill-buffers (hfy-prepare-index srcdir dstdir) dstdir) + (hfy-save-kill-buffers (hfy-prepare-tag-map srcdir dstdir) dstdir) )) + +;; name of the init file we want: +(defun hfy-initfile () + "Return the expected location of the htmlfontify specific init/custom file." + (let* ((file (or (getenv "HFY_INITFILE") ".hfy.el"))) + (expand-file-name file "~") )) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; incomplete as yet : transfer hook settings to hfy init file: +;; (defalias 'hfy-set-hooks 'custom-set-variables) + +;; (defun hfy-pp-hook (H) +;; (and (string-match "-hook$" (symbol-name H)) +;; (boundp H) +;; (symbol-value H) +;; (insert (format "\n '(%S %S)" H (symbol-value H))) +;; ) +;; ) + +;; (defun hfy-save-hooks () +;; (let ((custom-file (hfy-initfile))) +;; (custom-save-delete 'hfy-set-hooks) +;; (let ((standard-output (current-buffer))) +;; (princ "(hfy-set-hooks\n;;auto-generated, only one copy allowed\n") +;; (mapatoms 'hfy-pp-hook) +;; (insert "\n)") +;; ) +;; ) +;; ) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defalias 'hfy-init-progn 'progn) + +(defun hfy-save-initvar (sym) + (princ (format "(setq %s\n '" sym)) + (pp (symbol-value sym)) + (princ ")\n")) + +(defun htmlfontify-save-initfile () + "Save the htmlfontify settings to the htmlfontify init file." + (interactive) + (let* ((start-pos nil) + (custom-file (hfy-initfile)) + (standard-output (find-file-noselect custom-file 'nowarn))) + (save-excursion + (custom-save-delete 'hfy-init-progn) + (setq start-pos (point)) + (princ "(hfy-init-progn\n;;auto-generated, only one copy allowed\n") + (mapc 'hfy-save-initvar + (list 'auto-mode-alist 'interpreter-mode-alist)) + (princ ")\n") + (indent-region start-pos (point) nil)) + (custom-save-all) )) + +(defun htmlfontify-load-initfile () + "Load the htmlfontify specific init/custom file." + (interactive) + (let ((file (hfy-initfile))) + (load file 'NOERROR nil nil) )) + +(provide 'htmlfontify) +;;; htmlfontify.el ends here +