diff options
| author | Stefan Monnier | 2009-11-26 16:24:36 +0000 |
|---|---|---|
| committer | Stefan Monnier | 2009-11-26 16:24:36 +0000 |
| commit | 72fe6b25a283acd4c8f5a6c4e7393efa84649821 (patch) | |
| tree | a1565e2c364c344feb5ecc855673e4b551ce4537 | |
| parent | 85e0a5363c644d8886b7b14a864491f3776fac03 (diff) | |
| download | emacs-72fe6b25a283acd4c8f5a6c4e7393efa84649821.tar.gz emacs-72fe6b25a283acd4c8f5a6c4e7393efa84649821.zip | |
Misc coding convention cleanups.
* htmlfontify.el (hfy-init-kludge-hook): Rename from hfy-init-kludge-hooks.
(hfy-etags-cmd, hfy-flatten-style, hfy-invisible-name, hfy-face-at)
(hfy-fontify-buffer, hfy-prepare-index-i, hfy-subtract-maps)
(hfy-save-kill-buffers, htmlfontify-copy-and-link-dir): Use dolist and push.
(hfy-slant, hfy-weight): Use tables rather than code.
(hfy-box-to-border-assoc, hfy-box-to-style, hfy-decor)
(hfy-face-to-style-i, hfy-fontify-buffer): Use `case'.
(hfy-face-attr-for-class): Initialize `face-spec' directly.
(hfy-face-to-css): Remove `nconc' with single arg.
(hfy-p-to-face-lennart): Use `or'.
(hfy-face-at): Hoist common code. Remove spurious quotes in `case'.
(hfy-overlay-props-at, hfy-mark-tag-hrefs): Eta-reduce.
(hfy-compile-stylesheet, hfy-merge-adjacent-spans)
(hfy-compile-face-map, hfy-parse-tags-buffer): Use push.
(hfy-force-fontification): Use run-hooks.
| -rw-r--r-- | lisp/ChangeLog | 21 | ||||
| -rw-r--r-- | lisp/htmlfontify.el | 775 |
2 files changed, 407 insertions, 389 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 4e7266feda1..a1f83dc15a0 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog | |||
| @@ -1,3 +1,24 @@ | |||
| 1 | 2009-11-26 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 2 | |||
| 3 | Misc coding convention cleanups. | ||
| 4 | * htmlfontify.el (hfy-init-kludge-hook): Rename from | ||
| 5 | hfy-init-kludge-hooks. | ||
| 6 | (hfy-etags-cmd, hfy-flatten-style, hfy-invisible-name, hfy-face-at) | ||
| 7 | (hfy-fontify-buffer, hfy-prepare-index-i, hfy-subtract-maps) | ||
| 8 | (hfy-save-kill-buffers, htmlfontify-copy-and-link-dir): Use dolist | ||
| 9 | and push. | ||
| 10 | (hfy-slant, hfy-weight): Use tables rather than code. | ||
| 11 | (hfy-box-to-border-assoc, hfy-box-to-style, hfy-decor) | ||
| 12 | (hfy-face-to-style-i, hfy-fontify-buffer): Use `case'. | ||
| 13 | (hfy-face-attr-for-class): Initialize `face-spec' directly. | ||
| 14 | (hfy-face-to-css): Remove `nconc' with single arg. | ||
| 15 | (hfy-p-to-face-lennart): Use `or'. | ||
| 16 | (hfy-face-at): Hoist common code. Remove spurious quotes in `case'. | ||
| 17 | (hfy-overlay-props-at, hfy-mark-tag-hrefs): Eta-reduce. | ||
| 18 | (hfy-compile-stylesheet, hfy-merge-adjacent-spans) | ||
| 19 | (hfy-compile-face-map, hfy-parse-tags-buffer): Use push. | ||
| 20 | (hfy-force-fontification): Use run-hooks. | ||
| 21 | |||
| 1 | 2009-11-26 Vivek Dasmohapatra <vivek@etla.org> | 22 | 2009-11-26 Vivek Dasmohapatra <vivek@etla.org> |
| 2 | 23 | ||
| 3 | Various minor fixes. | 24 | Various minor fixes. |
diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el index a46ad334278..48bd7d921f9 100644 --- a/lisp/htmlfontify.el +++ b/lisp/htmlfontify.el | |||
| @@ -183,17 +183,19 @@ See: `htmlfontify-manual'" | |||
| 183 | :prefix "hfy-") | 183 | :prefix "hfy-") |
| 184 | 184 | ||
| 185 | (defcustom hfy-page-header 'hfy-default-header | 185 | (defcustom hfy-page-header 'hfy-default-header |
| 186 | "*Function called with two arguments \(the filename relative to the top | 186 | "Function called with two arguments \(the filename relative to the top |
| 187 | level source directory being etag\'d and fontified), and a string containing | 187 | level source directory being etag\'d and fontified), and a string containing |
| 188 | the <style>...</style> text to embed in the document- the string returned will | 188 | the <style>...</style> text to embed in the document- the string returned will |
| 189 | be used as the header for the htmlfontified version of the source file.\n | 189 | be used as the header for the htmlfontified version of the source file.\n |
| 190 | See also: `hfy-page-footer'" | 190 | See also: `hfy-page-footer'" |
| 191 | :group 'htmlfontify | 191 | :group 'htmlfontify |
| 192 | ;; FIXME: Why place such a :tag everywhere? Isn't it imposing your | ||
| 193 | ;; own Custom preference on your users? --Stef | ||
| 192 | :tag "page-header" | 194 | :tag "page-header" |
| 193 | :type '(function)) | 195 | :type '(function)) |
| 194 | 196 | ||
| 195 | (defcustom hfy-split-index nil | 197 | (defcustom hfy-split-index nil |
| 196 | "*Whether or not to split the index `hfy-index-file' alphabetically | 198 | "Whether or not to split the index `hfy-index-file' alphabetically |
| 197 | on the first letter of each tag. Useful when the index would otherwise | 199 | on the first letter of each tag. Useful when the index would otherwise |
| 198 | be large and take a long time to render or be difficult to navigate." | 200 | be large and take a long time to render or be difficult to navigate." |
| 199 | :group 'htmlfontify | 201 | :group 'htmlfontify |
| @@ -201,32 +203,32 @@ be large and take a long time to render or be difficult to navigate." | |||
| 201 | :type '(boolean)) | 203 | :type '(boolean)) |
| 202 | 204 | ||
| 203 | (defcustom hfy-page-footer 'hfy-default-footer | 205 | (defcustom hfy-page-footer 'hfy-default-footer |
| 204 | "*As `hfy-page-header', but generates the output footer | 206 | "As `hfy-page-header', but generates the output footer |
| 205 | \(and takes only 1 argument, the filename\)." | 207 | \(and takes only 1 argument, the filename\)." |
| 206 | :group 'htmlfontify | 208 | :group 'htmlfontify |
| 207 | :tag "page-footer" | 209 | :tag "page-footer" |
| 208 | :type '(function)) | 210 | :type '(function)) |
| 209 | 211 | ||
| 210 | (defcustom hfy-extn ".html" | 212 | (defcustom hfy-extn ".html" |
| 211 | "*File extension used for output files." | 213 | "File extension used for output files." |
| 212 | :group 'htmlfontify | 214 | :group 'htmlfontify |
| 213 | :tag "extension" | 215 | :tag "extension" |
| 214 | :type '(string)) | 216 | :type '(string)) |
| 215 | 217 | ||
| 216 | (defcustom hfy-src-doc-link-style "text-decoration: underline;" | 218 | (defcustom hfy-src-doc-link-style "text-decoration: underline;" |
| 217 | "*String to add to the \'<style> a\' variant of an htmlfontify css class." | 219 | "String to add to the \'<style> a\' variant of an htmlfontify css class." |
| 218 | :group 'htmlfontify | 220 | :group 'htmlfontify |
| 219 | :tag "src-doc-link-style" | 221 | :tag "src-doc-link-style" |
| 220 | :type '(string)) | 222 | :type '(string)) |
| 221 | 223 | ||
| 222 | (defcustom hfy-src-doc-link-unstyle " text-decoration: none;" | 224 | (defcustom hfy-src-doc-link-unstyle " text-decoration: none;" |
| 223 | "*Regex to remove from the <style> a variant of an htmlfontify css class." | 225 | "Regex to remove from the <style> a variant of an htmlfontify css class." |
| 224 | :group 'htmlfontify | 226 | :group 'htmlfontify |
| 225 | :tag "src-doc-link-unstyle" | 227 | :tag "src-doc-link-unstyle" |
| 226 | :type '(string)) | 228 | :type '(string)) |
| 227 | 229 | ||
| 228 | (defcustom hfy-link-extn nil | 230 | (defcustom hfy-link-extn nil |
| 229 | "*File extension used for href links - Useful where the htmlfontify | 231 | "File extension used for href links - Useful where the htmlfontify |
| 230 | output files are going to be processed again, with a resulting change | 232 | output files are going to be processed again, with a resulting change |
| 231 | in file extension. If nil, then any code using this should fall back | 233 | in file extension. If nil, then any code using this should fall back |
| 232 | to `hfy-extn'." | 234 | to `hfy-extn'." |
| @@ -235,7 +237,7 @@ to `hfy-extn'." | |||
| 235 | :type '(choice string (const nil))) | 237 | :type '(choice string (const nil))) |
| 236 | 238 | ||
| 237 | (defcustom hfy-link-style-fun 'hfy-link-style-string | 239 | (defcustom hfy-link-style-fun 'hfy-link-style-string |
| 238 | "*Set this to a function, which will be called with one argument | 240 | "Set this to a function, which will be called with one argument |
| 239 | \(a \"{ foo: bar; ...}\" css style-string\) - it should return a copy of | 241 | \(a \"{ foo: bar; ...}\" css style-string\) - it should return a copy of |
| 240 | its argument, altered so as to make any changes you want made for text which | 242 | its argument, altered so as to make any changes you want made for text which |
| 241 | is a hyperlink, in addition to being in the class to which that style would | 243 | is a hyperlink, in addition to being in the class to which that style would |
| @@ -245,29 +247,31 @@ normally be applied." | |||
| 245 | :type '(function)) | 247 | :type '(function)) |
| 246 | 248 | ||
| 247 | (defcustom hfy-index-file "hfy-index" | 249 | (defcustom hfy-index-file "hfy-index" |
| 248 | "*Name \(sans extension\) of the tag definition index file produced during | 250 | "Name \(sans extension\) of the tag definition index file produced during |
| 249 | fontification-and-hyperlinking." | 251 | fontification-and-hyperlinking." |
| 250 | :group 'htmlfontify | 252 | :group 'htmlfontify |
| 251 | :tag "index-file" | 253 | :tag "index-file" |
| 252 | :type '(string)) | 254 | :type '(string)) |
| 253 | 255 | ||
| 254 | (defcustom hfy-instance-file "hfy-instance" | 256 | (defcustom hfy-instance-file "hfy-instance" |
| 255 | "*Name \(sans extension\) of the tag usage index file produced during | 257 | "Name \(sans extension\) of the tag usage index file produced during |
| 256 | fontification-and-hyperlinking." | 258 | fontification-and-hyperlinking." |
| 257 | :group 'htmlfontify | 259 | :group 'htmlfontify |
| 258 | :tag "instance-file" | 260 | :tag "instance-file" |
| 259 | :type '(string)) | 261 | :type '(string)) |
| 260 | 262 | ||
| 261 | (defcustom hfy-html-quote-regex "\\(<\\|\"\\|&\\|>\\)" | 263 | (defcustom hfy-html-quote-regex "\\(<\\|\"\\|&\\|>\\)" |
| 262 | "*Regex to match \(with a single back-reference per match\) strings in HTML | 264 | "Regex to match \(with a single back-reference per match\) strings in HTML |
| 263 | which should be quoted with `hfy-html-quote' \(and `hfy-html-quote-map'\) | 265 | which should be quoted with `hfy-html-quote' \(and `hfy-html-quote-map'\) |
| 264 | to make them safe." | 266 | to make them safe." |
| 265 | :group 'htmlfontify | 267 | :group 'htmlfontify |
| 266 | :tag "html-quote-regex" | 268 | :tag "html-quote-regex" |
| 267 | :type '(regexp)) | 269 | :type '(regexp)) |
| 268 | 270 | ||
| 269 | (defcustom hfy-init-kludge-hooks '(hfy-kludge-cperl-mode) | 271 | (define-obsolete-variable-alias 'hfy-init-kludge-hooks 'hfy-init-kludge-hook |
| 270 | "*List of functions to call when starting htmlfontify-buffer to do any | 272 | "23.2") |
| 273 | (defcustom hfy-init-kludge-hook '(hfy-kludge-cperl-mode) | ||
| 274 | "List of functions to call when starting htmlfontify-buffer to do any | ||
| 271 | kludging necessary to get highlighting modes to bahave as you want, even | 275 | kludging necessary to get highlighting modes to bahave as you want, even |
| 272 | when not running under a window system." | 276 | when not running under a window system." |
| 273 | :group 'htmlfontify | 277 | :group 'htmlfontify |
| @@ -275,7 +279,7 @@ when not running under a window system." | |||
| 275 | :type '(hook)) | 279 | :type '(hook)) |
| 276 | 280 | ||
| 277 | (defcustom hfy-post-html-hooks nil | 281 | (defcustom hfy-post-html-hooks nil |
| 278 | "*List of functions to call after creating and filling the html buffer. | 282 | "List of functions to call after creating and filling the html buffer. |
| 279 | These functions will be called with the html buffer as the current buffer" | 283 | These functions will be called with the html buffer as the current buffer" |
| 280 | :group 'htmlfontify | 284 | :group 'htmlfontify |
| 281 | :tag "post-html-hooks" | 285 | :tag "post-html-hooks" |
| @@ -283,7 +287,7 @@ These functions will be called with the html buffer as the current buffer" | |||
| 283 | :type '(hook)) | 287 | :type '(hook)) |
| 284 | 288 | ||
| 285 | (defcustom hfy-default-face-def nil | 289 | (defcustom hfy-default-face-def nil |
| 286 | "*Fallback `defface' specification for the face \'default, used when | 290 | "Fallback `defface' specification for the face \'default, used when |
| 287 | `hfy-display-class' has been set \(the normal htmlfontify way of extracting | 291 | `hfy-display-class' has been set \(the normal htmlfontify way of extracting |
| 288 | potentially non-current face information doesn\'t necessarily work for | 292 | potentially non-current face information doesn\'t necessarily work for |
| 289 | \'default\).\n | 293 | \'default\).\n |
| @@ -298,7 +302,7 @@ Example: I customise this to:\n | |||
| 298 | "\x01" "\\([0-9]+\\)" | 302 | "\x01" "\\([0-9]+\\)" |
| 299 | "," "\\([0-9]+\\)$" | 303 | "," "\\([0-9]+\\)$" |
| 300 | "\\|" ".*\x7f[0-9]+,[0-9]+$") | 304 | "\\|" ".*\x7f[0-9]+,[0-9]+$") |
| 301 | "*Regex used to parse an etags entry: must have 3 subexps, corresponding, | 305 | "Regex used to parse an etags entry: must have 3 subexps, corresponding, |
| 302 | in order, to:\n | 306 | in order, to:\n |
| 303 | 1 - The tag | 307 | 1 - The tag |
| 304 | 2 - The line | 308 | 2 - The line |
| @@ -311,7 +315,7 @@ in order, to:\n | |||
| 311 | ("<" "<" ) | 315 | ("<" "<" ) |
| 312 | ("&" "&" ) | 316 | ("&" "&" ) |
| 313 | (">" ">" )) | 317 | (">" ">" )) |
| 314 | "*Alist of char -> entity mappings used to make the text html-safe." | 318 | "Alist of char -> entity mappings used to make the text html-safe." |
| 315 | :group 'htmlfontify | 319 | :group 'htmlfontify |
| 316 | :tag "html-quote-map" | 320 | :tag "html-quote-map" |
| 317 | :type '(alist :key-type (string))) | 321 | :type '(alist :key-type (string))) |
| @@ -353,14 +357,14 @@ done;") | |||
| 353 | 357 | ||
| 354 | (defcustom hfy-etags-cmd-alist | 358 | (defcustom hfy-etags-cmd-alist |
| 355 | hfy-etags-cmd-alist-default | 359 | hfy-etags-cmd-alist-default |
| 356 | "*Alist of possible shell commands that will generate etags output that | 360 | "Alist of possible shell commands that will generate etags output that |
| 357 | `htmlfontify' can use. \'%s\' will be replaced by `hfy-etags-bin'." | 361 | `htmlfontify' can use. \'%s\' will be replaced by `hfy-etags-bin'." |
| 358 | :group 'htmlfontify | 362 | :group 'htmlfontify |
| 359 | :tag "etags-cmd-alist" | 363 | :tag "etags-cmd-alist" |
| 360 | :type '(alist :key-type (string) :value-type (string)) )) | 364 | :type '(alist :key-type (string) :value-type (string)) )) |
| 361 | 365 | ||
| 362 | (defcustom hfy-etags-bin "etags" | 366 | (defcustom hfy-etags-bin "etags" |
| 363 | "*Location of etags binary (we begin by assuming it\'s in your path).\n | 367 | "Location of etags binary (we begin by assuming it\'s in your path).\n |
| 364 | Note that if etags is not in your path, you will need to alter the shell | 368 | Note that if etags is not in your path, you will need to alter the shell |
| 365 | commands in `hfy-etags-cmd-alist'." | 369 | commands in `hfy-etags-cmd-alist'." |
| 366 | :group 'htmlfontify | 370 | :group 'htmlfontify |
| @@ -368,7 +372,7 @@ commands in `hfy-etags-cmd-alist'." | |||
| 368 | :type '(file)) | 372 | :type '(file)) |
| 369 | 373 | ||
| 370 | (defcustom hfy-shell-file-name "/bin/sh" | 374 | (defcustom hfy-shell-file-name "/bin/sh" |
| 371 | "*Shell (bourne or compatible) to invoke for complex shell operations." | 375 | "Shell (bourne or compatible) to invoke for complex shell operations." |
| 372 | :group 'htmlfontify | 376 | :group 'htmlfontify |
| 373 | :tag "shell-file-name" | 377 | :tag "shell-file-name" |
| 374 | :type '(file)) | 378 | :type '(file)) |
| @@ -381,7 +385,7 @@ commands in `hfy-etags-cmd-alist'." | |||
| 381 | 385 | ||
| 382 | (defcustom hfy-etags-cmd | 386 | (defcustom hfy-etags-cmd |
| 383 | (eval-and-compile (cdr (assoc (hfy-which-etags) hfy-etags-cmd-alist))) | 387 | (eval-and-compile (cdr (assoc (hfy-which-etags) hfy-etags-cmd-alist))) |
| 384 | "*The etags equivalent command to run in a source directory to generate a tags | 388 | "The etags equivalent command to run in a source directory to generate a tags |
| 385 | file for the whole source tree from there on down. The command should emit | 389 | file for the whole source tree from there on down. The command should emit |
| 386 | the etags output on stdout.\n | 390 | the etags output on stdout.\n |
| 387 | Two canned commands are provided - they drive Emacs\' etags and | 391 | Two canned commands are provided - they drive Emacs\' etags and |
| @@ -390,15 +394,12 @@ exuberant-ctags\' etags respectively." | |||
| 390 | :tag "etags-command" | 394 | :tag "etags-command" |
| 391 | :type (eval-and-compile | 395 | :type (eval-and-compile |
| 392 | (let ((clist (list '(string)))) | 396 | (let ((clist (list '(string)))) |
| 393 | (mapc | 397 | (dolist (C hfy-etags-cmd-alist) |
| 394 | (lambda (C) | 398 | (push (list 'const :tag (car C) (cdr C)) clist)) |
| 395 | (setq clist | ||
| 396 | (cons (list 'const :tag (car C) (cdr C)) clist))) | ||
| 397 | hfy-etags-cmd-alist) | ||
| 398 | (cons 'choice clist)) )) | 399 | (cons 'choice clist)) )) |
| 399 | 400 | ||
| 400 | (defcustom hfy-istext-command "file %s | sed -e 's@^[^:]*:[ \t]*@@'" | 401 | (defcustom hfy-istext-command "file %s | sed -e 's@^[^:]*:[ \t]*@@'" |
| 401 | "*Command to run with the name of a file, to see whether it is a text file | 402 | "Command to run with the name of a file, to see whether it is a text file |
| 402 | or not. The command should emit a string containing the word \'text\' if | 403 | or not. The command should emit a string containing the word \'text\' if |
| 403 | the file is a text file, and a string not containing \'text\' otherwise." | 404 | the file is a text file, and a string not containing \'text\' otherwise." |
| 404 | :group 'htmlfontify | 405 | :group 'htmlfontify |
| @@ -407,13 +408,13 @@ the file is a text file, and a string not containing \'text\' otherwise." | |||
| 407 | 408 | ||
| 408 | (defcustom hfy-find-cmd | 409 | (defcustom hfy-find-cmd |
| 409 | "find . -type f \\! -name \\*~ \\! -name \\*.flc \\! -path \\*/CVS/\\*" | 410 | "find . -type f \\! -name \\*~ \\! -name \\*.flc \\! -path \\*/CVS/\\*" |
| 410 | "*Find command used to harvest a list of files to attempt to fontify." | 411 | "Find command used to harvest a list of files to attempt to fontify." |
| 411 | :group 'htmlfontify | 412 | :group 'htmlfontify |
| 412 | :tag "find-command" | 413 | :tag "find-command" |
| 413 | :type '(string)) | 414 | :type '(string)) |
| 414 | 415 | ||
| 415 | (defcustom hfy-display-class nil | 416 | (defcustom hfy-display-class nil |
| 416 | "*Display class to use to determine which display class to use when | 417 | "Display class to use to determine which display class to use when |
| 417 | calculating a face\'s attributes. This is useful when, for example, you | 418 | calculating a face\'s attributes. This is useful when, for example, you |
| 418 | are running Emacs on a tty or in batch mode, and want htmlfontify to have | 419 | are running Emacs on a tty or in batch mode, and want htmlfontify to have |
| 419 | access to the face spec you would use if you were connected to an X display.\n | 420 | access to the face spec you would use if you were connected to an X display.\n |
| @@ -451,7 +452,7 @@ and so on." | |||
| 451 | (const :tag "Bright" light ))) )) | 452 | (const :tag "Bright" light ))) )) |
| 452 | 453 | ||
| 453 | (defcustom hfy-optimisations (list 'keep-overlays) | 454 | (defcustom hfy-optimisations (list 'keep-overlays) |
| 454 | "*Optimisations to turn on: So far, the following have been implemented:\n | 455 | "Optimisations to turn on: So far, the following have been implemented:\n |
| 455 | merge-adjacent-tags: If two (or more) span tags are adjacent, identical and | 456 | merge-adjacent-tags: If two (or more) span tags are adjacent, identical and |
| 456 | separated by nothing more than whitespace, they will | 457 | separated by nothing more than whitespace, they will |
| 457 | be merged into one span. | 458 | be merged into one span. |
| @@ -583,8 +584,8 @@ list of 3 (16 bit) rgb values for said colour.\n | |||
| 583 | If a window system is unavailable, calls `hfy-fallback-colour-values'." | 584 | If a window system is unavailable, calls `hfy-fallback-colour-values'." |
| 584 | (if (string-match hfy-triplet-regex colour) | 585 | (if (string-match hfy-triplet-regex colour) |
| 585 | (mapcar | 586 | (mapcar |
| 586 | (lambda (x) | 587 | (lambda (x) (* (string-to-number (match-string x colour) 16) 257)) |
| 587 | (* (string-to-number (match-string x colour) 16) 257)) '(1 2 3)) | 588 | '(1 2 3)) |
| 588 | ;;(message ">> %s" colour) | 589 | ;;(message ">> %s" colour) |
| 589 | (if window-system | 590 | (if window-system |
| 590 | (if (fboundp 'color-values) | 591 | (if (fboundp 'color-values) |
| @@ -756,7 +757,8 @@ may happen\)." | |||
| 756 | (apply 'format "#%02x%02x%02x" | 757 | (apply 'format "#%02x%02x%02x" |
| 757 | (mapcar (lambda (X) | 758 | (mapcar (lambda (X) |
| 758 | (* (/ (nth X rgb16) | 759 | (* (/ (nth X rgb16) |
| 759 | (nth X white)) 255)) '(0 1 2))))) ) | 760 | (nth X white)) 255)) |
| 761 | '(0 1 2)))))) | ||
| 760 | 762 | ||
| 761 | (defun hfy-family (family) (list (cons "font-family" family))) | 763 | (defun hfy-family (family) (list (cons "font-family" family))) |
| 762 | (defun hfy-bgcol (colour) (list (cons "background" (hfy-triplet colour)))) | 764 | (defun hfy-bgcol (colour) (list (cons "background" (hfy-triplet colour)))) |
| @@ -784,32 +786,34 @@ the height of the underlying font." | |||
| 784 | "Derive a font-style css specifier from the Emacs :slant attribute SLANT: | 786 | "Derive a font-style css specifier from the Emacs :slant attribute SLANT: |
| 785 | CSS does not define the reverse-* styles, so just maps those to the | 787 | CSS does not define the reverse-* styles, so just maps those to the |
| 786 | regular specifiers." | 788 | regular specifiers." |
| 787 | (list (cons "font-style" (cond ((eq 'italic slant) "italic" ) | 789 | (list (cons "font-style" |
| 788 | ((eq 'reverse-italic slant) "italic" ) | 790 | (or (cdr (assq slant '((italic . "italic") |
| 789 | ((eq 'oblique slant) "oblique") | 791 | (reverse-italic . "italic" ) |
| 790 | ((eq 'reverse-oblique slant) "oblique") | 792 | (oblique . "oblique") |
| 791 | (t "normal" )))) ) | 793 | (reverse-oblique . "oblique")))) |
| 794 | "normal")))) | ||
| 792 | 795 | ||
| 793 | (defun hfy-weight (weight) | 796 | (defun hfy-weight (weight) |
| 794 | "Derive a font-weight css specifier from an Emacs weight spec symbol WEIGHT." | 797 | "Derive a font-weight css specifier from an Emacs weight spec symbol WEIGHT." |
| 795 | (list (cons "font-weight" (cond ((eq 'ultra-bold weight) "900") | 798 | (list (cons "font-weight" (cdr (assq weight '((ultra-bold . "900") |
| 796 | ((eq 'extra-bold weight) "800") | 799 | (extra-bold . "800") |
| 797 | ((eq 'bold weight) "700") | 800 | (bold . "700") |
| 798 | ((eq 'semi-bold weight) "600") | 801 | (semi-bold . "600") |
| 799 | ((eq 'normal weight) "500") | 802 | (normal . "500") |
| 800 | ((eq 'semi-light weight) "400") | 803 | (semi-light . "400") |
| 801 | ((eq 'light weight) "300") | 804 | (light . "300") |
| 802 | ((eq 'extra-light weight) "200") | 805 | (extra-light . "200") |
| 803 | ((eq 'ultra-light weight) "100")))) ) | 806 | (ultra-light . "100"))))))) |
| 804 | 807 | ||
| 805 | (defun hfy-box-to-border-assoc (spec) | 808 | (defun hfy-box-to-border-assoc (spec) |
| 806 | (if spec | 809 | (if spec |
| 807 | (let ((tag (car spec)) | 810 | (let ((tag (car spec)) |
| 808 | (val (cadr spec))) | 811 | (val (cadr spec))) |
| 809 | (cons (cond ((eq tag :color) (cons "colour" val)) | 812 | (cons (case tag |
| 810 | ((eq tag :width) (cons "width" val)) | 813 | (:color (cons "colour" val)) |
| 811 | ((eq tag :style) (cons "style" val))) | 814 | (:width (cons "width" val)) |
| 812 | (hfy-box-to-border-assoc (cddr spec))))) ) | 815 | (:style (cons "style" val))) |
| 816 | (hfy-box-to-border-assoc (cddr spec)))))) | ||
| 813 | 817 | ||
| 814 | (defun hfy-box-to-style (spec) | 818 | (defun hfy-box-to-style (spec) |
| 815 | (let* ((css (hfy-box-to-border-assoc spec)) | 819 | (let* ((css (hfy-box-to-border-assoc spec)) |
| @@ -818,9 +822,10 @@ regular specifiers." | |||
| 818 | (list | 822 | (list |
| 819 | (if col (cons "border-color" (cdr (assoc "colour" css)))) | 823 | (if col (cons "border-color" (cdr (assoc "colour" css)))) |
| 820 | (cons "border-width" (format "%dpx" (or (cdr (assoc "width" css)) 1))) | 824 | (cons "border-width" (format "%dpx" (or (cdr (assoc "width" css)) 1))) |
| 821 | (cons "border-style" (cond ((eq s 'released-button) "outset") | 825 | (cons "border-style" (case s |
| 822 | ((eq s 'pressed-button ) "inset" ) | 826 | (released-button "outset") |
| 823 | (t "solid" ))))) ) | 827 | (pressed-button "inset" ) |
| 828 | (t "solid" )))))) | ||
| 824 | 829 | ||
| 825 | (defun hfy-box (box) | 830 | (defun hfy-box (box) |
| 826 | "Derive CSS border-* attributes from the Emacs :box attribute BOX." | 831 | "Derive CSS border-* attributes from the Emacs :box attribute BOX." |
| @@ -836,9 +841,10 @@ TAG is an Emacs font attribute key (eg :underline). | |||
| 836 | VAL is ignored." | 841 | VAL is ignored." |
| 837 | (list | 842 | (list |
| 838 | ;; FIXME: Why not '("text-decoration" . "underline")? --Stef | 843 | ;; FIXME: Why not '("text-decoration" . "underline")? --Stef |
| 839 | (cond ((eq tag :underline ) (cons "text-decoration" "underline" )) | 844 | (case tag |
| 840 | ((eq tag :overline ) (cons "text-decoration" "overline" )) | 845 | (:underline (cons "text-decoration" "underline" )) |
| 841 | ((eq tag :strike-through) (cons "text-decoration" "line-through"))))) | 846 | (:overline (cons "text-decoration" "overline" )) |
| 847 | (:strike-through (cons "text-decoration" "line-through"))))) | ||
| 842 | 848 | ||
| 843 | (defun hfy-invisible (&optional val) | 849 | (defun hfy-invisible (&optional val) |
| 844 | "This text should be invisible. | 850 | "This text should be invisible. |
| @@ -871,75 +877,75 @@ no :inherit property to inherit from \'default \( this is because \'default | |||
| 871 | is magical in that Emacs' fonts behave as if they inherit implicitly from | 877 | is magical in that Emacs' fonts behave as if they inherit implicitly from |
| 872 | \'default, but no such behaviour exists in HTML/CSS \).\n | 878 | \'default, but no such behaviour exists in HTML/CSS \).\n |
| 873 | See `hfy-display-class' for details of valid values for CLASS." | 879 | See `hfy-display-class' for details of valid values for CLASS." |
| 874 | (let ((face-spec nil)) | 880 | (let ((face-spec |
| 875 | (setq | 881 | (if class |
| 876 | face-spec | 882 | (let ((face-props (hfy-combined-face-spec face)) |
| 877 | (if class | 883 | (face-specn nil) |
| 878 | (let ((face-props (hfy-combined-face-spec face)) | 884 | (face-class nil) |
| 879 | (face-specn nil) | 885 | (face-attrs nil) |
| 880 | (face-class nil) | 886 | (face-score -1) |
| 881 | (face-attrs nil) | 887 | (face-match nil)) |
| 882 | (face-score -1) | 888 | (while face-props |
| 883 | (face-match nil)) | 889 | (setq face-specn (car face-props) |
| 884 | (while face-props | 890 | face-class (car face-specn) |
| 885 | (setq face-specn (car face-props) | 891 | face-attrs (cdr face-specn) |
| 886 | face-class (car face-specn) | 892 | face-props (cdr face-props)) |
| 887 | face-attrs (cdr face-specn) | 893 | ;; if the current element CEL of CLASS is t we match |
| 888 | face-props (cdr face-props)) | 894 | ;; if the current face-class is t, we match |
| 889 | ;; if the current element CEL of CLASS is t we match | 895 | ;; if the cdr of CEL has a non-nil |
| 890 | ;; if the current face-class is t, we match | 896 | ;; intersection with the cdr of the first member of |
| 891 | ;; if the cdr of CEL has a non-nil | 897 | ;; the current face-class with the same car as CEL, we match |
| 892 | ;; intersection with the cdr of the first member of | 898 | ;; if we actually clash, then we can't match |
| 893 | ;; the current face-class with the same car as CEL, we match | 899 | (let ((cbuf class) |
| 894 | ;; if we actually clash, then we can't match | 900 | (cel nil) |
| 895 | (let ((cbuf class) | 901 | (key nil) |
| 896 | (cel nil) | 902 | (val nil) |
| 897 | (key nil) | 903 | (x nil) |
| 898 | (val nil) | 904 | (next nil) |
| 899 | (x nil) | 905 | (score 0)) |
| 900 | (next nil) | 906 | (while (and cbuf (not next)) |
| 901 | (score 0)) | 907 | (setq cel (car cbuf) |
| 902 | (while (and cbuf (not next)) | 908 | cbuf (cdr cbuf) |
| 903 | (setq cel (car cbuf) | 909 | key (car cel) |
| 904 | cbuf (cdr cbuf) | 910 | val (cdr cel) |
| 905 | key (car cel) | 911 | val (if (listp val) val (list val))) |
| 906 | val (cdr cel) | 912 | (cond |
| 907 | val (if (listp val) val (list val))) | 913 | ((or (eq cel t) |
| 908 | (cond | 914 | (memq face-class '(t default))) ;Default match. |
| 909 | ((or (eq cel t) (memq face-class '(t default)));;default match | 915 | (setq score 0) (ignore "t match")) |
| 910 | (setq score 0) (ignore "t match")) | 916 | ((not (cdr (assq key face-class))) ;Neither good nor bad. |
| 911 | ((not (cdr (assq key face-class))) ;; neither good nor bad | 917 | nil (ignore "non match, non collision")) |
| 912 | nil (ignore "non match, non collision")) | 918 | ((setq x (hfy-interq val (cdr (assq key face-class)))) |
| 913 | ((setq x (hfy-interq val (cdr (assq key face-class)))) | 919 | (setq score (+ score (length x))) |
| 914 | (setq score (+ score (length x))) | 920 | (ignore "intersection")) |
| 915 | (ignore "intersection")) | 921 | (t ;; nope. |
| 916 | (t ;; nope. | 922 | (setq next t score -10) (ignore "collision")) )) |
| 917 | (setq next t score -10) (ignore "collision")) )) | 923 | (if (> score face-score) |
| 918 | (if (> score face-score) | 924 | (progn |
| 919 | (progn | 925 | (setq face-match face-attrs |
| 920 | (setq face-match face-attrs | 926 | face-score score ) |
| 921 | face-score score ) | 927 | (ignore "%d << %S/%S" score face-class class)) |
| 922 | (ignore "%d << %S/%S" score face-class class)) | 928 | (ignore "--- %d ---- (insufficient)" score)) )) |
| 923 | (ignore "--- %d ---- (insufficient)" score)) )) | 929 | ;; matched ? last attrs : nil |
| 924 | ;; matched ? last attrs : nil | 930 | (if face-match |
| 925 | (if face-match | 931 | (if (listp (car face-match)) (car face-match) face-match) |
| 926 | (if (listp (car face-match)) (car face-match) face-match) nil)) | 932 | nil)) |
| 927 | ;; Unfortunately the default face returns a | 933 | ;; Unfortunately the default face returns a |
| 928 | ;; :background. Fortunately we can remove it, but how do we do | 934 | ;; :background. Fortunately we can remove it, but how do we do |
| 929 | ;; that in a non-system specific way? | 935 | ;; that in a non-system specific way? |
| 930 | (let ((spec (face-attr-construct face)) | 936 | (let ((spec (face-attr-construct face)) |
| 931 | (new-spec nil)) | 937 | (new-spec nil)) |
| 932 | (if (not (memq :background spec)) | 938 | (if (not (memq :background spec)) |
| 933 | spec | 939 | spec |
| 934 | (while spec | 940 | (while spec |
| 935 | (let ((a (nth 0 spec)) | 941 | (let ((a (nth 0 spec)) |
| 936 | (b (nth 1 spec))) | 942 | (b (nth 1 spec))) |
| 937 | (unless (and (eq a :background) | 943 | (unless (and (eq a :background) |
| 938 | (stringp b) | 944 | (stringp b) |
| 939 | (string= b "SystemWindow")) | 945 | (string= b "SystemWindow")) |
| 940 | (setq new-spec (cons a (cons b new-spec))))) | 946 | (setq new-spec (cons a (cons b new-spec))))) |
| 941 | (setq spec (cddr spec))) | 947 | (setq spec (cddr spec))) |
| 942 | new-spec)) )) | 948 | new-spec))))) |
| 943 | (if (or (memq :inherit face-spec) (eq 'default face)) | 949 | (if (or (memq :inherit face-spec) (eq 'default face)) |
| 944 | face-spec | 950 | face-spec |
| 945 | (nconc face-spec (list :inherit 'default))) )) | 951 | (nconc face-spec (list :inherit 'default))) )) |
| @@ -988,21 +994,21 @@ merged by the user - `hfy-flatten-style' should do this." | |||
| 988 | (hfy-face-to-style-i | 994 | (hfy-face-to-style-i |
| 989 | (hfy-face-attr-for-class v hfy-display-class)) )))) | 995 | (hfy-face-attr-for-class v hfy-display-class)) )))) |
| 990 | (setq this | 996 | (setq this |
| 991 | (if val (cond | 997 | (if val (case key |
| 992 | ((eq key :family ) (hfy-family val)) | 998 | (:family (hfy-family val)) |
| 993 | ((eq key :width ) (hfy-width val)) | 999 | (:width (hfy-width val)) |
| 994 | ((eq key :weight ) (hfy-weight val)) | 1000 | (:weight (hfy-weight val)) |
| 995 | ((eq key :slant ) (hfy-slant val)) | 1001 | (:slant (hfy-slant val)) |
| 996 | ((eq key :foreground ) (hfy-colour val)) | 1002 | (:foreground (hfy-colour val)) |
| 997 | ((eq key :background ) (hfy-bgcol val)) | 1003 | (:background (hfy-bgcol val)) |
| 998 | ((eq key :box ) (hfy-box val)) | 1004 | (:box (hfy-box val)) |
| 999 | ((eq key :height ) (hfy-size val)) | 1005 | (:height (hfy-size val)) |
| 1000 | ((eq key :underline ) (hfy-decor key val)) | 1006 | (:underline (hfy-decor key val)) |
| 1001 | ((eq key :overline ) (hfy-decor key val)) | 1007 | (:overline (hfy-decor key val)) |
| 1002 | ((eq key :strike-through) (hfy-decor key val)) | 1008 | (:strike-through (hfy-decor key val)) |
| 1003 | ((eq key :invisible ) (hfy-invisible val)) | 1009 | (:invisible (hfy-invisible val)) |
| 1004 | ((eq key :bold ) (hfy-weight 'bold)) | 1010 | (:bold (hfy-weight 'bold)) |
| 1005 | ((eq key :italic ) (hfy-slant 'italic)))))) | 1011 | (:italic (hfy-slant 'italic)))))) |
| 1006 | (setq that (hfy-face-to-style-i next)) | 1012 | (setq that (hfy-face-to-style-i next)) |
| 1007 | ;;(lwarn t :warning "%S => %S" fn (nconc this that parent)) | 1013 | ;;(lwarn t :warning "%S => %S" fn (nconc this that parent)) |
| 1008 | (nconc this that parent))) ) | 1014 | (nconc this that parent))) ) |
| @@ -1032,13 +1038,12 @@ haven\'t encountered them yet. Returns a `hfy-style-assoc'." | |||
| 1032 | (m (list 1)) | 1038 | (m (list 1)) |
| 1033 | (x nil) | 1039 | (x nil) |
| 1034 | (r nil)) | 1040 | (r nil)) |
| 1035 | (mapc | 1041 | (dolist (css style) |
| 1036 | (lambda (css) | 1042 | (if (string= (car css) "font-size") |
| 1037 | (if (string= (car css) "font-size") | 1043 | (progn |
| 1038 | (progn | 1044 | (when (not x) (setq m (nconc m (hfy-size-to-int (cdr css))))) |
| 1039 | (when (not x) (setq m (nconc m (hfy-size-to-int (cdr css))))) | 1045 | (when (string-match "pt" (cdr css)) (setq x t))) |
| 1040 | (when (string-match "pt" (cdr css)) (setq x t))) | 1046 | (setq r (nconc r (list css))))) |
| 1041 | (setq r (nconc r (list css))) )) style) | ||
| 1042 | ;;(message "r: %S" r) | 1047 | ;;(message "r: %S" r) |
| 1043 | (setq n (apply '* m)) | 1048 | (setq n (apply '* m)) |
| 1044 | (nconc r (hfy-size (if x (round n) (* n 1.0)))) )) | 1049 | (nconc r (hfy-size (if x (round n) (* n 1.0)))) )) |
| @@ -1112,14 +1117,13 @@ See also: `hfy-face-to-style'" | |||
| 1112 | ;;(message "(hfy-face-to-style %S)" fn) | 1117 | ;;(message "(hfy-face-to-style %S)" fn) |
| 1113 | (setq css-list (hfy-face-to-style fn)) | 1118 | (setq css-list (hfy-face-to-style fn)) |
| 1114 | (setq css-text | 1119 | (setq css-text |
| 1115 | (nconc | 1120 | (mapcar |
| 1116 | (mapcar | 1121 | (lambda (E) |
| 1117 | (lambda (E) | 1122 | (if (car E) |
| 1118 | (if (car E) | 1123 | (unless (member (car E) seen) |
| 1119 | (if (not (member (car E) seen)) | 1124 | (push (car E) seen) |
| 1120 | (progn | 1125 | (format " %s: %s; " (car E) (cdr E))))) |
| 1121 | (setq seen (cons (car E) seen)) | 1126 | css-list)) |
| 1122 | (format " %s: %s; " (car E) (cdr E)))))) css-list))) | ||
| 1123 | (cons (hfy-css-name fn) (format "{%s}" (apply 'concat css-text)))) ) | 1127 | (cons (hfy-css-name fn) (format "{%s}" (apply 'concat css-text)))) ) |
| 1124 | 1128 | ||
| 1125 | ;; extract a face from a list of char properties, if there is one: | 1129 | ;; extract a face from a list of char properties, if there is one: |
| @@ -1149,9 +1153,8 @@ property, or nil." | |||
| 1149 | (let* ((category (plist-get props 'category)) | 1153 | (let* ((category (plist-get props 'category)) |
| 1150 | (face (when category (plist-get (symbol-plist category) 'face)))) | 1154 | (face (when category (plist-get (symbol-plist category) 'face)))) |
| 1151 | face) | 1155 | face) |
| 1152 | (if font-lock-face | 1156 | (or font-lock-face |
| 1153 | font-lock-face | 1157 | face))))) |
| 1154 | face))))) | ||
| 1155 | 1158 | ||
| 1156 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | 1159 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 1157 | ;; (defun hfy-get-face-at (pos) | 1160 | ;; (defun hfy-get-face-at (pos) |
| @@ -1200,11 +1203,10 @@ POINT is the point inside the invisible region. | |||
| 1200 | MAP is the invisibility map as returned by `hfy-find-invisible-ranges'." | 1203 | MAP is the invisibility map as returned by `hfy-find-invisible-ranges'." |
| 1201 | ;;(message "(hfy-invisible-name %S %S)" point map) | 1204 | ;;(message "(hfy-invisible-name %S %S)" point map) |
| 1202 | (let (name) | 1205 | (let (name) |
| 1203 | (mapc | 1206 | (dolist (range map) |
| 1204 | (lambda (range) | 1207 | (when (and (>= point (car range)) |
| 1205 | (when (and (>= point (car range)) | 1208 | (< point (cdr range))) |
| 1206 | (< point (cdr range))) | 1209 | (setq name (format "invisible-%S-%S" (car range) (cdr range))))) |
| 1207 | (setq name (format "invisible-%S-%S" (car range) (cdr range))))) map) | ||
| 1208 | name)) | 1210 | name)) |
| 1209 | 1211 | ||
| 1210 | ;; Fix-me: This function needs some cleanup by someone who understand | 1212 | ;; Fix-me: This function needs some cleanup by someone who understand |
| @@ -1221,137 +1223,137 @@ return a defface style list of face properties instead of a face symbol." | |||
| 1221 | ;;(message "hfy-face-at");;DBUG | 1223 | ;;(message "hfy-face-at");;DBUG |
| 1222 | ;; Fix-me: clean up, remove face-name etc | 1224 | ;; Fix-me: clean up, remove face-name etc |
| 1223 | ;; not sure why we'd want to remove face-name? -- v | 1225 | ;; not sure why we'd want to remove face-name? -- v |
| 1224 | (let ((overlay-data nil) | 1226 | (let ((overlay-data nil) |
| 1225 | (base-face nil) | 1227 | (base-face nil) |
| 1226 | ;; restored hfy-p-to-face as it handles faces like (bold) as | 1228 | ;; restored hfy-p-to-face as it handles faces like (bold) as |
| 1227 | ;; well as face like 'bold - hfy-get-face-at doesn't dtrt -- v | 1229 | ;; well as face like 'bold - hfy-get-face-at doesn't dtrt -- v |
| 1228 | (face-name (hfy-p-to-face (text-properties-at p))) | 1230 | (face-name (hfy-p-to-face (text-properties-at p))) |
| 1229 | ;; (face-name (hfy-get-face-at p)) | 1231 | ;; (face-name (hfy-get-face-at p)) |
| 1230 | (prop-seen nil) | 1232 | (prop-seen nil) |
| 1231 | (extra-props nil) | 1233 | (extra-props nil) |
| 1232 | (text-props (text-properties-at p))) | 1234 | (text-props (text-properties-at p))) |
| 1233 | ;;(message "face-name: %S" face-name) | 1235 | ;;(message "face-name: %S" face-name) |
| 1234 | (when (and face-name (listp face-name) (facep (car face-name))) | 1236 | (when (and face-name (listp face-name) (facep (car face-name))) |
| 1235 | ;;(message "face-name is a list %S" face-name) | 1237 | ;;(message "face-name is a list %S" face-name) |
| 1236 | ;;(setq text-props (cons 'face face-name)) | 1238 | ;;(setq text-props (cons 'face face-name)) |
| 1237 | (dolist (f face-name) | 1239 | (dolist (f face-name) |
| 1238 | (if (listp f) ;; for things like (variable-pitch (:foreground "red")) | 1240 | (setq extra-props (if (listp f) |
| 1239 | (setq extra-props (cons f extra-props)) | 1241 | ;; for things like (variable-pitch |
| 1240 | (setq extra-props (cons :inherit (cons f extra-props))))) | 1242 | ;; (:foreground "red")) |
| 1241 | (setq base-face (car face-name) | 1243 | (cons f extra-props) |
| 1242 | face-name nil)) | 1244 | (cons :inherit (cons f extra-props))))) |
| 1243 | ;; text-properties-at => (face (:foreground "red" ...)) | 1245 | (setq base-face (car face-name) |
| 1244 | ;; or => (face (compilation-info underline)) list of faces | 1246 | face-name nil)) |
| 1245 | ;; overlay-properties | 1247 | ;; text-properties-at => (face (:foreground "red" ...)) |
| 1246 | ;; format= (evaporate t face ((foreground-color . "red"))) | 1248 | ;; or => (face (compilation-info underline)) list of faces |
| 1247 | 1249 | ;; overlay-properties | |
| 1248 | ;; SO: if we have turned overlays off, | 1250 | ;; format= (evaporate t face ((foreground-color . "red"))) |
| 1249 | ;; or if there's no overlay data | 1251 | |
| 1250 | ;; just bail out and return whatever face data we've accumulated so far | 1252 | ;; SO: if we have turned overlays off, |
| 1251 | (if (or (not (hfy-opt 'keep-overlays)) | 1253 | ;; or if there's no overlay data |
| 1252 | (not (setq overlay-data (hfy-overlay-props-at p)))) | 1254 | ;; just bail out and return whatever face data we've accumulated so far |
| 1253 | (progn | 1255 | (if (or (not (hfy-opt 'keep-overlays)) |
| 1254 | ;;(message "· %d: %s; %S; %s" | 1256 | (not (setq overlay-data (hfy-overlay-props-at p)))) |
| 1255 | ;; p face-name extra-props text-props) | 1257 | (progn |
| 1256 | (or face-name base-face)) ;; no overlays or extra properties | 1258 | ;;(message "· %d: %s; %S; %s" |
| 1257 | ;; collect any face data and any overlay data for processing: | 1259 | ;; p face-name extra-props text-props) |
| 1258 | (when text-props | 1260 | (or face-name base-face)) ;; no overlays or extra properties |
| 1259 | (setq overlay-data (cons text-props overlay-data))) | 1261 | ;; collect any face data and any overlay data for processing: |
| 1260 | (setq overlay-data (nreverse overlay-data)) | 1262 | (when text-props |
| 1261 | ;;(message "- %d: %s; %S; %s; %s" | 1263 | (push text-props overlay-data)) |
| 1262 | ;; p face-name extra-props text-props overlay-data) | 1264 | (setq overlay-data (nreverse overlay-data)) |
| 1263 | ;; remember the basic face name so we don't keep repeating its specs: | 1265 | ;;(message "- %d: %s; %S; %s; %s" |
| 1264 | (when face-name (setq base-face face-name)) | 1266 | ;; p face-name extra-props text-props overlay-data) |
| 1265 | (mapc | 1267 | ;; remember the basic face name so we don't keep repeating its specs: |
| 1266 | (lambda (P) | 1268 | (when face-name (setq base-face face-name)) |
| 1267 | (let ((iprops (cadr (memq 'invisible P)))) | 1269 | (dolist (P overlay-data) |
| 1268 | ;;(message "(hfy-prop-invisible-p %S)" iprops) | 1270 | (let ((iprops (cadr (memq 'invisible P)))) ;FIXME: plist-get? |
| 1269 | (when (and iprops (hfy-prop-invisible-p iprops)) | 1271 | ;;(message "(hfy-prop-invisible-p %S)" iprops) |
| 1270 | (setq extra-props | 1272 | (when (and iprops (hfy-prop-invisible-p iprops)) |
| 1271 | (cons :invisible (cons t extra-props))) )) | 1273 | (setq extra-props |
| 1272 | (let ((fprops (cadr (or (memq 'face P) | 1274 | (cons :invisible (cons t extra-props))) )) |
| 1273 | (memq 'font-lock-face P))))) | 1275 | (let ((fprops (cadr (or (memq 'face P) |
| 1274 | ;;(message "overlay face: %s" fprops) | 1276 | (memq 'font-lock-face P))))) |
| 1275 | (if (not (listp fprops)) | 1277 | ;;(message "overlay face: %s" fprops) |
| 1276 | (let ((this-face (if (stringp fprops) (intern fprops) fprops))) | 1278 | (if (not (listp fprops)) |
| 1277 | (when (not (eq this-face base-face)) | 1279 | (let ((this-face (if (stringp fprops) (intern fprops) fprops))) |
| 1278 | (setq extra-props | 1280 | (when (not (eq this-face base-face)) |
| 1279 | (cons :inherit | 1281 | (setq extra-props |
| 1280 | (cons this-face extra-props))) )) | 1282 | (cons :inherit |
| 1281 | (while fprops | 1283 | (cons this-face extra-props))) )) |
| 1282 | (if (facep (car fprops)) | 1284 | (while fprops |
| 1283 | (let ((face (car fprops))) | 1285 | (if (facep (car fprops)) |
| 1284 | (when (stringp face) (setq face (intern fprops))) | 1286 | (let ((face (car fprops))) |
| 1285 | (setq extra-props | 1287 | (when (stringp face) (setq face (intern fprops))) |
| 1286 | (cons :inherit | 1288 | (setq extra-props |
| 1287 | (cons face | 1289 | (cons :inherit |
| 1288 | extra-props))) | 1290 | (cons face |
| 1289 | (setq fprops (cdr fprops))) | 1291 | extra-props))) |
| 1290 | (let (p v) | 1292 | (setq fprops (cdr fprops))) |
| 1291 | ;; Sigh. | 1293 | (let (p v) |
| 1292 | (if (listp (car fprops)) | 1294 | ;; Sigh. |
| 1293 | (if (nlistp (cdr (car fprops))) | 1295 | (if (listp (car fprops)) |
| 1294 | (progn | 1296 | (if (nlistp (cdr (car fprops))) |
| 1295 | ;; ((prop . val)) | 1297 | (progn |
| 1296 | (setq p (caar fprops)) | 1298 | ;; ((prop . val)) |
| 1297 | (setq v (cdar fprops)) | 1299 | (setq p (caar fprops)) |
| 1298 | (setq fprops (cdr fprops))) | 1300 | (setq v (cdar fprops)) |
| 1299 | ;; ((prop val)) | 1301 | (setq fprops (cdr fprops))) |
| 1300 | (setq p (caar fprops)) | 1302 | ;; ((prop val)) |
| 1301 | (setq v (cadar fprops)) | 1303 | (setq p (caar fprops)) |
| 1302 | (setq fprops (cdr fprops))) | 1304 | (setq v (cadar fprops)) |
| 1303 | (if (listp (cdr fprops)) | 1305 | (setq fprops (cdr fprops))) |
| 1304 | (progn | 1306 | (if (listp (cdr fprops)) |
| 1305 | ;; (:prop val :prop val ...) | 1307 | (progn |
| 1306 | (setq p (car fprops)) | 1308 | ;; (:prop val :prop val ...) |
| 1307 | (setq v (cadr fprops)) | 1309 | (setq p (car fprops)) |
| 1308 | (setq fprops (cddr fprops))) | 1310 | (setq v (cadr fprops)) |
| 1309 | (if (and (listp fprops) | 1311 | (setq fprops (cddr fprops))) |
| 1310 | (not (listp (cdr fprops)))) | 1312 | (if (and (listp fprops) |
| 1311 | ;;(and (consp x) (cdr (last x))) | 1313 | (not (listp (cdr fprops)))) |
| 1312 | (progn | 1314 | ;;(and (consp x) (cdr (last x))) |
| 1313 | ;; (prop . val) | 1315 | (progn |
| 1314 | (setq p (car fprops)) | 1316 | ;; (prop . val) |
| 1315 | (setq v (cdr fprops)) | 1317 | (setq p (car fprops)) |
| 1316 | (setq fprops nil)) | 1318 | (setq v (cdr fprops)) |
| 1317 | (error "Eh... another format! fprops=%s" fprops) ))) | 1319 | (setq fprops nil)) |
| 1318 | (setq p (case p | 1320 | (error "Eh... another format! fprops=%s" fprops) ))) |
| 1319 | ;; These are all the properties handled | 1321 | (setq p (case p |
| 1320 | ;; in `hfy-face-to-style-i'. | 1322 | ;; These are all the properties handled |
| 1321 | ;; | 1323 | ;; in `hfy-face-to-style-i'. |
| 1322 | ;; Are these translations right? | 1324 | ;; |
| 1323 | ;; yes, they are -- v | 1325 | ;; Are these translations right? |
| 1324 | ('family :family ) | 1326 | ;; yes, they are -- v |
| 1325 | ('width :width ) | 1327 | (family :family ) |
| 1326 | ('height :height ) | 1328 | (width :width ) |
| 1327 | ('weight :weight ) | 1329 | (height :height ) |
| 1328 | ('slant :slant ) | 1330 | (weight :weight ) |
| 1329 | ('underline :underline ) | 1331 | (slant :slant ) |
| 1330 | ('overline :overline ) | 1332 | (underline :underline ) |
| 1331 | ('strike-through :strike-through) | 1333 | (overline :overline ) |
| 1332 | ('box :box ) | 1334 | (strike-through :strike-through) |
| 1333 | ('foreground-color :foreground) | 1335 | (box :box ) |
| 1334 | ('background-color :background) | 1336 | (foreground-color :foreground) |
| 1335 | ('bold :bold ) | 1337 | (background-color :background) |
| 1336 | ('italic :italic ) | 1338 | (bold :bold ) |
| 1337 | (t p))) | 1339 | (italic :italic ) |
| 1338 | (if (memq p prop-seen) nil ;; noop | 1340 | (t p))) |
| 1339 | (setq prop-seen (cons p prop-seen) | 1341 | (if (memq p prop-seen) nil ;; noop |
| 1340 | extra-props (cons p (cons v extra-props)))) )))))) | 1342 | (setq prop-seen (cons p prop-seen) |
| 1341 | overlay-data) | 1343 | extra-props (cons p (cons v extra-props)))))))))) |
| 1342 | ;;(message "+ %d: %s; %S" p face-name extra-props) | 1344 | ;;(message "+ %d: %s; %S" p face-name extra-props) |
| 1343 | (if extra-props | 1345 | (if extra-props |
| 1344 | (if (listp face-name) | 1346 | (if (listp face-name) |
| 1345 | (nconc extra-props face-name) | 1347 | (nconc extra-props face-name) |
| 1346 | (nconc extra-props (face-attr-construct face-name))) | 1348 | (nconc extra-props (face-attr-construct face-name))) |
| 1347 | face-name)) )) | 1349 | face-name)) )) |
| 1348 | 1350 | ||
| 1349 | (defun hfy-overlay-props-at (p) | 1351 | (defun hfy-overlay-props-at (p) |
| 1350 | "Grab overlay properties at point P. | 1352 | "Grab overlay properties at point P. |
| 1351 | The plists are returned in descending priority order." | 1353 | The plists are returned in descending priority order." |
| 1352 | (sort (mapcar (lambda (O) (overlay-properties O)) (overlays-at p)) | 1354 | (sort (mapcar #'overlay-properties (overlays-at p)) |
| 1353 | (lambda (A B) (> (or (cadr (memq 'priority A)) 0) | 1355 | (lambda (A B) (> (or (cadr (memq 'priority A)) 0) ;FIXME: plist-get? |
| 1354 | (or (cadr (memq 'priority B)) 0)) ) ) ) | 1356 | (or (cadr (memq 'priority B)) 0))))) |
| 1355 | 1357 | ||
| 1356 | ;; construct an assoc of (face-name . (css-name . "{ css-style }")) elements: | 1358 | ;; construct an assoc of (face-name . (css-name . "{ css-style }")) elements: |
| 1357 | (defun hfy-compile-stylesheet () | 1359 | (defun hfy-compile-stylesheet () |
| @@ -1366,9 +1368,9 @@ The plists are returned in descending priority order." | |||
| 1366 | (goto-char pt) | 1368 | (goto-char pt) |
| 1367 | (while (< pt (point-max)) | 1369 | (while (< pt (point-max)) |
| 1368 | (if (and (setq fn (hfy-face-at pt)) (not (assoc fn style))) | 1370 | (if (and (setq fn (hfy-face-at pt)) (not (assoc fn style))) |
| 1369 | (setq style (cons (cons fn (hfy-face-to-css fn)) style))) | 1371 | (push (cons fn (hfy-face-to-css fn)) style)) |
| 1370 | (setq pt (next-char-property-change pt))) ) | 1372 | (setq pt (next-char-property-change pt))) ) |
| 1371 | (setq style (cons (cons 'default (hfy-face-to-css 'default)) style))) ) | 1373 | (push (cons 'default (hfy-face-to-css 'default)) style))) |
| 1372 | 1374 | ||
| 1373 | (defun hfy-fontified-p () | 1375 | (defun hfy-fontified-p () |
| 1374 | "`font-lock' doesn't like to say it\'s been fontified when in batch | 1376 | "`font-lock' doesn't like to say it\'s been fontified when in batch |
| @@ -1410,8 +1412,8 @@ Returns a modified copy of FACE-MAP." | |||
| 1410 | (span-stop nil) | 1412 | (span-stop nil) |
| 1411 | (span-start nil) | 1413 | (span-start nil) |
| 1412 | (reduced-map nil)) | 1414 | (reduced-map nil)) |
| 1413 | ;;(setq reduced-map (cons (car tmp-map) reduced-map)) | 1415 | ;;(push (car tmp-map) reduced-map) |
| 1414 | ;;(setq reduced-map (cons (cadr tmp-map) reduced-map)) | 1416 | ;;(push (cadr tmp-map) reduced-map) |
| 1415 | (while tmp-map | 1417 | (while tmp-map |
| 1416 | (setq first-start (cadddr tmp-map) | 1418 | (setq first-start (cadddr tmp-map) |
| 1417 | first-stop (caddr tmp-map) | 1419 | first-stop (caddr tmp-map) |
| @@ -1431,8 +1433,8 @@ Returns a modified copy of FACE-MAP." | |||
| 1431 | first-stop (caddr map-buf) | 1433 | first-stop (caddr map-buf) |
| 1432 | last-start (cadr map-buf) | 1434 | last-start (cadr map-buf) |
| 1433 | last-stop (car map-buf))) | 1435 | last-stop (car map-buf))) |
| 1434 | (setq reduced-map (cons span-stop reduced-map)) | 1436 | (push span-stop reduced-map) |
| 1435 | (setq reduced-map (cons span-start reduced-map)) | 1437 | (push span-start reduced-map) |
| 1436 | (setq tmp-map (memq last-start tmp-map)) | 1438 | (setq tmp-map (memq last-start tmp-map)) |
| 1437 | (setq tmp-map (cdr tmp-map))) | 1439 | (setq tmp-map (cdr tmp-map))) |
| 1438 | (setq reduced-map (nreverse reduced-map)))) | 1440 | (setq reduced-map (nreverse reduced-map)))) |
| @@ -1459,15 +1461,15 @@ Returns a modified copy of FACE-MAP." | |||
| 1459 | (goto-char pt) | 1461 | (goto-char pt) |
| 1460 | (while (< pt (point-max)) | 1462 | (while (< pt (point-max)) |
| 1461 | (if (setq fn (hfy-face-at pt)) | 1463 | (if (setq fn (hfy-face-at pt)) |
| 1462 | (progn (if prev-tag (setq map (cons (cons pt-narrow 'end) map))) | 1464 | (progn (if prev-tag (push (cons pt-narrow 'end) map)) |
| 1463 | (setq map (cons (cons pt-narrow fn) map)) | 1465 | (push (cons pt-narrow fn) map) |
| 1464 | (setq prev-tag t)) | 1466 | (setq prev-tag t)) |
| 1465 | (if prev-tag (setq map (cons (cons pt-narrow 'end) map))) | 1467 | (if prev-tag (push (cons pt-narrow 'end) map)) |
| 1466 | (setq prev-tag nil)) | 1468 | (setq prev-tag nil)) |
| 1467 | (setq pt (next-char-property-change pt)) | 1469 | (setq pt (next-char-property-change pt)) |
| 1468 | (setq pt-narrow (1+ (- pt (point-min))))) | 1470 | (setq pt-narrow (1+ (- pt (point-min))))) |
| 1469 | (if (and map (not (eq 'end (cdar map)))) | 1471 | (if (and map (not (eq 'end (cdar map)))) |
| 1470 | (setq map (cons (cons (- (point-max) (point-min)) 'end) map)))) | 1472 | (push (cons (- (point-max) (point-min)) 'end) map))) |
| 1471 | (if (hfy-opt 'merge-adjacent-tags) (hfy-merge-adjacent-spans map) map))) | 1473 | (if (hfy-opt 'merge-adjacent-tags) (hfy-merge-adjacent-spans map) map))) |
| 1472 | 1474 | ||
| 1473 | (defun hfy-buffer () | 1475 | (defun hfy-buffer () |
| @@ -1514,7 +1516,8 @@ Uses `hfy-link-style-fun' to do this." | |||
| 1514 | (format | 1516 | (format |
| 1515 | "span.%s %s\nspan.%s a %s\n" | 1517 | "span.%s %s\nspan.%s a %s\n" |
| 1516 | (cadr style) (cddr style) | 1518 | (cadr style) (cddr style) |
| 1517 | (cadr style) (hfy-link-style (cddr style)))) css)) | 1519 | (cadr style) (hfy-link-style (cddr style)))) |
| 1520 | css)) | ||
| 1518 | " --></style>\n")) | 1521 | " --></style>\n")) |
| 1519 | (funcall hfy-page-header file stylesheet))) | 1522 | (funcall hfy-page-header file stylesheet))) |
| 1520 | 1523 | ||
| @@ -1665,38 +1668,36 @@ FILE, if set, is the file name." | |||
| 1665 | ;; property has already served its main purpose by this point. | 1668 | ;; property has already served its main purpose by this point. |
| 1666 | ;;(message "mapcar over the CSS-MAP") | 1669 | ;;(message "mapcar over the CSS-MAP") |
| 1667 | (message "invis-ranges:\n%S" invis-ranges) | 1670 | (message "invis-ranges:\n%S" invis-ranges) |
| 1668 | (mapc | 1671 | (dolist (point-face css-map) |
| 1669 | (lambda (point-face) | 1672 | (let ((pt (car point-face)) |
| 1670 | (let ((pt (car point-face)) | 1673 | (fn (cdr point-face)) |
| 1671 | (fn (cdr point-face)) | 1674 | (move-link nil)) |
| 1672 | (move-link nil)) | 1675 | (goto-char pt) |
| 1673 | (goto-char pt) | 1676 | (setq move-link |
| 1674 | (setq move-link | 1677 | (or (get-text-property pt 'hfy-linkp) |
| 1675 | (or (get-text-property pt 'hfy-linkp) | 1678 | (get-text-property pt 'hfy-endl ))) |
| 1676 | (get-text-property pt 'hfy-endl ))) | 1679 | (if (eq 'end fn) |
| 1677 | (if (eq 'end fn) | 1680 | (insert "</span>") |
| 1678 | (insert "</span>") | 1681 | (if (not (and srcdir file)) |
| 1679 | (if (not (and srcdir file)) | 1682 | nil |
| 1680 | nil | 1683 | (when move-link |
| 1681 | (when move-link | 1684 | (remove-text-properties (point) (1+ (point)) '(hfy-endl nil)) |
| 1682 | (remove-text-properties (point) (1+ (point)) '(hfy-endl nil)) | 1685 | (put-text-property pt (1+ pt) 'hfy-endl t) )) |
| 1683 | (put-text-property pt (1+ pt) 'hfy-endl t) )) | 1686 | ;; if we have invisible blocks, we need to do some extra magic: |
| 1684 | ;; if we have invisible blocks, we need to do some extra magic: | 1687 | (if invis-ranges |
| 1685 | (if invis-ranges | 1688 | (let ((iname (hfy-invisible-name pt invis-ranges)) |
| 1686 | (let ((iname (hfy-invisible-name pt invis-ranges)) | 1689 | (fname (hfy-lookup fn css-sheet ))) |
| 1687 | (fname (hfy-lookup fn css-sheet ))) | 1690 | (when (assq pt invis-ranges) |
| 1688 | (when (assq pt invis-ranges) | 1691 | (insert |
| 1689 | (insert | 1692 | (format "<span onclick=\"toggle_invis('%s');\">" iname)) |
| 1690 | (format "<span onclick=\"toggle_invis('%s');\">" iname)) | 1693 | (insert "…</span>")) |
| 1691 | (insert "…</span>")) | 1694 | (insert |
| 1692 | (insert | 1695 | (format "<span class=\"%s\" id=\"%s-%d\">" fname iname pt))) |
| 1693 | (format "<span class=\"%s\" id=\"%s-%d\">" fname iname pt))) | 1696 | (insert (format "<span class=\"%s\">" (hfy-lookup fn css-sheet)))) |
| 1694 | (insert (format "<span class=\"%s\">" (hfy-lookup fn css-sheet)))) | 1697 | (if (not move-link) nil |
| 1695 | (if (not move-link) nil | 1698 | ;;(message "removing prop2 @ %d" (point)) |
| 1696 | ;;(message "removing prop2 @ %d" (point)) | 1699 | (if (remove-text-properties (point) (1+ (point)) '(hfy-endl nil)) |
| 1697 | (if (remove-text-properties (point) (1+ (point)) '(hfy-endl nil)) | 1700 | (put-text-property pt (1+ pt) 'hfy-endl t)))))) |
| 1698 | (put-text-property pt (1+ pt) 'hfy-endl t))) ))) | ||
| 1699 | css-map) | ||
| 1700 | ;; ##################################################################### | 1701 | ;; ##################################################################### |
| 1701 | ;; Invisibility | 1702 | ;; Invisibility |
| 1702 | ;; Maybe just make the text invisible in XHTML? | 1703 | ;; Maybe just make the text invisible in XHTML? |
| @@ -1724,13 +1725,13 @@ FILE, if set, is the file name." | |||
| 1724 | (if (not (setq pr (get-text-property pt lp))) nil | 1725 | (if (not (setq pr (get-text-property pt lp))) nil |
| 1725 | (goto-char pt) | 1726 | (goto-char pt) |
| 1726 | (remove-text-properties pt (1+ pt) (list lp nil)) | 1727 | (remove-text-properties pt (1+ pt) (list lp nil)) |
| 1727 | (cond | 1728 | (case lp |
| 1728 | ((eq lp 'hfy-link) | 1729 | (hfy-link |
| 1729 | (if (setq rr (get-text-property pt 'hfy-inst)) | 1730 | (if (setq rr (get-text-property pt 'hfy-inst)) |
| 1730 | (insert (format "<a name=\"%s\"></a>" rr))) | 1731 | (insert (format "<a name=\"%s\"></a>" rr))) |
| 1731 | (insert (format "<a href=\"%s\">" pr)) | 1732 | (insert (format "<a href=\"%s\">" pr)) |
| 1732 | (setq lp 'hfy-endl)) | 1733 | (setq lp 'hfy-endl)) |
| 1733 | ((eq lp 'hfy-endl) | 1734 | (hfy-endl |
| 1734 | (insert "</a>") (setq lp 'hfy-link)) ))) )) | 1735 | (insert "</a>") (setq lp 'hfy-link)) ))) )) |
| 1735 | 1736 | ||
| 1736 | ;; ##################################################################### | 1737 | ;; ##################################################################### |
| @@ -1760,7 +1761,7 @@ FILE, if set, is the file name." | |||
| 1760 | 1761 | ||
| 1761 | (defun hfy-force-fontification () | 1762 | (defun hfy-force-fontification () |
| 1762 | "Try to force font-locking even when it is optimised away." | 1763 | "Try to force font-locking even when it is optimised away." |
| 1763 | (mapc (lambda (fun) (funcall fun)) hfy-init-kludge-hooks) | 1764 | (run-hooks 'hfy-init-kludge-hook) |
| 1764 | (eval-and-compile (require 'font-lock)) | 1765 | (eval-and-compile (require 'font-lock)) |
| 1765 | (if (boundp 'font-lock-cache-position) | 1766 | (if (boundp 'font-lock-cache-position) |
| 1766 | (or font-lock-cache-position | 1767 | (or font-lock-cache-position |
| @@ -1811,6 +1812,7 @@ hyperlinks as appropriate." | |||
| 1811 | "Return a list of files under DIRECTORY. | 1812 | "Return a list of files under DIRECTORY. |
| 1812 | Strips any leading \"./\" from each filename." | 1813 | Strips any leading \"./\" from each filename." |
| 1813 | ;;(message "hfy-list-files");;DBUG | 1814 | ;;(message "hfy-list-files");;DBUG |
| 1815 | ;; FIXME: this changes the dir of the currrent buffer. Is that right?? | ||
| 1814 | (cd directory) | 1816 | (cd directory) |
| 1815 | (mapcar (lambda (F) (if (string-match "^./\\(.*\\)" F) (match-string 1 F) F)) | 1817 | (mapcar (lambda (F) (if (string-match "^./\\(.*\\)" F) (match-string 1 F) F)) |
| 1816 | (split-string (shell-command-to-string hfy-find-cmd))) ) | 1818 | (split-string (shell-command-to-string hfy-find-cmd))) ) |
| @@ -1995,7 +1997,7 @@ FILE is the specific file we are rendering." | |||
| 1995 | (rmap-line nil) | 1997 | (rmap-line nil) |
| 1996 | (tag-regex (hfy-word-regex TAG)) | 1998 | (tag-regex (hfy-word-regex TAG)) |
| 1997 | (tag-map (gethash TAG cache-hash)) | 1999 | (tag-map (gethash TAG cache-hash)) |
| 1998 | (tag-files (mapcar (lambda (X) (car X)) tag-map))) | 2000 | (tag-files (mapcar #'car tag-map))) |
| 1999 | ;; find instances of TAG and do what needs to be done: | 2001 | ;; find instances of TAG and do what needs to be done: |
| 2000 | (goto-char (point-min)) | 2002 | (goto-char (point-min)) |
| 2001 | (while (search-forward TAG nil 'NOERROR) | 2003 | (while (search-forward TAG nil 'NOERROR) |
| @@ -2098,17 +2100,17 @@ FILE is the specific file we are rendering." | |||
| 2098 | (setq tag-point (round (string-to-number (match-string 3)))) | 2100 | (setq tag-point (round (string-to-number (match-string 3)))) |
| 2099 | (setq hash-entry (gethash tag-string cache-hash)) | 2101 | (setq hash-entry (gethash tag-string cache-hash)) |
| 2100 | (setq new-entry (list etags-file tag-line tag-point)) | 2102 | (setq new-entry (list etags-file tag-line tag-point)) |
| 2101 | (setq hash-entry (cons new-entry hash-entry)) | 2103 | (push new-entry hash-entry) |
| 2102 | ;;(message "HASH-ENTRY %s %S" tag-string new-entry) | 2104 | ;;(message "HASH-ENTRY %s %S" tag-string new-entry) |
| 2103 | (puthash tag-string hash-entry cache-hash)))) ))) | 2105 | (puthash tag-string hash-entry cache-hash)))) ))) |
| 2104 | 2106 | ||
| 2105 | ;; cache a list of tags in descending length order: | 2107 | ;; cache a list of tags in descending length order: |
| 2106 | (maphash (lambda (K V) (setq tags-list (cons K tags-list))) cache-hash) | 2108 | (maphash (lambda (K V) (push K tags-list)) cache-hash) |
| 2107 | (setq tags-list (sort tags-list (lambda (A B) (< (length B) (length A))))) | 2109 | (setq tags-list (sort tags-list (lambda (A B) (< (length B) (length A))))) |
| 2108 | 2110 | ||
| 2109 | ;; put the tag list into the cache: | 2111 | ;; put the tag list into the cache: |
| 2110 | (if tlist-cache (setcar (cdr tlist-cache) tags-list) | 2112 | (if tlist-cache (setcar (cdr tlist-cache) tags-list) |
| 2111 | (setq hfy-tags-sortl (cons (list srcdir tags-list) hfy-tags-sortl))) | 2113 | (push (list srcdir tags-list) hfy-tags-sortl)) |
| 2112 | 2114 | ||
| 2113 | ;; return the number of tags found: | 2115 | ;; return the number of tags found: |
| 2114 | (length tags-list) )) | 2116 | (length tags-list) )) |
| @@ -2134,36 +2136,33 @@ DSTDIR is the output directory, where files will be written." | |||
| 2134 | (setq cache-hash (cadr cache-entry)) | 2136 | (setq cache-hash (cadr cache-entry)) |
| 2135 | (setq index-buf (get-buffer-create index-file)))) | 2137 | (setq index-buf (get-buffer-create index-file)))) |
| 2136 | nil ;; noop | 2138 | nil ;; noop |
| 2137 | (maphash (lambda (K V) (setq tag-list (cons K tag-list))) cache-hash) | 2139 | (maphash (lambda (K V) (push K tag-list)) cache-hash) |
| 2138 | (setq tag-list (sort tag-list 'string<)) | 2140 | (setq tag-list (sort tag-list 'string<)) |
| 2139 | (set-buffer index-buf) | 2141 | (set-buffer index-buf) |
| 2140 | (erase-buffer) | 2142 | (erase-buffer) |
| 2141 | (insert (funcall hfy-page-header filename "<!-- CSS -->")) | 2143 | (insert (funcall hfy-page-header filename "<!-- CSS -->")) |
| 2142 | (insert "<table class=\"index\">\n") | 2144 | (insert "<table class=\"index\">\n") |
| 2143 | 2145 | ||
| 2144 | (mapc | 2146 | (dolist (TAG tag-list) |
| 2145 | (lambda (TAG) | 2147 | (let ((tag-started nil)) |
| 2146 | (let ((tag-started nil)) | 2148 | (dolist (DEF (gethash TAG cache-hash)) |
| 2147 | (mapc | 2149 | (if (and stub (not (string-match (concat "^" stub) TAG))) |
| 2148 | (lambda (DEF) | 2150 | nil ;; we have a stub and it didn't match: NOOP |
| 2149 | (if (and stub (not (string-match (concat "^" stub) TAG))) | 2151 | (let ((file (car DEF)) |
| 2150 | nil ;; we have a stub and it didn't match: NOOP | 2152 | (line (cadr DEF))) |
| 2151 | (let ((file (car DEF)) | 2153 | (insert |
| 2152 | (line (cadr DEF))) | 2154 | (format |
| 2153 | (insert | 2155 | (concat |
| 2154 | (format | 2156 | " <tr> \n" |
| 2155 | (concat | 2157 | " <td>%s</td> \n" |
| 2156 | " <tr> \n" | 2158 | " <td><a href=\"%s%s\">%s</a></td> \n" |
| 2157 | " <td>%s</td> \n" | 2159 | " <td><a href=\"%s%s#%s.%d\">%d</a></td>\n" |
| 2158 | " <td><a href=\"%s%s\">%s</a></td> \n" | 2160 | " </tr> \n") |
| 2159 | " <td><a href=\"%s%s#%s.%d\">%d</a></td>\n" | 2161 | (if (string= TAG tag-started) " " |
| 2160 | " </tr> \n") | 2162 | (format "<a name=\"%s\">%s</a>" TAG TAG)) |
| 2161 | (if (string= TAG tag-started) " " | 2163 | file (or hfy-link-extn hfy-extn) file |
| 2162 | (format "<a name=\"%s\">%s</a>" TAG TAG)) | 2164 | file (or hfy-link-extn hfy-extn) TAG line line)) |
| 2163 | file (or hfy-link-extn hfy-extn) file | 2165 | (setq tag-started TAG)))))) |
| 2164 | file (or hfy-link-extn hfy-extn) TAG line line)) | ||
| 2165 | (setq tag-started TAG)))) | ||
| 2166 | (gethash TAG cache-hash)))) tag-list) | ||
| 2167 | (insert "</table>\n") | 2166 | (insert "</table>\n") |
| 2168 | (insert (funcall hfy-page-footer filename)) | 2167 | (insert (funcall hfy-page-footer filename)) |
| 2169 | (and dstdir (cd dstdir)) | 2168 | (and dstdir (cd dstdir)) |
| @@ -2237,20 +2236,15 @@ See: `hfy-tags-cache' and `hfy-tags-rmap'" | |||
| 2237 | (fwd-map (cadr (assoc srcdir hfy-tags-cache))) | 2236 | (fwd-map (cadr (assoc srcdir hfy-tags-cache))) |
| 2238 | (rev-map (cadr (assoc srcdir hfy-tags-rmap ))) | 2237 | (rev-map (cadr (assoc srcdir hfy-tags-rmap ))) |
| 2239 | (taglist (cadr (assoc srcdir hfy-tags-sortl)))) | 2238 | (taglist (cadr (assoc srcdir hfy-tags-sortl)))) |
| 2240 | (mapc | 2239 | (dolist (TAG taglist) |
| 2241 | (lambda (TAG) | 2240 | (setq def-list (gethash TAG fwd-map) |
| 2242 | (setq def-list (gethash TAG fwd-map) | 2241 | old-list (gethash TAG rev-map) |
| 2243 | old-list (gethash TAG rev-map) | 2242 | exc-list (mapcar (lambda (P) (list (car P) (cadr P))) def-list) |
| 2244 | new-list nil | 2243 | new-list nil) |
| 2245 | exc-list nil) | 2244 | (dolist (P old-list) |
| 2246 | (mapc | 2245 | (or (member (list (car P) (cadr P)) exc-list) |
| 2247 | (lambda (P) | 2246 | (push P new-list))) |
| 2248 | (setq exc-list (cons (list (car P) (cadr P)) exc-list))) def-list) | 2247 | (puthash TAG new-list rev-map)))) |
| 2249 | (mapc | ||
| 2250 | (lambda (P) | ||
| 2251 | (or (member (list (car P) (cadr P)) exc-list) | ||
| 2252 | (setq new-list (cons P new-list)))) old-list) | ||
| 2253 | (puthash TAG new-list rev-map)) taglist) )) | ||
| 2254 | 2248 | ||
| 2255 | (defun htmlfontify-run-etags (srcdir) | 2249 | (defun htmlfontify-run-etags (srcdir) |
| 2256 | "Load the etags cache for SRCDIR. | 2250 | "Load the etags cache for SRCDIR. |
| @@ -2264,11 +2258,11 @@ See `hfy-load-tags-cache'." | |||
| 2264 | ;; (message "foo: %S\nbar: %S" foo bar)) | 2258 | ;; (message "foo: %S\nbar: %S" foo bar)) |
| 2265 | 2259 | ||
| 2266 | (defun hfy-save-kill-buffers (buffer-list &optional dstdir) | 2260 | (defun hfy-save-kill-buffers (buffer-list &optional dstdir) |
| 2267 | (mapc (lambda (B) | 2261 | (dolist (B buffer-list) |
| 2268 | (set-buffer B) | 2262 | (set-buffer B) |
| 2269 | (and dstdir (file-directory-p dstdir) (cd dstdir)) | 2263 | (and dstdir (file-directory-p dstdir) (cd dstdir)) |
| 2270 | (save-buffer) | 2264 | (save-buffer) |
| 2271 | (kill-buffer B)) buffer-list) ) | 2265 | (kill-buffer B))) |
| 2272 | 2266 | ||
| 2273 | (defun htmlfontify-copy-and-link-dir (srcdir dstdir &optional f-ext l-ext) | 2267 | (defun htmlfontify-copy-and-link-dir (srcdir dstdir &optional f-ext l-ext) |
| 2274 | "Trawl SRCDIR and write fontified-and-hyperlinked output in DSTDIR. | 2268 | "Trawl SRCDIR and write fontified-and-hyperlinked output in DSTDIR. |
| @@ -2291,8 +2285,8 @@ You may also want to set `hfy-page-header' and `hfy-page-footer'." | |||
| 2291 | (clrhash (cadr tr-cache)) | 2285 | (clrhash (cadr tr-cache)) |
| 2292 | (hfy-make-directory dstdir) | 2286 | (hfy-make-directory dstdir) |
| 2293 | (setq source-files (hfy-list-files srcdir)) | 2287 | (setq source-files (hfy-list-files srcdir)) |
| 2294 | (mapc (lambda (file) | 2288 | (dolist (file source-files) |
| 2295 | (hfy-copy-and-fontify-file srcdir dstdir file)) source-files) | 2289 | (hfy-copy-and-fontify-file srcdir dstdir file)) |
| 2296 | (hfy-subtract-maps srcdir) | 2290 | (hfy-subtract-maps srcdir) |
| 2297 | (hfy-save-kill-buffers (hfy-prepare-index srcdir dstdir) dstdir) | 2291 | (hfy-save-kill-buffers (hfy-prepare-index srcdir dstdir) dstdir) |
| 2298 | (hfy-save-kill-buffers (hfy-prepare-tag-map srcdir dstdir) dstdir) )) | 2292 | (hfy-save-kill-buffers (hfy-prepare-tag-map srcdir dstdir) dstdir) )) |
| @@ -2345,8 +2339,11 @@ You may also want to set `hfy-page-header' and `hfy-page-footer'." | |||
| 2345 | (custom-save-delete 'hfy-init-progn) | 2339 | (custom-save-delete 'hfy-init-progn) |
| 2346 | (setq start-pos (point)) | 2340 | (setq start-pos (point)) |
| 2347 | (princ "(hfy-init-progn\n;;auto-generated, only one copy allowed\n") | 2341 | (princ "(hfy-init-progn\n;;auto-generated, only one copy allowed\n") |
| 2342 | ;; FIXME: This saving&restoring of global customization | ||
| 2343 | ;; variables can interfere with other customization settings for | ||
| 2344 | ;; those vars (in .emacs or in Customize). | ||
| 2348 | (mapc 'hfy-save-initvar | 2345 | (mapc 'hfy-save-initvar |
| 2349 | (list 'auto-mode-alist 'interpreter-mode-alist)) | 2346 | '(auto-mode-alist interpreter-mode-alist)) |
| 2350 | (princ ")\n") | 2347 | (princ ")\n") |
| 2351 | (indent-region start-pos (point) nil)) | 2348 | (indent-region start-pos (point) nil)) |
| 2352 | (custom-save-all) )) | 2349 | (custom-save-all) )) |