htmlfontify.el 102 KB
Newer Older
Paul Eggert's avatar
Paul Eggert committed
1
;;; htmlfontify.el --- htmlize a buffer/source tree with optional hyperlinks
Stefan Monnier's avatar
Stefan Monnier committed
2

3
;; Copyright (C) 2002-2003, 2009-2013 Free Software Foundation, Inc.
Stefan Monnier's avatar
Stefan Monnier committed
4 5 6 7 8 9 10 11 12

;; 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
Paul Eggert's avatar
Paul Eggert committed
13
;; Description: htmlize a buffer/source tree with optional hyperlinks
Stefan Monnier's avatar
Stefan Monnier committed
14 15 16 17
;; URL: http://rtfm.etla.org/emacs/htmlfontify/
;; Compatibility: Emacs23, Emacs22
;; Incompatibility: Emacs19, Emacs20, Emacs21
;; Last Updated: Thu 2009-11-19 01:31:21 +0000
18
;; Version: 0.21
Stefan Monnier's avatar
Stefan Monnier committed
19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101

;; 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)

(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"
102 103
  "Copy and convert buffers and files to HTML, adding hyperlinks between files
\(driven by etags) if requested.
Stefan Monnier's avatar
Stefan Monnier committed
104 105 106 107 108 109 110
\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
111 112 113
fontify a file you have open:           \\[htmlfontify-buffer]
prepare the etags map for a directory:  \\[htmlfontify-run-etags]
copy a directory, fontifying as you go: \\[htmlfontify-copy-and-link-dir]\n
Stefan Monnier's avatar
Stefan Monnier committed
114
The following might be useful when running non-windowed or in batch mode:
115
\(note that they shouldn't be necessary - we have a built in map)\n
116 117
load an X11 style rgb.txt file:         \\[htmlfontify-load-rgb-file]
unload the current rgb.txt file:        \\[htmlfontify-unload-rgb-file]\n
Stefan Monnier's avatar
Stefan Monnier committed
118
And here's a programmatic example:\n
119 120
\(defun rtfm-build-page-header (file style)
  (format \"#define  TEMPLATE red+black.html
Stefan Monnier's avatar
Stefan Monnier committed
121 122 123
#define  DEBUG    1
#include <build/menu-dirlist|>\\n
html-css-url := /css/red+black.css
124
title        := rtfm.etla.org ( %s / src/%s )
Stefan Monnier's avatar
Stefan Monnier committed
125 126 127 128 129
bodytag      :=
head         <=STYLESHEET;\\n
%s
STYLESHEET
main-title   := rtfm / %s / src/%s\\n
130 131 132 133 134 135 136 137 138 139 140 141 142 143 144
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\")))")
Stefan Monnier's avatar
Stefan Monnier committed
145 146

(defgroup htmlfontify nil
Chong Yidong's avatar
Chong Yidong committed
147
  "Convert buffers and files to HTML."
Stefan Monnier's avatar
Stefan Monnier committed
148
  :group  'applications
Chong Yidong's avatar
Chong Yidong committed
149
  :link '(variable-link htmlfontify-manual)
Stefan Monnier's avatar
Stefan Monnier committed
150 151 152
  :prefix "hfy-")

(defcustom hfy-page-header 'hfy-default-header
Juanma Barranquero's avatar
Juanma Barranquero committed
153
  "Function called to build the header of the HTML source.
154
This is called with two arguments (the filename relative to the top
155
level source directory being etag'd and fontified), and a string containing
156
the <style>...</style> text to embed in the document.
Juanma Barranquero's avatar
Juanma Barranquero committed
157
It should return a string that will be used as the header for the
158
htmlfontified version of the source file.\n
159
See also `hfy-page-footer'."
Stefan Monnier's avatar
Stefan Monnier committed
160
  :group 'htmlfontify
161 162
  ;; FIXME: Why place such a :tag everywhere?  Isn't it imposing your
  ;; own Custom preference on your users?  --Stef
Stefan Monnier's avatar
Stefan Monnier committed
163 164 165 166
  :tag   "page-header"
  :type  '(function))

(defcustom hfy-split-index nil
167 168
  "Whether or not to split the index `hfy-index-file' alphabetically.
If non-nil, the index is split on the first letter of each tag.
Juanma Barranquero's avatar
Juanma Barranquero committed
169 170
Useful when the index would otherwise be large and take
a long time to render or be difficult to navigate."
Stefan Monnier's avatar
Stefan Monnier committed
171 172 173 174 175
  :group 'htmlfontify
  :tag   "split-index"
  :type  '(boolean))

(defcustom hfy-page-footer 'hfy-default-footer
176 177
  "As `hfy-page-header', but generates the output footer.
It takes only one argument, the filename."
Stefan Monnier's avatar
Stefan Monnier committed
178 179 180 181
  :group 'htmlfontify
  :tag   "page-footer"
  :type  '(function))

Juanma Barranquero's avatar
Juanma Barranquero committed
182
(defcustom hfy-extn ".html"
183
  "File extension used for output files."
Stefan Monnier's avatar
Stefan Monnier committed
184 185 186 187 188
  :group 'htmlfontify
  :tag   "extension"
  :type  '(string))

(defcustom hfy-src-doc-link-style "text-decoration: underline;"
189
  "String to add to the '<style> a' variant of an htmlfontify CSS class."
Stefan Monnier's avatar
Stefan Monnier committed
190 191 192 193 194
  :group 'htmlfontify
  :tag   "src-doc-link-style"
  :type  '(string))

(defcustom hfy-src-doc-link-unstyle " text-decoration: none;"
195
  "Regex to remove from the <style> a variant of an htmlfontify CSS class."
Stefan Monnier's avatar
Stefan Monnier committed
196 197 198 199 200
  :group 'htmlfontify
  :tag   "src-doc-link-unstyle"
  :type  '(string))

(defcustom hfy-link-extn nil
201 202 203 204
  "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'."
Stefan Monnier's avatar
Stefan Monnier committed
205 206 207 208 209
  :group 'htmlfontify
  :tag   "link-extension"
  :type  '(choice string (const nil)))

(defcustom hfy-link-style-fun 'hfy-link-style-string
210 211
  "Function to customize the appearance of hyperlinks.
Set this to a function, which will be called with one argument
212
\(a \"{ foo: bar; ...}\" CSS style-string) - it should return a copy of
Stefan Monnier's avatar
Stefan Monnier committed
213 214 215 216 217 218 219
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))

220 221
(defcustom hfy-index-file "hfy-index"
  "Name (sans extension) of the tag definition index file produced during
Stefan Monnier's avatar
Stefan Monnier committed
222 223 224 225 226
fontification-and-hyperlinking."
  :group 'htmlfontify
  :tag   "index-file"
  :type  '(string))

227 228
(defcustom hfy-instance-file "hfy-instance"
  "Name (sans extension) of the tag usage index file produced during
Stefan Monnier's avatar
Stefan Monnier committed
229 230 231 232 233
fontification-and-hyperlinking."
  :group 'htmlfontify
  :tag   "instance-file"
  :type  '(string))

234
(defcustom hfy-html-quote-regex "\\([<\"&>]\\)"
235 236
  "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')
Stefan Monnier's avatar
Stefan Monnier committed
237 238 239 240 241
to make them safe."
  :group 'htmlfontify
  :tag   "html-quote-regex"
  :type  '(regexp))

242 243 244
(define-obsolete-variable-alias 'hfy-init-kludge-hooks 'hfy-init-kludge-hook
  "23.2")
(defcustom hfy-init-kludge-hook '(hfy-kludge-cperl-mode)
245 246
  "List of functions to call when starting `htmlfontify-buffer' to do any
kludging necessary to get highlighting modes to behave as you want, even
Stefan Monnier's avatar
Stefan Monnier committed
247 248 249 250 251
when not running under a window system."
  :group 'htmlfontify
  :tag   "init-kludge-hooks"
  :type  '(hook))

Stefan Monnier's avatar
Stefan Monnier committed
252 253
(define-obsolete-variable-alias 'hfy-post-html-hooks 'hfy-post-html-hook "24.3")
(defcustom hfy-post-html-hook nil
254
  "List of functions to call after creating and filling the HTML buffer.
Juanma Barranquero's avatar
Juanma Barranquero committed
255
These functions will be called with the HTML buffer as the current buffer."
Stefan Monnier's avatar
Stefan Monnier committed
256 257 258 259 260 261
  :group   'htmlfontify
  :tag     "post-html-hooks"
  :options '(set-auto-mode)
  :type    '(hook))

(defcustom hfy-default-face-def nil
262 263 264 265 266 267
  "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 customize this to:\n
\((t :background \"black\" :foreground \"white\" :family \"misc-fixed\"))"
Stefan Monnier's avatar
Stefan Monnier committed
268 269 270 271 272 273 274 275 276
  :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]+$")
277
  "Regex used to parse an etags entry: must have 3 subexps, corresponding,
Stefan Monnier's avatar
Stefan Monnier committed
278 279 280
in order, to:\n
   1 - The tag
   2 - The line
281
   3 - The char (point) at which the tag occurs."
Stefan Monnier's avatar
Stefan Monnier committed
282 283 284 285 286 287 288 289
  :group 'htmlfontify
  :tag   "etag-regex"
  :type  '(regexp))

(defcustom hfy-html-quote-map '(("\"" "&quot;")
                                ("<"  "&lt;"  )
                                ("&"  "&amp;" )
                                (">"  "&gt;"  ))
290
  "Alist of char -> entity mappings used to make the text HTML-safe."
Stefan Monnier's avatar
Stefan Monnier committed
291 292 293
  :group 'htmlfontify
  :tag   "html-quote-map"
  :type  '(alist :key-type (string)))
294
(defconst hfy-e2x-etags-cmd "for src in `find . -type f`;
Stefan Monnier's avatar
Stefan Monnier committed
295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324
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;")

325 326 327
(defconst hfy-etags-cmd-alist-default
  `(("emacs etags"     . ,hfy-e2x-etags-cmd)
    ("exuberant ctags" . "%s -R -f -"   )))
Stefan Monnier's avatar
Stefan Monnier committed
328

329 330 331
(defcustom hfy-etags-cmd-alist
  hfy-etags-cmd-alist-default
  "Alist of possible shell commands that will generate etags output that
332
`htmlfontify' can use.  '%s' will be replaced by `hfy-etags-bin'."
333 334 335
  :group 'htmlfontify
  :tag   "etags-cmd-alist"
  :type  '(alist :key-type (string) :value-type (string)))
Stefan Monnier's avatar
Stefan Monnier committed
336 337

(defcustom hfy-etags-bin "etags"
338
  "Location of etags binary (we begin by assuming it's in your path).\n
Stefan Monnier's avatar
Stefan Monnier committed
339 340 341 342 343 344 345
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"
Juanma Barranquero's avatar
Juanma Barranquero committed
346
  "Shell (Bourne or compatible) to invoke for complex shell operations."
Stefan Monnier's avatar
Stefan Monnier committed
347 348 349 350
  :group 'htmlfontify
  :tag   "shell-file-name"
  :type  '(file))

351
(defcustom hfy-ignored-properties '(read-only
352 353 354 355 356 357
                                    intangible
                                    modification-hooks
                                    insert-in-front-hooks
                                    insert-behind-hooks
                                    point-entered
                                    point-left)
358
  "Properties to omit when copying a fontified buffer for HTML transformation."
359 360 361 362
  :group 'htmlfontify
  :tag   "ignored-properties"
  :type '(repeat symbol))

Stefan Monnier's avatar
Stefan Monnier committed
363
(defun hfy-which-etags ()
Paul Eggert's avatar
Paul Eggert committed
364
  "Return a string indicating which flavor of etags we are using."
Stefan Monnier's avatar
Stefan Monnier committed
365 366 367 368 369
  (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
370 371 372 373 374 375 376
  ;; We used to wrap this in a `eval-and-compile', but:
  ;; - it had no effect because this expression was not seen by the
  ;;   byte-compiler (defcustom used to quote this argument).
  ;; - it signals an error (`hfy-which-etags' is not defined at compile-time).
  ;; - we want this auto-detection to reflect the system on which Emacs is run
  ;;   rather than the one on which it's compiled.
  (cdr (assoc (hfy-which-etags) hfy-etags-cmd-alist))
377
  "The etags equivalent command to run in a source directory to generate a tags
Stefan Monnier's avatar
Stefan Monnier committed
378 379
file for the whole source tree from there on down.  The command should emit
the etags output on stdout.\n
380
Two canned commands are provided - they drive Emacs's etags and
381
exuberant-ctags' etags respectively."
Stefan Monnier's avatar
Stefan Monnier committed
382 383
  :group 'htmlfontify
  :tag   "etags-command"
384 385 386 387
  :type (let ((clist (list '(string))))
          (dolist (C hfy-etags-cmd-alist)
            (push (list 'const :tag (car C) (cdr C)) clist))
          (cons 'choice clist)))
Stefan Monnier's avatar
Stefan Monnier committed
388 389

(defcustom hfy-istext-command "file %s | sed -e 's@^[^:]*:[ \t]*@@'"
390
  "Command to run with the name of a file, to see whether it is a text file
391 392
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."
Stefan Monnier's avatar
Stefan Monnier committed
393 394 395 396 397 398
  :group 'htmlfontify
  :tag   "istext-command"
  :type  '(string))

(defcustom hfy-find-cmd
  "find . -type f \\! -name \\*~ \\! -name \\*.flc \\! -path \\*/CVS/\\*"
399
  "Find command used to harvest a list of files to attempt to fontify."
Stefan Monnier's avatar
Stefan Monnier committed
400 401 402 403 404
  :group 'htmlfontify
  :tag   "find-command"
  :type  '(string))

(defcustom hfy-display-class nil
405
  "Display class to use to determine which display class to use when
406
calculating a face's attributes.  This is useful when, for example, you
Stefan Monnier's avatar
Stefan Monnier committed
407 408 409
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
410 411 412 413 414 415 416 417
  '(class      color)
  '(class      grayscale)
  '(background dark)
  '(background light)
  '(type       x-toolkit)
  '(type       tty)
  '(type       motif)
  '(type       lucid)
Stefan Monnier's avatar
Stefan Monnier committed
418 419
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
420 421 422 423 424 425 426
'((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
Stefan Monnier's avatar
Stefan Monnier committed
427 428 429 430 431 432 433 434 435
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    )))

Paul Eggert's avatar
Paul Eggert committed
436 437
             (class      (choice (const :tag "Color"         color    )
                                 (const :tag "Grayscale"     grayscale)))
Stefan Monnier's avatar
Stefan Monnier committed
438 439 440 441 442

             (background (choice (const :tag "Dark"          dark     )
                                 (const :tag "Bright"        light    ))) ))

(defcustom hfy-optimisations (list 'keep-overlays)
443
  "Optimizations to turn on: So far, the following have been implemented:\n
Stefan Monnier's avatar
Stefan Monnier committed
444 445 446 447 448 449 450
  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.
451 452 453
  keep-overlays      : More of a bell (or possibly whistle) than an
                       optimization - If on, preserve overlay highlighting
                       (cf ediff or goo-font-lock) as well as basic faces.\n
454 455 456 457 458 459
  body-text-only     : Emit only body-text. In concrete terms,
                       1. Suppress calls to `hfy-page-header'and
                          `hfy-page-footer'
                       2. Pretend that `div-wrapper' option above is
                          turned off
                       3. Don't enclose output in <pre> </pre> tags
Stefan Monnier's avatar
Stefan Monnier committed
460 461 462
  And the following are planned but not yet available:\n
  kill-context-leak  : Suppress hyperlinking between files highlighted by
                       different modes.\n
463
Note: like compiler optimizations, these optimize the _output_ of the code,
Stefan Monnier's avatar
Stefan Monnier committed
464
not the processing of the source itself, and are therefore likely to slow
465
htmlfontify down, at least a little.  Except for skip-refontification,
Stefan Monnier's avatar
Stefan Monnier committed
466 467 468 469 470 471 472
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         )
473 474
               (const :tag "keep-overlays"        keep-overlays       )
               (const :tag "body-text-only"       body-text-only      ))
Stefan Monnier's avatar
Stefan Monnier committed
475
  :group 'htmlfontify
476
  :tag   "optimizations")
Stefan Monnier's avatar
Stefan Monnier committed
477

478
(defvar hfy-tags-cache nil
Stefan Monnier's avatar
Stefan Monnier committed
479
  "Alist of the form:\n
480 481
\((\"/src/dir/0\" . tag-hash0) (\"/src/dir/1\" tag-hash1) ...)\n
Each tag hash entry then contains entries of the form:\n
Stefan Monnier's avatar
Stefan Monnier committed
482
\"tag_string\" => ((\"file/name.ext\" line char) ... )\n
483 484
ie an alist mapping (relative) file paths to line and character offsets.\n
See also `hfy-load-tags-cache'.")
Stefan Monnier's avatar
Stefan Monnier committed
485

486 487 488 489
(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 also `hfy-load-tags-cache'.")
Stefan Monnier's avatar
Stefan Monnier committed
490

491 492 493
(defvar hfy-tags-rmap nil
  "Alist of the form ((\"/src/dir\" . tag-rmap-hash))\n
where tag-rmap-hash has entries of the form:
Stefan Monnier's avatar
Stefan Monnier committed
494 495 496 497 498 499
\"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.
500 501
Properties may be repeated, in which case later properties should be
treated as if they were inherited from a 'parent' font.
Stefan Monnier's avatar
Stefan Monnier committed
502 503
\(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
504
cumulative in a complex way.)\n
Stefan Monnier's avatar
Stefan Monnier committed
505
Some examples:\n
506 507 508 509 510 511 512 513 514 515 516 517 518 519
\(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")
Stefan Monnier's avatar
Stefan Monnier committed
520 521

(defvar hfy-sheet-assoc 'please-ignore-this-line
522 523 524
  "An assoc with elements of the form (face-name style-name . style-string):\n
'((default               \"default\" . \"{background: black; color: white}\")
  (font-lock-string-face \"string\"  . \"{color: rgb(64,224,208)}\"))" )
Stefan Monnier's avatar
Stefan Monnier committed
525 526

(defvar hfy-facemap-assoc 'please-ignore-this-line
527
  "An assoc of (point . FACE-SYMBOL) or (point . DEFFACE-LIST)
Stefan Monnier's avatar
Stefan Monnier committed
528
and (point . 'end) elements, in descending order of point value
529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547
\(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)
Stefan Monnier's avatar
Stefan Monnier committed
548
  ;; big similar section elided.  You get the idea.
549 550 551 552 553 554 555
  (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))")
Stefan Monnier's avatar
Stefan Monnier committed
556 557 558 559 560 561 562 563 564 565 566 567 568

(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)
569
  "Return the intersection (using `eq') of two lists SET-A and SET-B."
Stefan Monnier's avatar
Stefan Monnier committed
570 571 572 573
  (let ((sa set-a) (interq nil) (elt nil))
    (while sa
      (setq elt (car sa)
            sa  (cdr sa))
574 575
      (if (memq elt set-b) (setq interq (cons elt interq))))
    interq))
Stefan Monnier's avatar
Stefan Monnier committed
576 577

(defun hfy-colour-vals (colour)
578 579
  "Where COLOUR is a color name or #XXXXXX style triplet, return a
list of three (16 bit) rgb values for said color.\n
Stefan Monnier's avatar
Stefan Monnier committed
580 581 582
If a window system is unavailable, calls `hfy-fallback-colour-values'."
  (if (string-match hfy-triplet-regex colour)
      (mapcar
583 584
       (lambda (x) (* (string-to-number (match-string x colour) 16) 257))
       '(1 2 3))
Stefan Monnier's avatar
Stefan Monnier committed
585 586 587 588 589 590
    ;;(message ">> %s" colour)
    (if window-system
        (if (fboundp 'color-values)
            (color-values colour)
          ;;(message "[%S]" window-system)
          (x-color-values colour))
Paul Eggert's avatar
Paul Eggert committed
591
      ;; blarg - tty colors are no good - go fetch some X colors:
Stefan Monnier's avatar
Stefan Monnier committed
592 593 594 595 596
      (hfy-fallback-colour-values colour))))

(defvar hfy-cperl-mode-kludged-p nil)

(defun hfy-kludge-cperl-mode ()
Paul Eggert's avatar
Paul Eggert committed
597
  "CPerl mode does its damnedest not to do some of its fontification when not
Stefan Monnier's avatar
Stefan Monnier committed
598 599 600 601 602 603 604 605
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))) )

Juanma Barranquero's avatar
Juanma Barranquero committed
606 607
(defun hfy-opt (symbol)
  "Is option SYMBOL set."
608
  (memq symbol hfy-optimisations))
Stefan Monnier's avatar
Stefan Monnier committed
609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641

(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;

642
      // if arguments are provided to specify the colors
Stefan Monnier's avatar
Stefan Monnier committed
643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694
      // 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
      // &lt;tbody&gt;s
      var tbodies = table.getElementsByTagName(\"tbody\");

      // and iterate through them...
      for (var h = 0; h < tbodies.length; h++)
      {
          // find all the &lt;tr&gt; 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;
          }
      }
  }
Stefan Monnier's avatar
Stefan Monnier committed
695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716

  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\";   }
      }
  }
Stefan Monnier's avatar
Stefan Monnier committed
717 718 719
--> </script>
  </head>
  <body onload=\"stripe('index'); return true;\">\n"
720
          (mapconcat 'hfy-html-quote (mapcar 'char-to-string file) "") style))
Stefan Monnier's avatar
Stefan Monnier committed
721

722
(defun hfy-default-footer (_file)
Stefan Monnier's avatar
Stefan Monnier committed
723 724 725 726 727
  "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)
728
  "Replace the end of a CSS style declaration STYLE-STRING with the contents
Stefan Monnier's avatar
Stefan Monnier committed
729 730 731 732 733 734 735 736 737 738
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
739 740
                             style-string) " }")
    style-string))
Stefan Monnier's avatar
Stefan Monnier committed
741 742 743 744

;; utility functions - cast emacs style specification values into their
;; css2 equivalents:
(defun hfy-triplet (colour)
745
  "Takes a COLOUR name (string) and return a CSS rgb(R, G, B) triplet string.
Stefan Monnier's avatar
Stefan Monnier committed
746
Uses the definition of \"white\" to map the numbers to the 0-255 range, so
747 748 749
if you've redefined white, (esp. if you've redefined it to have a triplet
member lower than that of the color you are processing) strange things
may happen."
Stefan Monnier's avatar
Stefan Monnier committed
750
  ;;(message "hfy-colour-vals");;DBUG
751 752 753 754
  ;; TODO?  Can we do somehow do better than this?
  (cond
   ((equal colour "unspecified-fg") (setq colour "black"))
   ((equal colour "unspecified-bg") (setq colour "white")))
Stefan Monnier's avatar
Stefan Monnier committed
755 756 757 758 759 760 761 762
  (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)
763 764
                               (nth X white)) 255))
                       '(0 1 2))))))
Stefan Monnier's avatar
Stefan Monnier committed
765 766 767 768 769 770 771 772 773 774 775

(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)

776
(defun hfy-size (height)
Stefan Monnier's avatar
Stefan Monnier committed
777 778 779
  "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."
780 781
  ;; In ttys, the default face has :height == 1.
  (and (not (display-graphic-p)) (equal 1 height) (setq height 100))
Stefan Monnier's avatar
Stefan Monnier committed
782 783 784 785 786 787 788 789
  (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 )))) )) )

790 791
(defun hfy-slant (slant)
  "Derive a font-style CSS specifier from the Emacs :slant attribute SLANT:
Stefan Monnier's avatar
Stefan Monnier committed
792 793
CSS does not define the reverse-* styles, so just maps those to the
regular specifiers."
794 795 796 797 798 799
  (list (cons "font-style"
              (or (cdr (assq slant '((italic          . "italic")
                                     (reverse-italic  . "italic" )
                                     (oblique         . "oblique")
                                     (reverse-oblique . "oblique"))))
                  "normal"))))
Stefan Monnier's avatar
Stefan Monnier committed
800 801

(defun hfy-weight (weight)
802
  "Derive a font-weight CSS specifier from an Emacs weight spec symbol WEIGHT."
803 804 805 806 807 808 809 810 811
  (list (cons "font-weight" (cdr (assq weight '((ultra-bold  . "900")
                                                (extra-bold  . "800")
                                                (bold        . "700")
                                                (semi-bold   . "600")
                                                (normal      . "500")
                                                (semi-light  . "400")
                                                (light       . "300")
                                                (extra-light . "200")
                                                (ultra-light . "100")))))))
812

Stefan Monnier's avatar
Stefan Monnier committed
813 814 815 816
(defun hfy-box-to-border-assoc (spec)
  (if spec
      (let ((tag (car  spec))
            (val (cadr spec)))
817 818 819 820 821
        (cons (case tag
                (:color (cons "colour" val))
                (:width (cons "width"  val))
                (:style (cons "style"  val)))
              (hfy-box-to-border-assoc (cddr spec))))))
Stefan Monnier's avatar
Stefan Monnier committed
822 823 824 825 826 827 828 829

(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)))
830 831 832 833
     (cons "border-style" (case s
                            (released-button "outset")
                            (pressed-button  "inset" )
                            (t               "solid" ))))))
Stefan Monnier's avatar
Stefan Monnier committed
834 835 836 837 838 839 840 841 842

(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)                            ))) )

843
(defun hfy-decor (tag _val)
Stefan Monnier's avatar
Stefan Monnier committed
844 845 846 847
  "Derive CSS text-decoration specifiers from various Emacs font attributes.
TAG is an Emacs font attribute key (eg :underline).
VAL is ignored."
  (list
848
   ;; FIXME: Why not '("text-decoration" . "underline")?  --Stef
849 850 851 852
   (case tag
     (:underline      (cons "text-decoration" "underline"   ))
     (:overline       (cons "text-decoration" "overline"    ))
     (:strike-through (cons "text-decoration" "line-through")))))
Stefan Monnier's avatar
Stefan Monnier committed
853

854
(defun hfy-invisible (&optional _val)
Stefan Monnier's avatar
Stefan Monnier committed
855 856 857 858 859 860 861
  "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.
862
Entries resulting from customization (`custom-set-faces') will take
Stefan Monnier's avatar
Stefan Monnier committed
863
precedence."
864 865 866 867 868
  (append
   (if (and hfy-display-class hfy-default-face-def (eq face 'default))
       hfy-default-face-def)
   (get face 'saved-face)
   (get face 'face-defface-spec)))
Stefan Monnier's avatar
Stefan Monnier committed
869 870 871

(defun hfy-face-attr-for-class (face &optional class)
  "Return the face attributes for FACE.
872
If CLASS is set, it must be a `defface' alist key [see below],
Stefan Monnier's avatar
Stefan Monnier committed
873
in which case the first face specification returned by `hfy-combined-face-spec'
874
which *doesn't* clash with CLASS is returned.\n
Stefan Monnier's avatar
Stefan Monnier committed
875
\(A specification with a class of t is considered to match any class you
876
specify - this matches Emacs's behavior when deciding on which face attributes
877
to use, to the best of my understanding).\n
878
If CLASS is nil, then you just get whatever `face-attr-construct' returns,
Stefan Monnier's avatar
Stefan Monnier committed
879
ie the current specification in effect for FACE.\n
880 881
*NOTE*: This function forces any face that is not 'default and which has
no :inherit property to inherit from 'default (this is because 'default
882
is magical in that Emacs's fonts behave as if they inherit implicitly from
883 884
'default, but no such behavior exists in HTML/CSS).\n
See also `hfy-display-class' for details of valid values for CLASS."
885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953
  (let ((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)))))
Stefan Monnier's avatar
Stefan Monnier committed
954 955
    (if (or (memq :inherit face-spec) (eq 'default face))
        face-spec
956
      (append face-spec (list :inherit 'default)))))
Stefan Monnier's avatar
Stefan Monnier committed
957 958 959 960 961 962 963 964 965 966 967 968 969 970

;; 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,
971 972 973
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
Stefan Monnier's avatar
Stefan Monnier committed
974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001
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
1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016
              (if val (case key
                       (:family         (hfy-family    val))
                       (:width          (hfy-width     val))
                       (:weight         (hfy-weight    val))
                       (:slant          (hfy-slant     val))
                       (:foreground     (hfy-colour    val))
                       (:background     (hfy-bgcol     val))
                       (:box            (hfy-box       val))
                       (:height         (hfy-size      val))
                       (:underline      (hfy-decor key val))
                       (:overline       (hfy-decor key val))
                       (:strike-through (hfy-decor key val))
                       (:invisible      (hfy-invisible val))
                       (:bold           (hfy-weight  'bold))
                       (:italic         (hfy-slant 'italic))))))
Stefan Monnier's avatar
Stefan Monnier committed
1017 1018 1019 1020 1021
      (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)
1022 1023
  "Convert SPEC, a CSS font-size specifier, to an Emacs :height attribute value.
Used while merging multiple font-size attributes."
Stefan Monnier's avatar
Stefan Monnier committed
1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039
  ;;(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
1040
haven't encountered them yet.  Returns a `hfy-style-assoc'."
Stefan Monnier's avatar
Stefan Monnier committed
1041 1042 1043 1044 1045
  ;;(message "(hfy-flatten-style %S)" style) ;;DBUG
  (let ((n        0)
        (m (list 1))
        (x      nil)
        (r      nil))
1046 1047 1048 1049 1050 1051
    (dolist (css style)
      (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)))))
Stefan Monnier's avatar
Stefan Monnier committed
1052 1053 1054 1055
    ;;(message "r: %S" r)
    (setq  n (apply '* m))
    (nconc r (hfy-size (if x (round n) (* n 1.0)))) ))

1056 1057 1058 1059 1060
(defun hfy-face-resolve-face (fn)
  (cond
   ((facep fn)
    (hfy-face-attr-for-class fn hfy-display-class))
   ((and (symbolp fn)
1061
         (facep (symbol-value fn)))
1062 1063 1064 1065
    (hfy-face-attr-for-class (symbol-value fn) hfy-display-class))
   (t nil)))


Stefan Monnier's avatar
Stefan Monnier committed
1066 1067
(defun hfy-face-to-style (fn)
  "Take FN, a font or `defface' style font specification,
1068
\(as returned by `face-attr-construct' or `hfy-face-attr-for-class')
Stefan Monnier's avatar
Stefan Monnier committed
1069
and return a `hfy-style-assoc'.\n
1070
See also `hfy-face-to-style-i', `hfy-flatten-style'."
Stefan Monnier's avatar
Stefan Monnier committed
1071
  ;;(message "hfy-face-to-style");;DBUG
1072 1073 1074
  (let* ((face-def (hfy-face-resolve-face fn))
         (final-style
          (hfy-flatten-style (hfy-face-to-style-i face-def))))
Stefan Monnier's avatar
Stefan Monnier committed
1075 1076 1077 1078 1079 1080 1081
    ;;(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
Juanma Barranquero's avatar
Juanma Barranquero committed
1082
                     (nconc final-style '(("text-decoration" . "none"))))))
Stefan Monnier's avatar
Stefan Monnier committed
1083 1084 1085 1086 1087 1088 1089
    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)
1090
  "Render a font symbol or `defface' font spec FN into a name (string)."
Stefan Monnier's avatar
Stefan Monnier committed
1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115
  ;;(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))
1116 1117 1118
          (if (string-match "\\(.*\\)-face\\'" face-name)
              (setq face-name (match-string 1 face-name)))
          face-name)
Stefan Monnier's avatar
Stefan Monnier committed
1119 1120 1121 1122
      face-name)) )

;; construct an assoc of (stripped-name . "{ css-stuff-here }") pairs
;; from a face:
1123 1124 1125
(defun hfy-face-to-css-default (fn)
  "Default handler for mapping faces to styles.
See also `hfy-face-to-css'."
Stefan Monnier's avatar
Stefan Monnier committed
1126
  ;;(message "hfy-face-to-css");;DBUG
1127 1128 1129
  (let* ((css-list (hfy-face-to-style fn))
         (seen     nil)
         (css-text
1130 1131 1132 1133 1134 1135
          (mapcar
           (lambda (E)
             (if (car E)
                 (unless (member (car E) seen)
                   (push (car E) seen)
                   (format " %s: %s; " (car E) (cdr E)))))
1136
           css-list)))
Stefan Monnier's avatar
Stefan Monnier committed
1137 1138
    (cons (hfy-css-name fn) (format "{%s}" (apply 'concat css-text)))) )

1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149
(defvar hfy-face-to-css 'hfy-face-to-css-default
  "Handler for mapping faces  to styles.
The signature of the handler is of the form \(lambda (FN) ...\).
FN is a font or `defface' specification (cf
`face-attr-construct').  The handler should return a cons cell of
the form (STYLE-NAME . STYLE-SPEC).

The default handler is `hfy-face-to-css-default'.

See also `hfy-face-to-style'.")

1150 1151 1152 1153 1154 1155 1156
(defalias 'hfy-prop-invisible-p
  (if (fboundp 'invisible-p) #'invisible-p
    (lambda (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))))))
Stefan Monnier's avatar
Stefan Monnier committed
1157 1158 1159

(defun hfy-find-invisible-ranges ()
  "Return a list of (start-point . end-point) cons cells of invisible regions."
1160 1161
  (save-excursion
    (let (invisible p i s) ;; return-value pos invisible end start
Stefan Monnier's avatar
Stefan Monnier committed
1162 1163 1164 1165 1166
      (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
1167 1168
              (setq i         nil
                    invisible (cons (cons s p) invisible)))
Stefan Monnier's avatar
Stefan Monnier committed
1169 1170 1171 1172 1173 1174
          ;; 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
1175
        (setq invisible (cons (cons s (point-max)) invisible)))
1176
      invisible)))
Stefan Monnier's avatar
Stefan Monnier committed
1177 1178 1179 1180 1181 1182 1183

(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)
1184 1185 1186 1187
    (dolist (range map)
      (when (and (>= point (car range))
                 (<  point (cdr range)))
        (setq name (format "invisible-%S-%S" (car range) (cdr range)))))
Stefan Monnier's avatar
Stefan Monnier committed
1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198
    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.
1199 1200
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."
Stefan Monnier's avatar
Stefan Monnier committed
1201 1202 1203
  ;;(message "hfy-face-at");;DBUG
  ;; Fix-me: clean up, remove face-name etc
  ;; not sure why we'd want to remove face-name? -- v
1204 1205
  (let ((overlay-data nil)
        (base-face    nil)
1206
        (face-name   (get-text-property p 'face))
1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300