htmlfontify.el 102 KB
Newer Older
Mark Oteiza's avatar
Mark Oteiza committed
1
;;; htmlfontify.el --- htmlize a buffer/source tree with optional hyperlinks -*- lexical-binding: t -*-
Stefan Monnier's avatar
Stefan Monnier committed
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 2002-2003, 2009-2019 Free Software Foundation, Inc.
Stefan Monnier's avatar
Stefan Monnier committed
4 5

;; Emacs Lisp Archive Entry
6
;; Package: htmlfontify
Stefan Monnier's avatar
Stefan Monnier committed
7 8 9 10 11
;; Filename: htmlfontify.el
;; Version: 0.21
;; Keywords: html, hypermedia, markup, etags
;; Author: Vivek Dasmohapatra <vivek@etla.org>
;; Created: 2002-01-05
Paul Eggert's avatar
Paul Eggert committed
12
;; Description: htmlize a buffer/source tree with optional hyperlinks
Stefan Monnier's avatar
Stefan Monnier committed
13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30
;; 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
31
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
Stefan Monnier's avatar
Stefan Monnier committed
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

;;; 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:
Mark Oteiza's avatar
Mark Oteiza committed
83
(eval-when-compile (require 'cl-lib))
Stefan Monnier's avatar
Stefan Monnier committed
84 85 86 87 88 89 90 91
(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)

92 93
(require 'htmlfontify-loaddefs)

Stefan Monnier's avatar
Stefan Monnier committed
94 95 96 97 98 99 100 101
(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
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: \")
137
  (require \\='htmlfontify)
138
  (hfy-load-tags-cache srcdir)
139 140
  (let ((hfy-page-header  \\='rtfm-build-page-header)
        (hfy-page-footer  \\='rtfm-build-page-footer)
141 142 143 144
        (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)
150 151
  :link '(custom-manual "(htmlfontify) Top")
  :link '(info-link "(htmlfontify) Customization")
Stefan Monnier's avatar
Stefan Monnier committed
152 153 154
  :prefix "hfy-")

(defcustom hfy-page-header 'hfy-default-header
Juanma Barranquero's avatar
Juanma Barranquero committed
155
  "Function called to build the header of the HTML source.
156
This is called with two arguments (the filename relative to the top
157
level source directory being etag'd and fontified), and a string containing
158
the <style>...</style> text to embed in the document.
Juanma Barranquero's avatar
Juanma Barranquero committed
159
It should return a string that will be used as the header for the
160
htmlfontified version of the source file.\n
161
See also `hfy-page-footer'."
Stefan Monnier's avatar
Stefan Monnier committed
162
  :group 'htmlfontify
163 164
  ;; 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
165 166 167 168
  :tag   "page-header"
  :type  '(function))

(defcustom hfy-split-index nil
169 170
  "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
171 172
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
173 174 175 176 177
  :group 'htmlfontify
  :tag   "split-index"
  :type  '(boolean))

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

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

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

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

(defcustom hfy-link-extn nil
203 204 205 206
  "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
207 208 209 210 211
  :group 'htmlfontify
  :tag   "link-extension"
  :type  '(choice string (const nil)))

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

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

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

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

244 245 246
(define-obsolete-variable-alias 'hfy-init-kludge-hooks 'hfy-init-kludge-hook
  "23.2")
(defcustom hfy-init-kludge-hook '(hfy-kludge-cperl-mode)
247 248
  "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
249 250 251 252 253
when not running under a window system."
  :group 'htmlfontify
  :tag   "init-kludge-hooks"
  :type  '(hook))

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

(defcustom hfy-default-face-def nil
264
  "Fallback `defface' specification for the face `default', used when
265 266
`hfy-display-class' has been set (the normal htmlfontify way of extracting
potentially non-current face information doesn't necessarily work for
267
`default').\n
268 269
Example: I customize this to:\n
\((t :background \"black\" :foreground \"white\" :family \"misc-fixed\"))"
Stefan Monnier's avatar
Stefan Monnier committed
270 271 272 273 274 275 276 277 278
  :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]+$")
279
  "Regex used to parse an etags entry: must have 3 subexps, corresponding,
Stefan Monnier's avatar
Stefan Monnier committed
280 281 282
in order, to:\n
   1 - The tag
   2 - The line
283
   3 - The char (point) at which the tag occurs."
Stefan Monnier's avatar
Stefan Monnier committed
284 285 286 287 288 289 290 291
  :group 'htmlfontify
  :tag   "etag-regex"
  :type  '(regexp))

(defcustom hfy-html-quote-map '(("\"" "&quot;")
                                ("<"  "&lt;"  )
                                ("&"  "&amp;" )
                                (">"  "&gt;"  ))
292
  "Alist of char -> entity mappings used to make the text HTML-safe."
Stefan Monnier's avatar
Stefan Monnier committed
293 294 295
  :group 'htmlfontify
  :tag   "html-quote-map"
  :type  '(alist :key-type (string)))
296
(defconst hfy-e2x-etags-cmd "for src in `find . -type f`;
Stefan Monnier's avatar
Stefan Monnier committed
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 325 326
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;")

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

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

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

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

Stefan Monnier's avatar
Stefan Monnier committed
365
(defun hfy-which-etags ()
Paul Eggert's avatar
Paul Eggert committed
366
  "Return a string indicating which flavor of etags we are using."
367 368 369 370 371
  (with-temp-buffer
    (condition-case nil
        (when (eq (call-process hfy-etags-bin nil t nil "--version") 0)
          (goto-char (point-min))
          (cond
372 373
           ((search-forward "exube" nil t) "exuberant ctags")
           ((search-forward "GNU E" nil t) "emacs etags")))
374 375
      ;; Return nil if the etags binary isn't executable (Bug#25468).
      (file-error nil))))
Stefan Monnier's avatar
Stefan Monnier committed
376 377

(defcustom hfy-etags-cmd
378 379 380 381 382 383 384
  ;; 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))
385
  "The etags equivalent command to run in a source directory to generate a tags
Stefan Monnier's avatar
Stefan Monnier committed
386 387
file for the whole source tree from there on down.  The command should emit
the etags output on stdout.\n
388
Two canned commands are provided - they drive Emacs's etags and
389
exuberant-ctags' etags respectively."
Stefan Monnier's avatar
Stefan Monnier committed
390 391
  :group 'htmlfontify
  :tag   "etags-command"
392 393 394 395
  :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
396 397

(defcustom hfy-istext-command "file %s | sed -e 's@^[^:]*:[ \t]*@@'"
398
  "Command to run with the name of a file, to see whether it is a text file
399 400
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
401 402 403 404 405 406
  :group 'htmlfontify
  :tag   "istext-command"
  :type  '(string))

(defcustom hfy-find-cmd
  "find . -type f \\! -name \\*~ \\! -name \\*.flc \\! -path \\*/CVS/\\*"
407
  "Find command used to harvest a list of files to attempt to fontify."
Stefan Monnier's avatar
Stefan Monnier committed
408 409 410 411 412
  :group 'htmlfontify
  :tag   "find-command"
  :type  '(string))

(defcustom hfy-display-class nil
413
  "Display class to use to determine which display class to use when
414
calculating a face's attributes.  This is useful when, for example, you
Stefan Monnier's avatar
Stefan Monnier committed
415 416 417
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
418 419 420 421 422 423 424 425
  (class      color)
  (class      grayscale)
  (background dark)
  (background light)
  (type       x-toolkit)
  (type       tty)
  (type       motif)
  (type       lucid)
Stefan Monnier's avatar
Stefan Monnier committed
426 427
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
Glenn Morris's avatar
Glenn Morris committed
428
\((class color grayscale) (type tty)) would match any of:\n
429 430 431 432 433 434
  ((class color))
  ((class grayscale))
  ((class color grayscale))
  ((class color foo))
  ((type  tty))
  ((type  tty) (class color))\n
Stefan Monnier's avatar
Stefan Monnier committed
435 436 437 438 439 440 441 442 443
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
444 445
             (class      (choice (const :tag "Color"         color    )
                                 (const :tag "Grayscale"     grayscale)))
Stefan Monnier's avatar
Stefan Monnier committed
446 447 448 449

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

450
(define-obsolete-variable-alias 'hfy-optimisations 'hfy-optimizations "25.1")
451
(defcustom hfy-optimizations (list 'keep-overlays)
452
  "Optimizations to turn on: So far, the following have been implemented:\n
Stefan Monnier's avatar
Stefan Monnier committed
453 454 455 456 457 458 459
  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.
460 461 462
  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
463
  body-text-only     : Emit only body-text. In concrete terms,
464
                       1. Suppress calls to `hfy-page-header' and
465 466 467 468
                          `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
469 470 471
  And the following are planned but not yet available:\n
  kill-context-leak  : Suppress hyperlinking between files highlighted by
                       different modes.\n
472
Note: like compiler optimizations, these optimize the _output_ of the code,
Stefan Monnier's avatar
Stefan Monnier committed
473
not the processing of the source itself, and are therefore likely to slow
474
htmlfontify down, at least a little.  Except for skip-refontification,
Stefan Monnier's avatar
Stefan Monnier committed
475 476 477 478 479 480 481
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         )
482 483
               (const :tag "keep-overlays"        keep-overlays       )
               (const :tag "body-text-only"       body-text-only      ))
Stefan Monnier's avatar
Stefan Monnier committed
484
  :group 'htmlfontify
485
  :tag   "optimizations")
Stefan Monnier's avatar
Stefan Monnier committed
486

487
(defvar hfy-tags-cache nil
Stefan Monnier's avatar
Stefan Monnier committed
488
  "Alist of the form:\n
489 490
\((\"/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
491
\"tag_string\" => ((\"file/name.ext\" line char) ... )\n
492 493
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
494

495 496 497 498
(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
499

500 501 502
(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
503 504 505 506 507 508
\"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.
509
Properties may be repeated, in which case later properties should be
510
treated as if they were inherited from a `parent' font.
Stefan Monnier's avatar
Stefan Monnier committed
511 512
\(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
513
cumulative in a complex way.)\n
Stefan Monnier's avatar
Stefan Monnier committed
514
Some examples:\n
515
\(hfy-face-to-style \\='default) =>
516 517 518 519 520 521 522 523
  ((\"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
524
\(hfy-face-to-style \\='Info-title-3-face) =>
525 526 527 528
  ((\"font-weight\"     . \"700\")
   (\"font-family\"     . \"helv\")
   (\"font-size\"       . \"120%\")
   (\"text-decoration\" . \"none\"))\n")
Stefan Monnier's avatar
Stefan Monnier committed
529 530

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

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

(defvar hfy-tmpfont-stack nil
  "An alist of derived fonts resulting from overlays.")

569
(defconst hfy-hex-regex "[[:xdigit:]]")
Stefan Monnier's avatar
Stefan Monnier committed
570 571 572 573 574 575 576 577

(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)
578
  "Return the intersection (using `eq') of two lists SET-A and SET-B."
Stefan Monnier's avatar
Stefan Monnier committed
579 580 581 582
  (let ((sa set-a) (interq nil) (elt nil))
    (while sa
      (setq elt (car sa)
            sa  (cdr sa))
583 584
      (if (memq elt set-b) (setq interq (cons elt interq))))
    interq))
Stefan Monnier's avatar
Stefan Monnier committed
585

Paul Eggert's avatar
Paul Eggert committed
586 587
(defun hfy-color-vals (color)
  "Where COLOR is a color name or #XXXXXX style triplet, return a
588
list of three (16 bit) rgb values for said color.\n
Paul Eggert's avatar
Paul Eggert committed
589 590
If a window system is unavailable, calls `hfy-fallback-color-values'."
  (if (string-match hfy-triplet-regex color)
Stefan Monnier's avatar
Stefan Monnier committed
591
      (mapcar
Paul Eggert's avatar
Paul Eggert committed
592
       (lambda (x) (* (string-to-number (match-string x color) 16) 257))
593
       '(1 2 3))
Paul Eggert's avatar
Paul Eggert committed
594
    ;;(message ">> %s" color)
Stefan Monnier's avatar
Stefan Monnier committed
595 596
    (if window-system
        (if (fboundp 'color-values)
Paul Eggert's avatar
Paul Eggert committed
597
            (color-values color)
Stefan Monnier's avatar
Stefan Monnier committed
598
          ;;(message "[%S]" window-system)
Paul Eggert's avatar
Paul Eggert committed
599
          (x-color-values color))
Paul Eggert's avatar
Paul Eggert committed
600
      ;; blarg - tty colors are no good - go fetch some X colors:
Paul Eggert's avatar
Paul Eggert committed
601 602
      (hfy-fallback-color-values color))))
(define-obsolete-function-alias 'hfy-colour-vals 'hfy-color-vals "27.1")
Stefan Monnier's avatar
Stefan Monnier committed
603 604 605 606

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

(defun hfy-kludge-cperl-mode ()
Paul Eggert's avatar
Paul Eggert committed
607
  "CPerl mode does its damnedest not to do some of its fontification when not
Stefan Monnier's avatar
Stefan Monnier committed
608 609 610 611 612 613 614 615
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
616 617
(defun hfy-opt (symbol)
  "Is option SYMBOL set."
618
  (memq symbol hfy-optimizations))
Stefan Monnier's avatar
Stefan Monnier committed
619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651

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

652
      // if arguments are provided to specify the colors
Glenn Morris's avatar
Glenn Morris committed
653
      // of the even & odd rows, then use them;
Stefan Monnier's avatar
Stefan Monnier committed
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 695 696 697 698 699 700 701 702 703 704
      // 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
705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726

  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
727 728 729
--> </script>
  </head>
  <body onload=\"stripe('index'); return true;\">\n"
730
          (mapconcat 'hfy-html-quote (mapcar 'char-to-string file) "") style))
Stefan Monnier's avatar
Stefan Monnier committed
731

732
(defun hfy-default-footer (_file)
Stefan Monnier's avatar
Stefan Monnier committed
733 734 735 736 737
  "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)
738
  "Replace the end of a CSS style declaration STYLE-STRING with the contents
Stefan Monnier's avatar
Stefan Monnier committed
739 740
of the variable `hfy-src-doc-link-style', removing text matching the regex
`hfy-src-doc-link-unstyle' first, if necessary."
Paul Eggert's avatar
Paul Eggert committed
741
  ;;(message "hfy-color-vals");;DBUG
Stefan Monnier's avatar
Stefan Monnier committed
742 743 744 745 746 747 748
  (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
749 750
                             style-string) " }")
    style-string))
Stefan Monnier's avatar
Stefan Monnier committed
751 752 753

;; utility functions - cast emacs style specification values into their
;; css2 equivalents:
Paul Eggert's avatar
Paul Eggert committed
754 755
(defun hfy-triplet (color)
  "Takes a COLOR name (string) and return a CSS rgb(R, G, B) triplet string.
Stefan Monnier's avatar
Stefan Monnier committed
756
Uses the definition of \"white\" to map the numbers to the 0-255 range, so
757 758 759
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."
Paul Eggert's avatar
Paul Eggert committed
760
  ;;(message "hfy-color-vals");;DBUG
761 762
  ;; TODO?  Can we do somehow do better than this?
  (cond
Paul Eggert's avatar
Paul Eggert committed
763 764 765 766
   ((equal color "unspecified-fg") (setq color "black"))
   ((equal color "unspecified-bg") (setq color "white")))
  (let ((white (mapcar (lambda (I) (float (1+ I))) (hfy-color-vals "white")))
        (rgb16 (mapcar (lambda (I) (float (1+ I))) (hfy-color-vals  color))))
Stefan Monnier's avatar
Stefan Monnier committed
767 768 769 770 771 772
    (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)
773 774
                               (nth X white)) 255))
                       '(0 1 2))))))
Stefan Monnier's avatar
Stefan Monnier committed
775 776

(defun hfy-family (family) (list (cons "font-family"  family)))
Paul Eggert's avatar
Paul Eggert committed
777 778 779
(defun hfy-bgcol  (color) (list (cons "background"   (hfy-triplet color))))
(defun hfy-color (color) (list (cons "color"        (hfy-triplet color))))
(define-obsolete-function-alias 'hfy-colour 'hfy-color "27.1")
Stefan Monnier's avatar
Stefan Monnier committed
780 781 782 783 784 785 786
(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)

787
(defun hfy-size (height)
Stefan Monnier's avatar
Stefan Monnier committed
788 789 790
  "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."
791 792
  ;; 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
793 794 795 796 797 798 799 800
  (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 )))) )) )

801 802
(defun hfy-slant (slant)
  "Derive a font-style CSS specifier from the Emacs :slant attribute SLANT:
Stefan Monnier's avatar
Stefan Monnier committed
803 804
CSS does not define the reverse-* styles, so just maps those to the
regular specifiers."
805 806 807 808 809 810
  (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
811 812

(defun hfy-weight (weight)
813
  "Derive a font-weight CSS specifier from an Emacs weight spec symbol WEIGHT."
814 815 816 817 818 819 820 821 822
  (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")))))))
823

Stefan Monnier's avatar
Stefan Monnier committed
824 825 826 827
(defun hfy-box-to-border-assoc (spec)
  (if spec
      (let ((tag (car  spec))
            (val (cadr spec)))
Mark Oteiza's avatar
Mark Oteiza committed
828
        (cons (cl-case tag
Paul Eggert's avatar
Paul Eggert committed
829
                (:color (cons "color" val))
830 831 832
                (:width (cons "width"  val))
                (:style (cons "style"  val)))
              (hfy-box-to-border-assoc (cddr spec))))))
Stefan Monnier's avatar
Stefan Monnier committed
833 834 835

(defun hfy-box-to-style (spec)
  (let* ((css (hfy-box-to-border-assoc  spec))
Paul Eggert's avatar
Paul Eggert committed
836
         (col (cdr      (assoc "color" css)))
Stefan Monnier's avatar
Stefan Monnier committed
837 838
         (s   (cdr      (assoc "style"  css))))
    (list
Paul Eggert's avatar
Paul Eggert committed
839
     (if col (cons "border-color" (cdr (assoc "color" css))))
Stefan Monnier's avatar
Stefan Monnier committed
840
     (cons "border-width" (format "%dpx" (or (cdr (assoc "width" css)) 1)))
Mark Oteiza's avatar
Mark Oteiza committed
841
     (cons "border-style" (cl-case s
842 843 844
                            (released-button "outset")
                            (pressed-button  "inset" )
                            (t               "solid" ))))))
Stefan Monnier's avatar
Stefan Monnier committed
845 846 847 848 849 850 851 852 853

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

854
(defun hfy-decor (tag _val)
Stefan Monnier's avatar
Stefan Monnier committed
855 856 857 858
  "Derive CSS text-decoration specifiers from various Emacs font attributes.
TAG is an Emacs font attribute key (eg :underline).
VAL is ignored."
  (list
859
   ;; FIXME: Why not '("text-decoration" . "underline")?  --Stef
Mark Oteiza's avatar
Mark Oteiza committed
860
   (cl-case tag
861 862 863
     (:underline      (cons "text-decoration" "underline"   ))
     (:overline       (cons "text-decoration" "overline"    ))
     (:strike-through (cons "text-decoration" "line-through")))))
Stefan Monnier's avatar
Stefan Monnier committed
864

865
(defun hfy-invisible (&optional _val)
Stefan Monnier's avatar
Stefan Monnier committed
866 867 868 869 870 871 872
  "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.
873
Entries resulting from customization (`custom-set-faces') will take
Stefan Monnier's avatar
Stefan Monnier committed
874
precedence."
875 876 877 878 879
  (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
880 881 882

(defun hfy-face-attr-for-class (face &optional class)
  "Return the face attributes for FACE.
883
If CLASS is set, it must be a `defface' alist key [see below],
Stefan Monnier's avatar
Stefan Monnier committed
884
in which case the first face specification returned by `hfy-combined-face-spec'
885
which *doesn't* clash with CLASS is returned.\n
Stefan Monnier's avatar
Stefan Monnier committed
886
\(A specification with a class of t is considered to match any class you
887
specify - this matches Emacs's behavior when deciding on which face attributes
888
to use, to the best of my understanding).\n
889
If CLASS is nil, then you just get whatever `face-attr-construct' returns,
Stefan Monnier's avatar
Stefan Monnier committed
890
ie the current specification in effect for FACE.\n
891 892
*NOTE*: This function forces any face that is not `default' and which has
no :inherit property to inherit from `default' (this is because `default'
893
is magical in that Emacs's fonts behave as if they inherit implicitly from
894
`default', but no such behavior exists in HTML/CSS).\n
895
See also `hfy-display-class' for details of valid values for CLASS."
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 954 955 956 957 958 959 960 961 962 963 964
  (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
965 966
    (if (or (memq :inherit face-spec) (eq 'default face))
        face-spec
967
      (append face-spec (list :inherit 'default)))))
Stefan Monnier's avatar
Stefan Monnier committed
968 969 970 971 972 973 974 975 976 977 978 979 980 981

;; 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,
982 983 984
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
985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010
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
1011
                    (hfy-face-attr-for-class v hfy-display-class))))))
Stefan Monnier's avatar
Stefan Monnier committed
1012
        (setq this
Mark Oteiza's avatar
Mark Oteiza committed
1013
              (if val (cl-case key
1014 1015 1016 1017
                       (:family         (hfy-family    val))
                       (:width          (hfy-width     val))
                       (:weight         (hfy-weight    val))
                       (:slant          (hfy-slant     val))
Paul Eggert's avatar
Paul Eggert committed
1018
                       (:foreground     (hfy-color     val))
1019 1020 1021 1022 1023 1024 1025 1026 1027
                       (: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
1028 1029
      (setq that (hfy-face-to-style-i next))
      ;;(lwarn t :warning "%S => %S" fn (nconc this that parent))
1030
      (nconc this parent that))) )
Stefan Monnier's avatar
Stefan Monnier committed
1031 1032

(defun hfy-size-to-int (spec)
1033 1034
  "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
1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050
  ;;(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
1051
haven't encountered them yet.  Returns a `hfy-style-assoc'."
Stefan Monnier's avatar
Stefan Monnier committed
1052 1053 1054 1055 1056
  ;;(message "(hfy-flatten-style %S)" style) ;;DBUG
  (let ((n        0)
        (m (list 1))
        (x      nil)
        (r      nil))
1057 1058 1059 1060 1061 1062
    (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
1063 1064 1065 1066
    ;;(message "r: %S" r)
    (setq  n (apply '* m))
    (nconc r (hfy-size (if x (round n) (* n 1.0)))) ))

1067
(defun hfy-face-resolve-face (fn)
1068 1069 1070
  "For FN return a face specification.
FN may be either a face or a face specification. If the latter,
then the specification is returned unchanged."
1071 1072 1073
  (cond
   ((facep fn)
    (hfy-face-attr-for-class fn hfy-display-class))
1074 1075
   ;; FIXME: is this necessary? Faces can be symbols, but
   ;; not symbols refering to other symbols?
1076
   ((and (symbolp fn)
1077
         (facep (symbol-value fn)))
1078 1079 1080
    (hfy-face-attr-for-class
     (symbol-value fn) hfy-display-class))
   (t fn)))
1081 1082


Stefan Monnier's avatar
Stefan Monnier committed
1083 1084
(defun hfy-face-to-style (fn)
  "Take FN, a font or `defface' style font specification,
1085
\(as returned by `face-attr-construct' or `hfy-face-attr-for-class')
Stefan Monnier's avatar
Stefan Monnier committed
1086
and return a `hfy-style-assoc'.\n
1087
See also `hfy-face-to-style-i', `hfy-flatten-style'."
Stefan Monnier's avatar
Stefan Monnier committed
1088
  ;;(message "hfy-face-to-style");;DBUG
1089 1090 1091
  (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
1092 1093 1094 1095 1096 1097 1098
    ;;(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
1099
                     (nconc final-style '(("text-decoration" . "none"))))))
Stefan Monnier's avatar
Stefan Monnier committed
1100 1101 1102 1103 1104 1105 1106
    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)
1107
  "Render a font symbol or `defface' font spec FN into a name (string)."
Stefan Monnier's avatar
Stefan Monnier committed
1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132
  ;;(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))
1133 1134 1135
          (if (string-match "\\(.*\\)-face\\'" face-name)
              (setq face-name (match-string 1 face-name)))
          face-name)
Stefan Monnier's avatar
Stefan Monnier committed
1136 1137 1138 1139
      face-name)) )

;; construct an assoc of (stripped-name . "{ css-stuff-here }") pairs
;; from a face:
1140 1141 1142
(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
1143
  ;;(message "hfy-face-to-css");;DBUG
1144 1145 1146
  (let* ((css-list (hfy-face-to-style fn))
         (seen     nil)
         (css-text
1147 1148 1149 1150 1151 1152
          (mapcar
           (lambda (E)
             (if (car E)
                 (unless (member (car E) seen)
                   (push (car E) seen)
                   (format " %s: %s; " (car E) (cdr E)))))
1153
           css-list)))
Stefan Monnier's avatar
Stefan Monnier committed
1154 1155
    (cons (hfy-css-name fn) (format "{%s}" (apply 'concat css-text)))) )

1156 1157
(defvar hfy-face-to-css 'hfy-face-to-css-default
  "Handler for mapping faces  to styles.
1158
The signature of the handler is of the form \(lambda (FN) ...).
1159 1160 1161 1162 1163 1164 1165 1166
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'.")

1167 1168 1169 1170 1171 1172 1173
(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
1174 1175 1176

(defun hfy-find-invisible-ranges ()
  "Return a list of (start-point . end-point) cons cells of invisible regions."
1177 1178
  (save-excursion
    (let (invisible p i s) ;; return-value pos invisible end start
Stefan Monnier's avatar
Stefan Monnier committed
1179 1180 1181 1182 1183
      (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
1184 1185
              (setq i         nil
                    invisible (cons (cons s p) invisible)))
Stefan Monnier's avatar
Stefan Monnier committed
1186 1187 1188 1189 1190 1191
          ;; 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
1192
        (setq invisible (cons (cons s (point-max)) invisible)))
1193
      invisible)))
Stefan Monnier's avatar
Stefan Monnier committed
1194 1195 1196 1197 1198 1199 1200

(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)
1201 1202 1203 1204
    (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
1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215
    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.
1216
If overlays are to be considered (see `hfy-optimizations') then this may
1217
return a `defface' style list of face properties instead of a face symbol."
Stefan Monnier's avatar
Stefan Monnier committed
1218 1219 1220
  ;;(message "hfy-face-at");;DBUG
  ;; Fix-me: clean up, remove face-name etc
  ;; not sure why we'd want to remove face-name? -- v
1221 1222
  (let ((overlay-data nil)
        (base-face    nil)
1223
        (face-name   (get-text-property p 'face))
1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244