;;; htmlfontify.el --- htmlise a buffer/source tree with optional hyperlinks
-;; Copyright (C) 2002, 2003, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2003, 2009-2011 Free Software Foundation, Inc.
;; Emacs Lisp Archive Entry
;; Package: htmlfontify
;; Compatibility: Emacs23, Emacs22
;; Incompatibility: Emacs19, Emacs20, Emacs21
;; Last Updated: Thu 2009-11-19 01:31:21 +0000
+;; Version: 0.21
;; This file is part of GNU Emacs.
;; (`font-lock-fontify-region')
(require 'cus-edit)
-(eval-and-compile
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; I want these - can't be bothered requiring all of cl though.
- (if (not (fboundp 'caddr))
- (defun caddr (list)
- "Return the `car' of the `cddr' of LIST."
- (car (cddr list))))
-
- (if (not (fboundp 'cadddr))
- (defun cadddr (list)
- "Return the `cadr' of the `cddr' of LIST."
- (cadr (cddr list))))
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
- (autoload
- 'htmlfontify-load-rgb-file
- "hfy-cmap"
- "Load an rgb.txt file for colour name -> rgb translation purposes."
- 'interactive)
-
- (autoload
- 'htmlfontify-unload-rgb-file
- "hfy-cmap"
- "Unload the current colour name -> rgb translation map."
- 'interactive)
-
- (autoload
- 'hfy-fallback-colour-values
- "hfy-cmap"
- "Use a fallback method for obtaining the rgb values for a colour."
- 'interactive)
- )
-
(defconst htmlfontify-version 0.21)
(defconst hfy-meta-tags
"The generator meta tag for this version of htmlfontify.")
(defconst htmlfontify-manual "Htmlfontify Manual"
- "Copy and convert buffers and files to html, adding hyperlinks between files
-\(driven by etags\) if requested.
+ "Copy and convert buffers and files to HTML, adding hyperlinks between files
+\(driven by etags) if requested.
\nInteractive functions:
`htmlfontify-buffer'
`htmlfontify-run-etags'
`htmlfontify-load-rgb-file'
`htmlfontify-unload-rgb-file'\n
In order to:\n
-fontify a file you have open: M-x htmlfontify-buffer
-prepare the etags map for a directory: M-x htmlfontify-run-etags
-copy a directory, fontifying as you go: M-x htmlfontify-copy-and-link-dir\n
+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
The following might be useful when running non-windowed or in batch mode:
-\(note that they shouldn't be necessary - we have a built in map\)\n
-load an X11 style rgb.txt file: M-x htmlfontify-load-rgb-file
-unload the current rgb.txt file: M-x htmlfontify-unload-rgb-file\n
+\(note that they shouldn't be necessary - we have a built in map)\n
+load an X11 style rgb.txt file: \\[htmlfontify-load-rgb-file]
+unload the current rgb.txt file: \\[htmlfontify-unload-rgb-file]\n
And here's a programmatic example:\n
-\(defun rtfm-build-page-header \(file style\)
- \(format \"#define TEMPLATE red+black.html
+\(defun rtfm-build-page-header (file style)
+ (format \"#define TEMPLATE red+black.html
#define DEBUG 1
#include <build/menu-dirlist|>\\n
html-css-url := /css/red+black.css
-title := rtfm.etla.org \( %s / src/%s \)
+title := rtfm.etla.org ( %s / src/%s )
bodytag :=
head <=STYLESHEET;\\n
%s
STYLESHEET
main-title := rtfm / %s / src/%s\\n
-main-content <=MAIN_CONTENT;\\n\" rtfm-section file style rtfm-section file\)\)
-
-\(defun rtfm-build-page-footer \(file\) \"\\nMAIN_CONTENT\\n\"\)
-
-\(defun rtfm-build-source-docs \(section srcdir destdir\)
- \(interactive
- \"s section[eg- emacs / p4-blame]:\\nD source-dir: \\nD output-dir: \"\)
- \(require 'htmlfontify\)
- \(hfy-load-tags-cache srcdir\)
- \(let \(\(hfy-page-header 'rtfm-build-page-header\)
- \(hfy-page-footer 'rtfm-build-page-footer\)
- \(rtfm-section section\)
- \(hfy-index-file \"index\"\)\)
- \(htmlfontify-run-etags srcdir\)
- \(htmlfontify-copy-and-link-dir srcdir destdir \".src\" \".html\"\)\)\)")
+main-content <=MAIN_CONTENT;\\n\" rtfm-section file style rtfm-section file))
+
+\(defun rtfm-build-page-footer (file) \"\\nMAIN_CONTENT\\n\")
+
+\(defun rtfm-build-source-docs (section srcdir destdir)
+ (interactive
+ \"s section[eg- emacs / p4-blame]:\\nD source-dir: \\nD output-dir: \")
+ (require 'htmlfontify)
+ (hfy-load-tags-cache srcdir)
+ (let ((hfy-page-header 'rtfm-build-page-header)
+ (hfy-page-footer 'rtfm-build-page-footer)
+ (rtfm-section section)
+ (hfy-index-file \"index\"))
+ (htmlfontify-run-etags srcdir)
+ (htmlfontify-copy-and-link-dir srcdir destdir \".src\" \".html\")))")
(defgroup htmlfontify nil
- "Copy and convert buffers and files to html, adding hyperlinks between
-files \(driven by etags\) if requested.\n
-See: `htmlfontify-manual'"
+ "Convert buffers and files to HTML."
:group 'applications
+ :link '(variable-link htmlfontify-manual)
:prefix "hfy-")
(defcustom hfy-page-header 'hfy-default-header
- "*Function called with two arguments \(the filename relative to the top
-level source directory being etag\'d and fontified), and a string containing
-the <style>...</style> text to embed in the document- the string returned will
-be used as the header for the htmlfontified version of the source file.\n
-See also: `hfy-page-footer'"
+ "Function called to build the header of the html source.
+This is called with two arguments (the filename relative to the top
+level source directory being etag'd and fontified), and a string containing
+the <style>...</style> text to embed in the document.
+It should return the string returned will be used as the header for the
+htmlfontified version of the source file.\n
+See also `hfy-page-footer'."
:group 'htmlfontify
+ ;; FIXME: Why place such a :tag everywhere? Isn't it imposing your
+ ;; own Custom preference on your users? --Stef
:tag "page-header"
:type '(function))
(defcustom hfy-split-index nil
- "*Whether or not to split the index `hfy-index-file' alphabetically
-on the first letter of each tag. Useful when the index would otherwise
+ "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.
+Useful when the index would otherwise
be large and take a long time to render or be difficult to navigate."
:group 'htmlfontify
:tag "split-index"
:type '(boolean))
(defcustom hfy-page-footer 'hfy-default-footer
- "*As `hfy-page-header', but generates the output footer
-\(and takes only 1 argument, the filename\)."
+ "As `hfy-page-header', but generates the output footer.
+It takes only one argument, the filename."
:group 'htmlfontify
:tag "page-footer"
:type '(function))
(defcustom hfy-extn ".html"
- "*File extension used for output files."
+ "File extension used for output files."
:group 'htmlfontify
:tag "extension"
:type '(string))
(defcustom hfy-src-doc-link-style "text-decoration: underline;"
- "*String to add to the \'<style> a\' variant of an htmlfontify css class."
+ "String to add to the '<style> a' variant of an htmlfontify CSS class."
:group 'htmlfontify
:tag "src-doc-link-style"
:type '(string))
(defcustom hfy-src-doc-link-unstyle " text-decoration: none;"
- "*Regex to remove from the <style> a variant of an htmlfontify css class."
+ "Regex to remove from the <style> a variant of an htmlfontify CSS class."
:group 'htmlfontify
:tag "src-doc-link-unstyle"
:type '(string))
(defcustom hfy-link-extn nil
- "*File extension used for href links - Useful where the htmlfontify
-output files are going to be processed again, with a resulting change
-in file extension. If nil, then any code using this should fall back
-to `hfy-extn'."
+ "File extension used for href links.
+Useful where the htmlfontify output files are going to be processed
+again, with a resulting change in file extension. If nil, then any
+code using this should fall back to `hfy-extn'."
:group 'htmlfontify
:tag "link-extension"
:type '(choice string (const nil)))
(defcustom hfy-link-style-fun 'hfy-link-style-string
- "*Set this to a function, which will be called with one argument
-\(a \"{ foo: bar; ...}\" css style-string\) - it should return a copy of
+ "Function to customize the appearance of hyperlinks.
+Set this to a function, which will be called with one argument
+\(a \"{ foo: bar; ...}\" CSS style-string) - it should return a copy of
its argument, altered so as to make any changes you want made for text which
is a hyperlink, in addition to being in the class to which that style would
normally be applied."
:tag "link-style-function"
:type '(function))
-(defcustom hfy-index-file "hfy-index"
- "*Name \(sans extension\) of the tag definition index file produced during
+(defcustom hfy-index-file "hfy-index"
+ "Name (sans extension) of the tag definition index file produced during
fontification-and-hyperlinking."
:group 'htmlfontify
:tag "index-file"
:type '(string))
-(defcustom hfy-instance-file "hfy-instance"
- "*Name \(sans extension\) of the tag usage index file produced during
+(defcustom hfy-instance-file "hfy-instance"
+ "Name (sans extension) of the tag usage index file produced during
fontification-and-hyperlinking."
:group 'htmlfontify
:tag "instance-file"
:type '(string))
-(defcustom hfy-html-quote-regex "\\(<\\|\"\\|&\\|>\\)"
- "*Regex to match \(with a single back-reference per match\) strings in HTML
-which should be quoted with `hfy-html-quote' \(and `hfy-html-quote-map'\)
+(defcustom hfy-html-quote-regex "\\([<\"&>]\\)"
+ "Regex to match (with a single back-reference per match) strings in HTML
+which should be quoted with `hfy-html-quote' (and `hfy-html-quote-map')
to make them safe."
:group 'htmlfontify
:tag "html-quote-regex"
:type '(regexp))
-(defcustom hfy-init-kludge-hooks '(hfy-kludge-cperl-mode)
- "*List of functions to call when starting htmlfontify-buffer to do any
-kludging necessary to get highlighting modes to bahave as you want, even
+(define-obsolete-variable-alias 'hfy-init-kludge-hooks 'hfy-init-kludge-hook
+ "23.2")
+(defcustom hfy-init-kludge-hook '(hfy-kludge-cperl-mode)
+ "List of functions to call when starting `htmlfontify-buffer' to do any
+kludging necessary to get highlighting modes to behave as you want, even
when not running under a window system."
:group 'htmlfontify
:tag "init-kludge-hooks"
:type '(hook))
(defcustom hfy-post-html-hooks nil
- "*List of functions to call after creating and filling the html buffer.
-These functions will be called with the html buffer as the current buffer"
+ "List of functions to call after creating and filling the HTML buffer.
+These functions will be called with the html buffer as the current buffer."
:group 'htmlfontify
:tag "post-html-hooks"
:options '(set-auto-mode)
:type '(hook))
(defcustom hfy-default-face-def nil
- "*Fallback `defface' specification for the face \'default, used when
-`hfy-display-class' has been set \(the normal htmlfontify way of extracting
-potentially non-current face information doesn\'t necessarily work for
-\'default\).\n
-Example: I customise this to:\n
-\(\(t :background \"black\" :foreground \"white\" :family \"misc-fixed\"\)\)"
+ "Fallback `defface' specification for the face 'default, used when
+`hfy-display-class' has been set (the normal htmlfontify way of extracting
+potentially non-current face information doesn't necessarily work for
+'default).\n
+Example: I customize this to:\n
+\((t :background \"black\" :foreground \"white\" :family \"misc-fixed\"))"
:group 'htmlfontify
:tag "default-face-definition"
:type '(alist))
"\x01" "\\([0-9]+\\)"
"," "\\([0-9]+\\)$"
"\\|" ".*\x7f[0-9]+,[0-9]+$")
- "*Regex used to parse an etags entry: must have 3 subexps, corresponding,
+ "Regex used to parse an etags entry: must have 3 subexps, corresponding,
in order, to:\n
1 - The tag
2 - The line
- 3 - The char \(point\) at which the tag occurs."
+ 3 - The char (point) at which the tag occurs."
:group 'htmlfontify
:tag "etag-regex"
:type '(regexp))
("<" "<" )
("&" "&" )
(">" ">" ))
- "*Alist of char -> entity mappings used to make the text html-safe."
+ "Alist of char -> entity mappings used to make the text HTML-safe."
:group 'htmlfontify
:tag "html-quote-map"
:type '(alist :key-type (string)))
(defcustom hfy-etags-cmd-alist
hfy-etags-cmd-alist-default
- "*Alist of possible shell commands that will generate etags output that
-`htmlfontify' can use. \'%s\' will be replaced by `hfy-etags-bin'."
+ "Alist of possible shell commands that will generate etags output that
+`htmlfontify' can use. '%s' will be replaced by `hfy-etags-bin'."
:group 'htmlfontify
:tag "etags-cmd-alist"
:type '(alist :key-type (string) :value-type (string)) ))
(defcustom hfy-etags-bin "etags"
- "*Location of etags binary (we begin by assuming it\'s in your path).\n
+ "Location of etags binary (we begin by assuming it's in your path).\n
Note that if etags is not in your path, you will need to alter the shell
commands in `hfy-etags-cmd-alist'."
:group 'htmlfontify
:type '(file))
(defcustom hfy-shell-file-name "/bin/sh"
- "*Shell (bourne or compatible) to invoke for complex shell operations."
+ "Shell (bourne or compatible) to invoke for complex shell operations."
:group 'htmlfontify
:tag "shell-file-name"
:type '(file))
+(defcustom hfy-ignored-properties '(read-only
+ intangible
+ modification-hooks
+ insert-in-front-hooks
+ insert-behind-hooks
+ point-entered
+ point-left)
+ "Properties to omit when copying a fontified buffer for HTML transformation."
+ :group 'htmlfontify
+ :tag "ignored-properties"
+ :type '(repeat symbol))
+
(defun hfy-which-etags ()
- "Return a string indicating which flavour of etags we are using."
+ "Return a string indicating which flavour of etags we are using."
(let ((v (shell-command-to-string (concat hfy-etags-bin " --version"))))
(cond ((string-match "exube" v) "exuberant ctags")
((string-match "GNU E" v) "emacs etags" )) ))
(defcustom hfy-etags-cmd
(eval-and-compile (cdr (assoc (hfy-which-etags) hfy-etags-cmd-alist)))
- "*The etags equivalent command to run in a source directory to generate a tags
+ "The etags equivalent command to run in a source directory to generate a tags
file for the whole source tree from there on down. The command should emit
the etags output on stdout.\n
-Two canned commands are provided - they drive Emacs\' etags and
-exuberant-ctags\' etags respectively."
+Two canned commands are provided - they drive Emacs' etags and
+exuberant-ctags' etags respectively."
:group 'htmlfontify
:tag "etags-command"
:type (eval-and-compile
(let ((clist (list '(string))))
- (mapc
- (lambda (C)
- (setq clist
- (cons (list 'const :tag (car C) (cdr C)) clist)))
- hfy-etags-cmd-alist)
+ (dolist (C hfy-etags-cmd-alist)
+ (push (list 'const :tag (car C) (cdr C)) clist))
(cons 'choice clist)) ))
(defcustom hfy-istext-command "file %s | sed -e 's@^[^:]*:[ \t]*@@'"
- "*Command to run with the name of a file, to see whether it is a text file
-or not. The command should emit a string containing the word \'text\' if
-the file is a text file, and a string not containing \'text\' otherwise."
+ "Command to run with the name of a file, to see whether it is a text file
+or not. The command should emit a string containing the word 'text' if
+the file is a text file, and a string not containing 'text' otherwise."
:group 'htmlfontify
:tag "istext-command"
:type '(string))
(defcustom hfy-find-cmd
"find . -type f \\! -name \\*~ \\! -name \\*.flc \\! -path \\*/CVS/\\*"
- "*Find command used to harvest a list of files to attempt to fontify."
+ "Find command used to harvest a list of files to attempt to fontify."
:group 'htmlfontify
:tag "find-command"
:type '(string))
(defcustom hfy-display-class nil
- "*Display class to use to determine which display class to use when
-calculating a face\'s attributes. This is useful when, for example, you
+ "Display class to use to determine which display class to use when
+calculating a face's attributes. This is useful when, for example, you
are running Emacs on a tty or in batch mode, and want htmlfontify to have
access to the face spec you would use if you were connected to an X display.\n
Some valid class specification elements are:\n
- \'\(class color\)
- \'\(class grayscale\)
- \'\(background dark\)
- \'\(background light\)
- \'\(type x-toolkit\)
- \'\(type tty\)
- \'\(type motif\)
- \'\(type lucid\)
+ '(class color)
+ '(class grayscale)
+ '(background dark)
+ '(background light)
+ '(type x-toolkit)
+ '(type tty)
+ '(type motif)
+ '(type lucid)
Multiple values for a tag may be combined, to indicate that any one or more
of these values in the specification key constitutes a match, eg:\n
-\'\(\(class color grayscale\) \(type tty\)\) would match any of:\n
- \'\(\(class color\)\)
- \'\(\(class grayscale\)\)
- \'\(\(class color grayscale\)\)\)
- \'\(\(class color foo\)\)
- \'\(\(type tty\)\)
- \'\(\(type tty\) \(class color\)\)\n
+'((class color grayscale) (type tty)) would match any of:\n
+ '((class color))
+ '((class grayscale))
+ '((class color grayscale))
+ '((class color foo))
+ '((type tty))
+ '((type tty) (class color))\n
and so on."
:type '(alist :key-type (symbol) :value-type (symbol))
:group 'htmlfontify
(const :tag "Bright" light ))) ))
(defcustom hfy-optimisations (list 'keep-overlays)
- "*Optimisations to turn on: So far, the following have been implemented:\n
+ "Optimizations to turn on: So far, the following have been implemented:\n
merge-adjacent-tags: If two (or more) span tags are adjacent, identical and
separated by nothing more than whitespace, they will
be merged into one span.
zap-string-links : Suppress hyperlinking of tags found in strings.
div-wrapper : Add <div class=\"default\"> </div> tags around the
output.
- keep-overlays : More of a bell \(or possibly whistle\) than an
- optimisation - If on, preserve overlay highlighting
- \(cf ediff or goo-font-lock\) as well as basic faces\n
+ 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
And the following are planned but not yet available:\n
kill-context-leak : Suppress hyperlinking between files highlighted by
different modes.\n
-Note: like compiler optimisations, these optimise the _output_ of the code,
+Note: like compiler optimizations, these optimize the _output_ of the code,
not the processing of the source itself, and are therefore likely to slow
-htmlfontify down, at least a little. Except for skip-refontification,
+htmlfontify down, at least a little. Except for skip-refontification,
which can never slow you down, but may result in incomplete fontification."
:type '(set (const :tag "merge-adjacent-tags" merge-adjacent-tags )
(const :tag "zap-comment-links" zap-comment-links )
(const :tag "div-wrapper" div-wrapper )
(const :tag "keep-overlays" keep-overlays ))
:group 'htmlfontify
- :tag "optimisations")
+ :tag "optimizations")
-(defvar hfy-tags-cache nil
+(defvar hfy-tags-cache nil
"Alist of the form:\n
-\(\(\"/src/dir/0\" . tag-hash0\) \(\"/src/dir/1\" tag-hash1\) ...\)\n
-Each tag hash entry then contains entries of the form:\n
+\((\"/src/dir/0\" . tag-hash0) (\"/src/dir/1\" tag-hash1) ...)\n
+Each tag hash entry then contains entries of the form:\n
\"tag_string\" => ((\"file/name.ext\" line char) ... )\n
-ie an alist mapping \(relative\) file paths to line and character offsets.\n
-See `hfy-load-tags-cache'.")
+ie an alist mapping (relative) file paths to line and character offsets.\n
+See also `hfy-load-tags-cache'.")
-(defvar hfy-tags-sortl nil
- "Alist of the form \(\(\"/src/dir\" . (tag0 tag1 tag2)\) ... \)\n
-Where the tags are stored in descending order of length.\n
-See `hfy-load-tags-cache'.")
+(defvar hfy-tags-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'.")
-(defvar hfy-tags-rmap nil
- "Alist of the form \(\(\"/src/dir\" . tag-rmap-hash\)\)\n
-Where tag-rmap-hash has entries of the form:
+(defvar hfy-tags-rmap nil
+ "Alist of the form ((\"/src/dir\" . tag-rmap-hash))\n
+where tag-rmap-hash has entries of the form:
\"tag_string\" => ( \"file/name.ext\" line char )
Unlike `hfy-tags-cache' these are the locations of occurrences of
tagged items, not the locations of their definitions.")
(defvar hfy-style-assoc 'please-ignore-this-line
"An assoc representing/describing an Emacs face.
-Properties may be repeated, In which case later properties should be
-treated as if they were inherited from a \'parent\' font.
+Properties may be repeated, in which case later properties should be
+treated as if they were inherited from a 'parent' font.
\(For some properties, only the first encountered value is of any importance,
for others the values might be cumulative, and for others they might be
-cumulative in a complex way).\n
+cumulative in a complex way.)\n
Some examples:\n
-\(hfy-face-to-style 'default\) =>
- \(\(\"background\" . \"rgb\(0, 0, 0\)\"\)
- \(\"color\" . \"rgb\(255, 255, 255\)\"\)
- \(\"font-style\" . \"normal\"\)
- \(\"font-weight\" . \"500\"\)
- \(\"font-stretch\" . \"normal\"\)
- \(\"font-family\" . \"misc-fixed\"\)
- \(\"font-size\" . \"13pt\"\)
- \(\"text-decoration\" . \"none\"\)\)\n
-\(hfy-face-to-style 'Info-title-3-face\) =>
- \(\(\"font-weight\" . \"700\"\)
- \(\"font-family\" . \"helv\"\)
- \(\"font-size\" . \"120%\"\)
- \(\"text-decoration\" . \"none\"\)\)\n")
+\(hfy-face-to-style 'default) =>
+ ((\"background\" . \"rgb(0, 0, 0)\")
+ (\"color\" . \"rgb(255, 255, 255)\")
+ (\"font-style\" . \"normal\")
+ (\"font-weight\" . \"500\")
+ (\"font-stretch\" . \"normal\")
+ (\"font-family\" . \"misc-fixed\")
+ (\"font-size\" . \"13pt\")
+ (\"text-decoration\" . \"none\"))\n
+\(hfy-face-to-style 'Info-title-3-face) =>
+ ((\"font-weight\" . \"700\")
+ (\"font-family\" . \"helv\")
+ (\"font-size\" . \"120%\")
+ (\"text-decoration\" . \"none\"))\n")
(defvar hfy-sheet-assoc 'please-ignore-this-line
- "An assoc with elements of the form (face-name style-name . stlye-string):\n
-'\(\(default \"default\" . \"{background: black;color: white}\"\)
- \(font-lock-string-face \"string\" . \"{color: rgb\(64,224,208\)}\"\)\)" )
+ "An assoc with elements of the form (face-name style-name . style-string):\n
+'((default \"default\" . \"{background: black; color: white}\")
+ (font-lock-string-face \"string\" . \"{color: rgb(64,224,208)}\"))" )
(defvar hfy-facemap-assoc 'please-ignore-this-line
- "An assoc of \(point . FACE-SYMBOL\) or \(point . DEFFACE-LIST\)
+ "An assoc of (point . FACE-SYMBOL) or (point . DEFFACE-LIST)
and (point . 'end) elements, in descending order of point value
-\(ie from the file's end to its beginning\).\n
-The map is in reverse order because inserting a <style> tag \(or any other
-string) at POINT invalidates the map for all entries with a greater value of
-point. By traversing the map from greatest to least POINT, we still invalidate
-the map as we go, but only those points we have already dealt with \( and
-therefore no longer care about \) will be invalid at any time.\n
-'\(\(64820 . end\)
- \(64744 . font-lock-comment-face\)
- \(64736 . end\)
- \(64722 . font-lock-string-face\)
- \(64630 . end\)
- \(64623 . font-lock-string-face\)
- \(64449 . end\)
- \(64446 . font-lock-keyword-face\)
- \(64406 . end\)
- \(64395 . font-lock-constant-face\)
- \(64393 . end\)
- \(64386 . font-lock-keyword-face\)
- \(64379 . end\)
+\(ie from the file's end to its beginning).\n
+The map is in reverse order because inserting a <style> tag (or any other
+string) at `point' invalidates the map for all entries with a greater value of
+point. By traversing the map from greatest to least point, we still invalidate
+the map as we go, but only those points we have already dealt with (and
+therefore no longer care about) will be invalid at any time.\n
+'((64820 . end)
+ (64744 . font-lock-comment-face)
+ (64736 . end)
+ (64722 . font-lock-string-face)
+ (64630 . end)
+ (64623 . font-lock-string-face)
+ (64449 . end)
+ (64446 . font-lock-keyword-face)
+ (64406 . end)
+ (64395 . font-lock-constant-face)
+ (64393 . end)
+ (64386 . font-lock-keyword-face)
+ (64379 . end)
;; big similar section elided. You get the idea.
- \(4285 . font-lock-constant-face\)
- \(4285 . end\)
- \(4221 . font-lock-comment-face\)
- \(4221 . end\)
- \(4197 . font-lock-constant-face\)
- \(4197 . end\)
- \(1 . font-lock-comment-face\)\)")
+ (4285 . font-lock-constant-face)
+ (4285 . end)
+ (4221 . font-lock-comment-face)
+ (4221 . end)
+ (4197 . font-lock-constant-face)
+ (4197 . end)
+ (1 . font-lock-comment-face))")
(defvar hfy-tmpfont-stack nil
"An alist of derived fonts resulting from overlays.")
"\\(" hfy-hex-regex hfy-hex-regex "\\)"))
(defun hfy-interq (set-a set-b)
- "Return the intersection \(using `eq'\) of 2 lists SET-A and SET-B."
+ "Return the intersection (using `eq') of two lists SET-A and SET-B."
(let ((sa set-a) (interq nil) (elt nil))
(while sa
(setq elt (car sa)
sa (cdr sa))
- (if (memq elt set-b) (setq interq (cons elt interq)))) interq))
+ (if (memq elt set-b) (setq interq (cons elt interq))))
+ interq))
(defun hfy-colour-vals (colour)
- "Where COLOUR is a colour name or #XXXXXX style triplet, return a
-list of 3 (16 bit) rgb values for said colour.\n
+ "Where COLOUR is a color name or #XXXXXX style triplet, return a
+list of three (16 bit) rgb values for said color.\n
If a window system is unavailable, calls `hfy-fallback-colour-values'."
(if (string-match hfy-triplet-regex colour)
(mapcar
- (lambda (x)
- (* (string-to-number (match-string x colour) 16) 257)) '(1 2 3))
+ (lambda (x) (* (string-to-number (match-string x colour) 16) 257))
+ '(1 2 3))
;;(message ">> %s" colour)
(if window-system
(if (fboundp 'color-values)
(setq cperl-syntaxify-by-font-lock t)))
(setq hfy-cperl-mode-kludged-p t))) )
-(defun hfy-opt (symbol) "Is option SYMBOL set." (memq symbol hfy-optimisations))
+(defun hfy-opt (symbol) "Is option SYMBOL set."
+ (memq symbol hfy-optimisations))
(defun hfy-default-header (file style)
"Default value for `hfy-page-header'.
// whether the current row is odd or even
var even = false;
- // if arguments are provided to specify the colours
+ // if arguments are provided to specify the colors
// of the even & odd rows, then use the them;
// otherwise use the following defaults:
var evenColor = arguments[1] ? arguments[1] : \"#fff\";
}
}
}
+
+ function toggle_invis( name )
+ {
+ var filter =
+ { acceptNode:
+ function( node )
+ { var classname = node.id;
+ if( classname )
+ { var classbase = classname.substr( 0, name.length );
+ if( classbase == name ) { return NodeFilter.FILTER_ACCEPT; } }
+ return NodeFilter.FILTER_SKIP; } };
+ var walker = document.createTreeWalker( document.body ,
+ NodeFilter.SHOW_ELEMENT ,
+ filter ,
+ false );
+ while( walker.nextNode() )
+ {
+ var e = walker.currentNode;
+ if( e.style.display == \"none\" ) { e.style.display = \"inline\"; }
+ else { e.style.display = \"none\"; }
+ }
+ }
--> </script>
</head>
<body onload=\"stripe('index'); return true;\">\n"
"\n </body>\n</html>\n")
(defun hfy-link-style-string (style-string)
- "Replace the end of a css style declaration STYLE-STRING with the contents
+ "Replace the end of a CSS style declaration STYLE-STRING with the contents
of the variable `hfy-src-doc-link-style', removing text matching the regex
`hfy-src-doc-link-unstyle' first, if necessary."
;;(message "hfy-colour-vals");;DBUG
(concat (replace-match hfy-src-doc-link-style
'fixed-case
'literal
- style-string) " }") style-string))
+ style-string) " }")
+ style-string))
;; utility functions - cast emacs style specification values into their
;; css2 equivalents:
(defun hfy-triplet (colour)
- "Takes a COLOUR name \(string\) and return a CSS rgb(R, G, B) triplet string.
+ "Takes a COLOUR name (string) and return a CSS rgb(R, G, B) triplet string.
Uses the definition of \"white\" to map the numbers to the 0-255 range, so
-if you\'ve redefined white, \(esp if you've redefined it to have a triplet
-member lower than that of the colour you are processing, strange things
-may happen\)."
+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."
;;(message "hfy-colour-vals");;DBUG
(let ((white (mapcar (lambda (I) (float (1+ I))) (hfy-colour-vals "white")))
(rgb16 (mapcar (lambda (I) (float (1+ I))) (hfy-colour-vals colour))))
(apply 'format "#%02x%02x%02x"
(mapcar (lambda (X)
(* (/ (nth X rgb16)
- (nth X white)) 255)) '(0 1 2))))) )
+ (nth X white)) 255))
+ '(0 1 2))))))
(defun hfy-family (family) (list (cons "font-family" family)))
(defun hfy-bgcol (colour) (list (cons "background" (hfy-triplet colour))))
:type 'float
:group 'htmlfontify)
-(defun hfy-size (height)
+(defun hfy-size (height)
"Derive a CSS font-size specifier from an Emacs font :height attribute HEIGHT.
Does not cope with the case where height is a function to be applied to
the height of the underlying font."
((integerp height)
(cons "font-size" (format "%dpt" (/ (* hfy-font-zoom height) 10 )))) )) )
-(defun hfy-slant (slant)
- "Derive a font-style css specifier from the Emacs :slant attribute SLANT:
+(defun hfy-slant (slant)
+ "Derive a font-style CSS specifier from the Emacs :slant attribute SLANT:
CSS does not define the reverse-* styles, so just maps those to the
regular specifiers."
- (list (cons "font-style" (cond ((eq 'italic slant) "italic" )
- ((eq 'reverse-italic slant) "italic" )
- ((eq 'oblique slant) "oblique")
- ((eq 'reverse-oblique slant) "oblique")
- (t "normal" )))) )
+ (list (cons "font-style"
+ (or (cdr (assq slant '((italic . "italic")
+ (reverse-italic . "italic" )
+ (oblique . "oblique")
+ (reverse-oblique . "oblique"))))
+ "normal"))))
(defun hfy-weight (weight)
- "Derive a font-weight css specifier from an Emacs weight spec symbol WEIGHT."
- (list (cons "font-weight" (cond ((eq 'ultra-bold weight) "900")
- ((eq 'extra-bold weight) "800")
- ((eq 'bold weight) "700")
- ((eq 'semi-bold weight) "600")
- ((eq 'normal weight) "500")
- ((eq 'semi-light weight) "400")
- ((eq 'light weight) "300")
- ((eq 'extra-light weight) "200")
- ((eq 'ultra-light weight) "100")))) )
+ "Derive a font-weight CSS specifier from an Emacs weight spec symbol WEIGHT."
+ (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")))))))
(defun hfy-box-to-border-assoc (spec)
(if spec
(let ((tag (car spec))
(val (cadr spec)))
- (cons (cond ((eq tag :color) (cons "colour" val))
- ((eq tag :width) (cons "width" val))
- ((eq tag :style) (cons "style" val)))
- (hfy-box-to-border-assoc (cddr spec))))) )
+ (cons (case tag
+ (:color (cons "colour" val))
+ (:width (cons "width" val))
+ (:style (cons "style" val)))
+ (hfy-box-to-border-assoc (cddr spec))))))
(defun hfy-box-to-style (spec)
(let* ((css (hfy-box-to-border-assoc spec))
(list
(if col (cons "border-color" (cdr (assoc "colour" css))))
(cons "border-width" (format "%dpx" (or (cdr (assoc "width" css)) 1)))
- (cons "border-style" (cond ((eq s 'released-button) "outset")
- ((eq s 'pressed-button ) "inset" )
- (t "solid" ))))) )
+ (cons "border-style" (case s
+ (released-button "outset")
+ (pressed-button "inset" )
+ (t "solid" ))))))
(defun hfy-box (box)
"Derive CSS border-* attributes from the Emacs :box attribute BOX."
VAL is ignored."
(list
;; FIXME: Why not '("text-decoration" . "underline")? --Stef
- (cond ((eq tag :underline ) (cons "text-decoration" "underline" ))
- ((eq tag :overline ) (cons "text-decoration" "overline" ))
- ((eq tag :strike-through) (cons "text-decoration" "line-through")))))
+ (case tag
+ (:underline (cons "text-decoration" "underline" ))
+ (:overline (cons "text-decoration" "overline" ))
+ (:strike-through (cons "text-decoration" "line-through")))))
(defun hfy-invisible (&optional val)
"This text should be invisible.
(defun hfy-combined-face-spec (face)
"Return a `defface' style alist of possible specifications for FACE.
-Entries resulting from customisation \(`custom-set-faces'\) will take
+Entries resulting from customization (`custom-set-faces') will take
precedence."
- (let ((spec nil))
- (setq spec (append (or (get face 'saved-face) (list))
- (or (get face 'face-defface-spec) (list))))
- (if (and hfy-display-class hfy-default-face-def (eq face 'default))
- (setq spec (append hfy-default-face-def spec))) spec))
+ (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)))
(defun hfy-face-attr-for-class (face &optional class)
"Return the face attributes for FACE.
-If CLASS is set, it must be a `defface' alist key \[see below\],
+If CLASS is set, it must be a `defface' alist key [see below],
in which case the first face specification returned by `hfy-combined-face-spec'
-which *doesn\'t* clash with CLASS is returned.\n
+which *doesn't* clash with CLASS is returned.\n
\(A specification with a class of t is considered to match any class you
-specify - this matches Emacs\' behaviour when deciding on which face attributes
-to use, to the best of my understanding\).\n
+specify - this matches Emacs' behavior when deciding on which face attributes
+to use, to the best of my understanding).\n
If CLASS is nil, then you just get get whatever `face-attr-construct' returns,
ie the current specification in effect for FACE.\n
-*NOTE* This function forces any face that is not \'default and which has
-no :inherit property to inherit from \'default \( this is because \'default
+*NOTE*: This function forces any face that is not 'default and which has
+no :inherit property to inherit from 'default (this is because 'default
is magical in that Emacs' fonts behave as if they inherit implicitly from
-\'default, but no such behaviour exists in HTML/CSS \).\n
-See `hfy-display-class' for details of valid values for CLASS."
- (let ((face-spec nil))
- (setq
- face-spec
- (if class
- (let ((face-props (hfy-combined-face-spec face))
- (face-specn nil)
- (face-class nil)
- (face-attrs nil)
- (face-score -1)
- (face-match nil))
- (while face-props
- (setq face-specn (car face-props)
- face-class (car face-specn)
- face-attrs (cdr face-specn)
- face-props (cdr face-props))
- ;; if the current element CEL of CLASS is t we match
- ;; if the current face-class is t, we match
- ;; if the cdr of CEL has a non-nil
- ;; intersection with the cdr of the first member of
- ;; the current face-class with the same car as CEL, we match
- ;; if we actually clash, then we can't match
- (let ((cbuf class)
- (cel nil)
- (key nil)
- (val nil)
- (x nil)
- (next nil)
- (score 0))
- (while (and cbuf (not next))
- (setq cel (car cbuf)
- cbuf (cdr cbuf)
- key (car cel)
- val (cdr cel)
- val (if (listp val) val (list val)))
- (cond
- ((or (eq cel t) (memq face-class '(t default)));;default match
- (setq score 0) (ignore "t match"))
- ((not (cdr (assq key face-class))) ;; neither good nor bad
- nil (ignore "non match, non collision"))
- ((setq x (hfy-interq val (cdr (assq key face-class))))
- (setq score (+ score (length x)))
- (ignore "intersection"))
- (t ;; nope.
- (setq next t score -10) (ignore "collision")) ))
- (if (> score face-score)
- (progn
- (setq face-match face-attrs
- face-score score )
- (ignore "%d << %S/%S" score face-class class))
- (ignore "--- %d ---- (insufficient)" score)) ))
- ;; matched ? last attrs : nil
- (if face-match
- (if (listp (car face-match)) (car face-match) face-match) nil))
- ;; Unfortunately the default face returns a
- ;; :background. Fortunately we can remove it, but how do we do
- ;; that in a non-system specific way?
- (let ((spec (face-attr-construct face))
- (new-spec nil))
- (if (not (memq :background spec))
- spec
- (while spec
- (let ((a (nth 0 spec))
- (b (nth 1 spec)))
- (unless (and (eq a :background)
- (stringp b)
- (string= b "SystemWindow"))
- (setq new-spec (cons a (cons b new-spec)))))
- (setq spec (cddr spec)))
- new-spec)) ))
+'default, but no such behavior exists in HTML/CSS).\n
+See also `hfy-display-class' for details of valid values for CLASS."
+ (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)))))
(if (or (memq :inherit face-spec) (eq 'default face))
face-spec
- (nconc face-spec (list :inherit 'default))) ))
+ (append face-spec (list :inherit 'default)))))
;; construct an assoc of (css-tag-name . css-tag-value) pairs
;; from a face or assoc of face attributes:
;; :height 98 :width normal :family "outline-courier new")
(defun hfy-face-to-style-i (fn)
"The guts of `hfy-face-to-style': FN should be a `defface' font spec,
-as returned by `face-attr-construct' or `hfy-face-attr-for-class'. Note
-that this function does not get font-sizes right if they are based on
-inherited modifiers \(via the :inherit\) attribute, and any other
+as returned by `face-attr-construct' or `hfy-face-attr-for-class'.
+Note that this function does not get font-sizes right if they are based
+on inherited modifiers (via the :inherit) attribute, and any other
modifiers that are cumulative if they appear multiple times need to be
merged by the user - `hfy-flatten-style' should do this."
;;(message "hfy-face-to-style-i");;DBUG
(hfy-face-to-style-i
(hfy-face-attr-for-class v hfy-display-class)) ))))
(setq this
- (if val (cond
- ((eq key :family ) (hfy-family val))
- ((eq key :width ) (hfy-width val))
- ((eq key :weight ) (hfy-weight val))
- ((eq key :slant ) (hfy-slant val))
- ((eq key :foreground ) (hfy-colour val))
- ((eq key :background ) (hfy-bgcol val))
- ((eq key :box ) (hfy-box val))
- ((eq key :height ) (hfy-size val))
- ((eq key :underline ) (hfy-decor key val))
- ((eq key :overline ) (hfy-decor key val))
- ((eq key :strike-through) (hfy-decor key val))
- ((eq key :invisible ) (hfy-invisible val))
- ((eq key :bold ) (hfy-weight 'bold))
- ((eq key :italic ) (hfy-slant 'italic))))))
+ (if val (case key
+ (:family (hfy-family val))
+ (:width (hfy-width val))
+ (:weight (hfy-weight val))
+ (:slant (hfy-slant val))
+ (:foreground (hfy-colour val))
+ (:background (hfy-bgcol val))
+ (:box (hfy-box val))
+ (:height (hfy-size val))
+ (:underline (hfy-decor key val))
+ (:overline (hfy-decor key val))
+ (:strike-through (hfy-decor key val))
+ (:invisible (hfy-invisible val))
+ (:bold (hfy-weight 'bold))
+ (:italic (hfy-slant 'italic))))))
(setq that (hfy-face-to-style-i next))
;;(lwarn t :warning "%S => %S" fn (nconc this that parent))
(nconc this that parent))) )
(defun hfy-size-to-int (spec)
- "Convert SPEC, a css font-size specifier, back to an Emacs :height attribute
-value. Used while merging multiple font-size attributes."
+ "Convert SPEC, a CSS font-size specifier, to an Emacs :height attribute value.
+Used while merging multiple font-size attributes."
;;(message "hfy-size-to-int");;DBUG
(list
(if (string-match "\\([0-9]+\\)\\(%\\|pt\\)" spec)
"Take STYLE (see `hfy-face-to-style-i', `hfy-face-to-style') and merge
any multiple attributes appropriately. Currently only font-size is merged
down to a single occurrence - others may need special handling, but I
-haven\'t encountered them yet. Returns a `hfy-style-assoc'."
+haven't encountered them yet. Returns a `hfy-style-assoc'."
;;(message "(hfy-flatten-style %S)" style) ;;DBUG
(let ((n 0)
(m (list 1))
(x nil)
(r nil))
- (mapc
- (lambda (css)
- (if (string= (car css) "font-size")
- (progn
- (when (not x) (setq m (nconc m (hfy-size-to-int (cdr css)))))
- (when (string-match "pt" (cdr css)) (setq x t)))
- (setq r (nconc r (list css))) )) style)
+ (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)))))
;;(message "r: %S" r)
(setq n (apply '* m))
(nconc r (hfy-size (if x (round n) (* n 1.0)))) ))
+(defun hfy-face-resolve-face (fn)
+ (cond
+ ((facep fn)
+ (hfy-face-attr-for-class fn hfy-display-class))
+ ((and (symbolp fn)
+ (facep (symbol-value fn)))
+ ;; Obsolete faces like `font-lock-reference-face' are defined as
+ ;; aliases for another face.
+ (hfy-face-attr-for-class (symbol-value fn) hfy-display-class))
+ (t nil)))
+
+
(defun hfy-face-to-style (fn)
"Take FN, a font or `defface' style font specification,
-\(as returned by `face-attr-construct' or `hfy-face-attr-for-class'\)
+\(as returned by `face-attr-construct' or `hfy-face-attr-for-class')
and return a `hfy-style-assoc'.\n
-See also: `hfy-face-to-style-i', `hfy-flatten-style'."
+See also `hfy-face-to-style-i', `hfy-flatten-style'."
;;(message "hfy-face-to-style");;DBUG
- (let ((face-def (if (facep fn)
- (hfy-face-attr-for-class fn hfy-display-class) fn))
- (final-style nil))
-
- (setq final-style (hfy-flatten-style (hfy-face-to-style-i face-def)))
+ (let* ((face-def (hfy-face-resolve-face fn))
+ (final-style
+ (hfy-flatten-style (hfy-face-to-style-i face-def))))
;;(message "%S" final-style)
(if (not (assoc "text-decoration" final-style))
(progn (setq final-style
;; also handle ephemeral fonts created by overlays, which don't actually
;; have names:
(defun hfy-face-or-def-to-name (fn)
- "Render a font symbol or `defface' font spec FN into a name \(string\)."
+ "Render a font symbol or `defface' font spec FN into a name (string)."
;;(message "generating name for %s" fn)
(if (not (listp fn))
(format "%s" fn)
(string-match "^[Ii]nfo-\\(.*\\)" face-name))
(progn
(setq face-name (match-string 1 face-name))
- (if (string-match "\\(.*\\)-face$" face-name)
- (setq face-name (match-string 1 face-name))) face-name)
+ (if (string-match "\\(.*\\)-face\\'" face-name)
+ (setq face-name (match-string 1 face-name)))
+ face-name)
face-name)) )
;; construct an assoc of (stripped-name . "{ css-stuff-here }") pairs
;; from a face:
(defun hfy-face-to-css (fn)
- "Take FN, a font or `defface' specification \(cf `face-attr-construct'\)
+ "Take FN, a font or `defface' specification (cf `face-attr-construct')
and return a CSS style specification.\n
-See also: `hfy-face-to-style'"
+See also `hfy-face-to-style'."
;;(message "hfy-face-to-css");;DBUG
- (let ((css-list nil)
- (css-text nil)
- (seen nil))
- ;;(message "(hfy-face-to-style %S)" fn)
- (setq css-list (hfy-face-to-style fn))
- (setq css-text
- (nconc
- (mapcar
- (lambda (E)
- (if (car E)
- (if (not (member (car E) seen))
- (progn
- (setq seen (cons (car E) seen))
- (format " %s: %s; " (car E) (cdr E)))))) css-list)))
+ (let* ((css-list (hfy-face-to-style fn))
+ (seen nil)
+ (css-text
+ (mapcar
+ (lambda (E)
+ (if (car E)
+ (unless (member (car E) seen)
+ (push (car E) seen)
+ (format " %s: %s; " (car E) (cdr E)))))
+ css-list)))
(cons (hfy-css-name fn) (format "{%s}" (apply 'concat css-text)))) )
-;; extract a face from a list of char properties, if there is one:
-(defun hfy-p-to-face (props)
- "Given PROPS, a list of text-properties, return the value of the face
-property, or nil."
- (if props
- (if (string= (car props) "face")
- (let ((propval (cadr props)))
- (if (and (listp propval) (not (cdr propval)))
- (car propval)
- propval))
- (hfy-p-to-face (cddr props)))
- nil))
-
-(defun hfy-p-to-face-lennart (props)
- "Given PROPS, a list of text-properties, return the value of the face
-property, or nil."
- (when props
- (let ((face (plist-get props 'face))
- (font-lock-face (plist-get props 'font-lock-face))
- (button (plist-get props 'button))
- ;;(face-rec (memq 'face props))
- ;;(button-rec (memq 'button props)))
- )
- (if button
- (let* ((category (plist-get props 'category))
- (face (when category (plist-get (symbol-plist category) 'face))))
- face)
- (if font-lock-face
- font-lock-face
- face)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; (defun hfy-get-face-at (pos)
-;; ;; (let ((face (get-char-property-and-overlay pos 'face)))
-;; ;; (when (and face (listp face)) (setq face (car face)))
-;; ;; (unless (listp face)
-;; ;; face)))
-;; ;;(get-char-property pos 'face)
-;; ;; Overlays are handled later
-;; (if (or (not show-trailing-whitespace)
-;; (not (get-text-property pos 'hfy-show-trailing-whitespace)))
-;; (get-text-property pos 'face)
-;; (list 'trailing-whitespace (get-text-property pos 'face)))
-;; )
-
-(defun hfy-prop-invisible-p (prop)
- "Is text property PROP an active invisibility property?"
- (or (and (eq buffer-invisibility-spec t) prop)
- (or (memq prop buffer-invisibility-spec)
- (assq prop buffer-invisibility-spec))))
+(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))))))
(defun hfy-find-invisible-ranges ()
"Return a list of (start-point . end-point) cons cells of invisible regions."
- (let (invisible p i e s) ;; return-value pos invisible end start
- (save-excursion
+ (save-excursion
+ (let (invisible p i s) ;; return-value pos invisible end start
(setq p (goto-char (point-min)))
(when (invisible-p p) (setq s p i t))
(while (< p (point-max))
(if i ;; currently invisible
(when (not (invisible-p p)) ;; but became visible
- (setq e p
- i nil
- invisible (cons (cons s e) invisible)))
+ (setq i nil
+ invisible (cons (cons s p) invisible)))
;; currently visible:
(when (invisible-p p) ;; but have become invisible
(setq s p i t)))
(setq p (next-char-property-change p)))
;; still invisible at buffer end?
(when i
- (setq e (point-max)
- invisible (cons (cons s e) invisible))) ) invisible))
+ (setq invisible (cons (cons s (point-max)) invisible)))
+ invisible)))
(defun hfy-invisible-name (point map)
"Generate a CSS style name for an invisible section of the buffer.
MAP is the invisibility map as returned by `hfy-find-invisible-ranges'."
;;(message "(hfy-invisible-name %S %S)" point map)
(let (name)
- (mapc
- (lambda (range)
- (when (and (>= point (car range))
- (< point (cdr range)))
- (setq name (format "invisible-%S-%S" (car range) (cdr range))))) map)
+ (dolist (range map)
+ (when (and (>= point (car range))
+ (< point (cdr range)))
+ (setq name (format "invisible-%S-%S" (car range) (cdr range)))))
name))
;; Fix-me: This function needs some cleanup by someone who understand
;; -- v
(defun hfy-face-at (p)
"Find face in effect at point P.
-If overlays are to be considered \(see `hfy-optimisations'\) then this may
-return a defface style list of face properties instead of a face symbol."
+If overlays are to be considered (see `hfy-optimisations') then this may
+return a `defface' style list of face properties instead of a face symbol."
;;(message "hfy-face-at");;DBUG
;; Fix-me: clean up, remove face-name etc
;; not sure why we'd want to remove face-name? -- v
- (let ((overlay-data nil)
- (base-face nil)
- ;; restored hfy-p-to-face as it handles faces like (bold) as
- ;; well as face like 'bold - hfy-get-face-at doesn't dtrt -- v
- (face-name (hfy-p-to-face (text-properties-at p)))
- ;; (face-name (hfy-get-face-at p))
- (prop-seen nil)
- (extra-props nil)
- (text-props (text-properties-at p)))
- ;;(message "face-name: %S" face-name)
- (when (and face-name (listp face-name) (facep (car face-name)))
- ;;(message "face-name is a list %S" face-name)
- ;;(setq text-props (cons 'face face-name))
- (dolist (f face-name)
- (if (listp f) ;; for things like (variable-pitch (:foreground "red"))
- (setq extra-props (cons f extra-props))
- (setq extra-props (cons :inherit (cons f extra-props)))))
- (setq face-name nil))
- ;; text-properties-at => (face (:foreground "red" ...))
- ;; or => (face (compilation-info underline)) list of faces
- ;; overlay-properties
- ;; format= (evaporate t face ((foreground-color . "red")))
-
- ;; SO: if we have turned overlays off,
- ;; or if there's no overlay data
- ;; just bail out and return whatever face data we've accumulated so far
- (if (or (not (hfy-opt 'keep-overlays))
- (not (setq overlay-data (hfy-overlay-props-at p))))
- (progn
- ;;(message "· %d: %s; %S; %s"
- ;; p face-name extra-props text-props)
- face-name) ;; no overlays or extra properties
- ;; collect any face data and any overlay data for processing:
- (when text-props
- (setq overlay-data (cons text-props overlay-data)))
- (setq overlay-data (nreverse overlay-data))
- ;;(message "- %d: %s; %S; %s; %s"
- ;; p face-name extra-props text-props overlay-data)
- ;; remember the basic face name so we don't keep repeating its specs:
- (when face-name (setq base-face face-name))
- (mapc
- (lambda (P)
- (let ((iprops (cadr (memq 'invisible P))))
- ;;(message "(hfy-prop-invisible-p %S)" iprops)
- (when (hfy-prop-invisible-p iprops)
- (setq extra-props
- (cons :invisible (cons t extra-props))) ))
- (let ((fprops (cadr (or (memq 'face P)
- (memq 'font-lock-face P)))))
- ;;(message "overlay face: %s" fprops)
- (if (not (listp fprops))
- (let ((this-face (if (stringp fprops) (intern fprops) fprops)))
- (when (not (eq this-face base-face))
- (setq extra-props
- (cons :inherit
- (cons this-face extra-props))) ))
- (while fprops
- (if (facep (car fprops))
- (let ((face (car fprops)))
- (when (stringp face) (setq face (intern fprops)))
- (setq extra-props
- (cons :inherit
- (cons face
- extra-props)))
- (setq fprops (cdr fprops)))
- (let (p v)
- ;; Sigh.
- (if (listp (car fprops))
- (if (nlistp (cdr (car fprops)))
- (progn
- ;; ((prop . val))
- (setq p (caar fprops))
- (setq v (cdar fprops))
- (setq fprops (cdr fprops)))
- ;; ((prop val))
- (setq p (caar fprops))
- (setq v (cadar fprops))
- (setq fprops (cdr fprops)))
- (if (listp (cdr fprops))
- (progn
- ;; (:prop val :prop val ...)
- (setq p (car fprops))
- (setq v (cadr fprops))
- (setq fprops (cddr fprops)))
- (if (and (listp fprops)
- (not (listp (cdr fprops))))
- ;;(and (consp x) (cdr (last x)))
- (progn
- ;; (prop . val)
- (setq p (car fprops))
- (setq v (cdr fprops))
- (setq fprops nil))
- (error "Eh... another format! fprops=%s" fprops) )))
- (setq p (case p
- ;; These are all the properties handled
- ;; in `hfy-face-to-style-i'.
- ;;
- ;; Are these translations right?
- ;; yes, they are -- v
- ('family :family )
- ('width :width )
- ('height :height )
- ('weight :weight )
- ('slant :slant )
- ('underline :underline )
- ('overline :overline )
- ('strike-through :strike-through)
- ('box :box )
- ('foreground-color :foreground)
- ('background-color :background)
- ('bold :bold )
- ('italic :italic )
- (t p)))
- (if (memq p prop-seen) nil ;; noop
- (setq prop-seen (cons p prop-seen)
- extra-props (cons p (cons v extra-props)))) ))))))
- overlay-data)
- ;;(message "+ %d: %s; %S" p face-name extra-props)
- (if extra-props
- (if (listp face-name)
- (nconc extra-props face-name)
- (nconc extra-props (face-attr-construct face-name)))
- face-name)) ))
+ (let ((overlay-data nil)
+ (base-face nil)
+ (face-name (get-text-property p 'face))
+ ;; (face-name (hfy-get-face-at p))
+ (prop-seen nil)
+ (extra-props nil)
+ (text-props (text-properties-at p)))
+ ;;(message "face-name: %S" face-name)
+ (when (and face-name (listp face-name) (facep (car face-name)))
+ ;;(message "face-name is a list %S" face-name)
+ ;;(setq text-props (cons 'face face-name))
+ (dolist (f face-name)
+ (setq extra-props (if (listp f)
+ ;; for things like (variable-pitch
+ ;; (:foreground "red"))
+ (cons f extra-props)
+ (cons :inherit (cons f extra-props)))))
+ (setq base-face (car face-name)
+ face-name nil))
+ ;; text-properties-at => (face (:foreground "red" ...))
+ ;; or => (face (compilation-info underline)) list of faces
+ ;; overlay-properties
+ ;; format= (evaporate t face ((foreground-color . "red")))
+
+ ;; SO: if we have turned overlays off,
+ ;; or if there's no overlay data
+ ;; just bail out and return whatever face data we've accumulated so far
+ (if (or (not (hfy-opt 'keep-overlays))
+ (not (setq overlay-data (hfy-overlay-props-at p))))
+ (progn
+ ;;(message "· %d: %s; %S; %s"
+ ;; p face-name extra-props text-props)
+ (or face-name base-face)) ;; no overlays or extra properties
+ ;; collect any face data and any overlay data for processing:
+ (when text-props
+ (push text-props overlay-data))
+ (setq overlay-data (nreverse overlay-data))
+ ;;(message "- %d: %s; %S; %s; %s"
+ ;; p face-name extra-props text-props overlay-data)
+ ;; remember the basic face name so we don't keep repeating its specs:
+ (when face-name (setq base-face face-name))
+ (dolist (P overlay-data)
+ (let ((iprops (cadr (memq 'invisible P)))) ;FIXME: plist-get?
+ ;;(message "(hfy-prop-invisible-p %S)" iprops)
+ (when (and iprops (hfy-prop-invisible-p iprops))
+ (setq extra-props
+ (cons :invisible (cons t extra-props))) ))
+ (let ((fprops (cadr (or (memq 'face P)
+ (memq 'font-lock-face P)))))
+ ;;(message "overlay face: %s" fprops)
+ (if (not (listp fprops))
+ (let ((this-face (if (stringp fprops) (intern fprops) fprops)))
+ (when (not (eq this-face base-face))
+ (setq extra-props
+ (cons :inherit
+ (cons this-face extra-props))) ))
+ (while fprops
+ (if (facep (car fprops))
+ (let ((face (car fprops)))
+ (when (stringp face) (setq face (intern fprops)))
+ (setq extra-props
+ (cons :inherit
+ (cons face
+ extra-props)))
+ (setq fprops (cdr fprops)))
+ (let (p v)
+ ;; Sigh.
+ (if (listp (car fprops))
+ (if (nlistp (cdr (car fprops)))
+ (progn
+ ;; ((prop . val))
+ (setq p (caar fprops))
+ (setq v (cdar fprops))
+ (setq fprops (cdr fprops)))
+ ;; ((prop val))
+ (setq p (caar fprops))
+ (setq v (cadar fprops))
+ (setq fprops (cdr fprops)))
+ (if (listp (cdr fprops))
+ (progn
+ ;; (:prop val :prop val ...)
+ (setq p (car fprops))
+ (setq v (cadr fprops))
+ (setq fprops (cddr fprops)))
+ (if (and (listp fprops)
+ (not (listp (cdr fprops))))
+ ;;(and (consp x) (cdr (last x)))
+ (progn
+ ;; (prop . val)
+ (setq p (car fprops))
+ (setq v (cdr fprops))
+ (setq fprops nil))
+ (error "Eh... another format! fprops=%s" fprops) )))
+ (setq p (case p
+ ;; These are all the properties handled
+ ;; in `hfy-face-to-style-i'.
+ ;;
+ ;; Are these translations right?
+ ;; yes, they are -- v
+ (family :family )
+ (width :width )
+ (height :height )
+ (weight :weight )
+ (slant :slant )
+ (underline :underline )
+ (overline :overline )
+ (strike-through :strike-through)
+ (box :box )
+ (foreground-color :foreground)
+ (background-color :background)
+ (bold :bold )
+ (italic :italic )
+ (t p)))
+ (if (memq p prop-seen) nil ;; noop
+ (setq prop-seen (cons p prop-seen)
+ extra-props (cons p (cons v extra-props))))))))))
+ ;;(message "+ %d: %s; %S" p face-name extra-props)
+ (if extra-props
+ (nconc extra-props (if (listp face-name)
+ face-name
+ (face-attr-construct face-name)))
+ face-name)) ))
(defun hfy-overlay-props-at (p)
"Grab overlay properties at point P.
The plists are returned in descending priority order."
- (sort (mapcar (lambda (O) (overlay-properties O)) (overlays-at p))
- (lambda (A B) (> (or (cadr (memq 'priority A)) 0)
- (or (cadr (memq 'priority B)) 0)) ) ) )
+ (sort (mapcar #'overlay-properties (overlays-at p))
+ (lambda (A B) (> (or (cadr (memq 'priority A)) 0) ;FIXME: plist-get?
+ (or (cadr (memq 'priority B)) 0)))))
;; construct an assoc of (face-name . (css-name . "{ css-style }")) elements:
(defun hfy-compile-stylesheet ()
(goto-char pt)
(while (< pt (point-max))
(if (and (setq fn (hfy-face-at pt)) (not (assoc fn style)))
- (setq style (cons (cons fn (hfy-face-to-css fn)) style)))
+ (push (cons fn (hfy-face-to-css fn)) style))
(setq pt (next-char-property-change pt))) )
- (setq style (cons (cons 'default (hfy-face-to-css 'default)) style))) )
+ (push (cons 'default (hfy-face-to-css 'default)) style)))
(defun hfy-fontified-p ()
- "`font-lock' doesn't like to say it\'s been fontified when in batch
+ "`font-lock' doesn't like to say it's been fontified when in batch
mode, but we want to know if we should fontify or raw copy, so in batch
mode we check for non-default face properties. Otherwise we test
variable `font-lock-mode' and variable `font-lock-fontified' for truth."
(goto-char pt)
(while (and (< pt (point-max)) (not face-name))
(setq face-name (hfy-face-at pt))
- (setq pt (next-char-property-change pt)))) face-name)
+ (setq pt (next-char-property-change pt))))
+ face-name)
font-lock-mode)))
;; remember, the map is in reverse point order:
this function merges adjacent style blocks which are of the same value
and are separated by nothing more interesting than whitespace.\n
<span class=\"foo\">narf</span> <span class=\"foo\">brain</span>\n
-\(as interpreted from FACE-MAP\) would become:\n
+\(as interpreted from FACE-MAP) would become:\n
<span class=\"foo\">narf brain</span>\n
Returns a modified copy of FACE-MAP."
(let ((tmp-map face-map)
(span-stop nil)
(span-start nil)
(reduced-map nil))
- ;;(setq reduced-map (cons (car tmp-map) reduced-map))
- ;;(setq reduced-map (cons (cadr tmp-map) reduced-map))
+ ;;(push (car tmp-map) reduced-map)
+ ;;(push (cadr tmp-map) reduced-map)
(while tmp-map
(setq first-start (cadddr tmp-map)
first-stop (caddr tmp-map)
first-stop (caddr map-buf)
last-start (cadr map-buf)
last-stop (car map-buf)))
- (setq reduced-map (cons span-stop reduced-map))
- (setq reduced-map (cons span-start reduced-map))
+ (push span-stop reduced-map)
+ (push span-start reduced-map)
(setq tmp-map (memq last-start tmp-map))
(setq tmp-map (cdr tmp-map)))
(setq reduced-map (nreverse reduced-map))))
;; Fix-me: save table for multi-buffer
"Compile and return a `hfy-facemap-assoc' for the current buffer."
;;(message "hfy-compile-face-map");;DBUG
- (let ((pt (point-min))
- (pt-narrow 1)
- (fn nil)
- (map nil)
- (prev-tag nil)) ;; t if the last tag-point was a span-start
- ;; nil if it was a span-stop
+ (let* ((pt (point-min))
+ (pt-narrow (save-restriction (widen) (point-min)))
+ (offset (- pt pt-narrow))
+ (fn nil)
+ (map nil)
+ (prev-tag nil)) ;; t if the last tag-point was a span-start
+ ;; nil if it was a span-stop
(save-excursion
(goto-char pt)
(while (< pt (point-max))
(if (setq fn (hfy-face-at pt))
- (progn (if prev-tag (setq map (cons (cons pt-narrow 'end) map)))
- (setq map (cons (cons pt-narrow fn) map))
+ (progn (if prev-tag (push (cons pt-narrow 'end) map))
+ (push (cons pt-narrow fn) map)
(setq prev-tag t))
- (if prev-tag (setq map (cons (cons pt-narrow 'end) map)))
+ (if prev-tag (push (cons pt-narrow 'end) map))
(setq prev-tag nil))
(setq pt (next-char-property-change pt))
- (setq pt-narrow (1+ (- pt (point-min)))))
+ (setq pt-narrow (+ offset pt)))
(if (and map (not (eq 'end (cdar map))))
- (setq map (cons (cons (- (point-max) (point-min)) 'end) map))))
+ (push (cons (- (point-max) (point-min)) 'end) map)))
(if (hfy-opt 'merge-adjacent-tags) (hfy-merge-adjacent-spans map) map)))
(defun hfy-buffer ()
- "Generate a buffer to hold the html output.
-The filename of this buffer is derived from the source \(current\) buffer\'s
+ "Generate a buffer to hold the HTML output.
+The filename of this buffer is derived from the source (current) buffer's
variable `buffer-file-name', if it is set, plus `hfy-extn'.
Otherwise a plausible filename is constructed from `default-directory',
`buffer-name' and `hfy-extn'."
(with-current-buffer buf
(setq buffer-file-name
(if src (concat src hfy-extn)
- (expand-file-name (if (string-match "^.*/\\([^/]*\\)$" name)
+ (expand-file-name (if (string-match "^.*/\\([^/]*\\)\\'" name)
(match-string 1 name)
name))))
buf)))
(defun hfy-sprintf-stylesheet (css file)
"Return the inline CSS style sheet for FILE as a string."
- (let ((stylesheet nil))
- (setq stylesheet
- (concat
- hfy-meta-tags
- "\n<style type=\"text/css\"><!-- \n"
- ;; Fix-me: Add handling of page breaks here + scan for ^L
- ;; where appropriate.
- (format "body %s\n" (cddr (assq 'default css)))
- (apply 'concat
- (mapcar
- (lambda (style)
- (format
- "span.%s %s\nspan.%s a %s\n"
- (cadr style) (cddr style)
- (cadr style) (hfy-link-style (cddr style)))) css))
- " --></style>\n"))
+ (let ((stylesheet
+ (concat
+ hfy-meta-tags
+ "\n<style type=\"text/css\"><!-- \n"
+ ;; Fix-me: Add handling of page breaks here + scan for ^L
+ ;; where appropriate.
+ (format "body %s\n" (cddr (assq 'default css)))
+ (apply 'concat
+ (mapcar
+ (lambda (style)
+ (format
+ "span.%s %s\nspan.%s a %s\n"
+ (cadr style) (cddr style)
+ (cadr style) (hfy-link-style (cddr style))))
+ css))
+ " --></style>\n")))
(funcall hfy-page-header file stylesheet)))
-(defconst hfy-javascript "
- <script type=\"text/javascript\">
- // <![CDATA[
-function toggle_invis( name )
-{
- var filter =
- { acceptNode:
- function( node )
- { var classname = node.id;
- if( classname )
- { var classbase = classname.substr( 0, name.length );
- if( classbase == name ) { return NodeFilter.FILTER_ACCEPT; } }
- return NodeFilter.FILTER_SKIP; } };
- var walker = document.createTreeWalker( document.body ,
- NodeFilter.SHOW_ELEMENT ,
- filter ,
- false );
- while( walker.nextNode() )
- {
- var e = walker.currentNode;
- if( e.style.display == \"none\" ) { e.style.display = \"inline\"; }
- else { e.style.display = \"none\"; }
- }
-}
- // ]]>
- </script>\n")
-
;; tag all the dangerous characters we want to escape
;; (ie any "<> chars we _didn't_ put there explicitly for css markup)
(defun hfy-html-enkludge-buffer ()
- "Mark dangerous [\"\<\>] characters with the \'hfy-quoteme property.\n
+ "Mark dangerous [\"<>] characters with the `hfy-quoteme' property.\n
See also `hfy-html-dekludge-buffer'."
;;(message "hfy-html-enkludge-buffer");;DBUG
(save-excursion
;; dangerous char -> &entity;
(defun hfy-html-quote (char-string)
- "Map CHAR-STRING to an html safe string (entity) if need be."
+ "Map CHAR-STRING to an HTML safe string (entity) if need be."
;;(message "hfy-html-quote");;DBUG
(or (cadr (assoc char-string hfy-html-quote-map)) char-string) )
;; enter any other text before we do this, we'd have to track another
;; map of offsets, which would be tedious...
(defun hfy-html-dekludge-buffer ()
- "Transform all dangerous characters marked with the \'hfy-quoteme property
-using `hfy-html-quote'\n
+ "Transform all dangerous characters marked with the `hfy-quoteme' property
+using `hfy-html-quote'.\n
See also `hfy-html-enkludge-buffer'."
;;(message "hfy-html-dekludge-buffer");;DBUG
(save-excursion
(delete-overlay rovl))
(copy-to-buffer html-buffer (point-min) (point-max))
(set-buffer html-buffer)
+ ;; rip out props that could interfere with our htmlisation of the buffer:
+ (remove-text-properties (point-min) (point-max) hfy-ignored-properties)
;; Apply overlay invisible spec
(setq orig-ovls
(sort orig-ovls
;; property has already served its main purpose by this point.
;;(message "mapcar over the CSS-MAP")
(message "invis-ranges:\n%S" invis-ranges)
- (mapc
- (lambda (point-face)
- (let ((pt (car point-face))
- (fn (cdr point-face))
- (move-link nil))
- (goto-char pt)
- (setq move-link
- (or (get-text-property pt 'hfy-linkp)
- (get-text-property pt 'hfy-endl )))
- (if (eq 'end fn)
- (insert "</span>")
- (if (not (and srcdir file))
- nil
- (when move-link
- (remove-text-properties (point) (1+ (point)) '(hfy-endl nil))
- (put-text-property pt (1+ pt) 'hfy-endl t) ))
- ;; if we have invisible blocks, we need to do some extra magic:
- (if invis-ranges
- (let ((iname (hfy-invisible-name pt invis-ranges))
- (fname (hfy-lookup fn css-sheet )))
- (when (assq pt invis-ranges)
- (insert
- (format "<span onclick=\"toggle_invis('%s');\">" iname))
- (insert "…</span>"))
- (insert
- (format "<span class=\"%s\" id=\"%s-%d\">" fname iname pt)))
- (insert (format "<span class=\"%s\">" (hfy-lookup fn css-sheet))))
- (if (not move-link) nil
- ;;(message "removing prop2 @ %d" (point))
- (if (remove-text-properties (point) (1+ (point)) '(hfy-endl nil))
- (put-text-property pt (1+ pt) 'hfy-endl t))) )))
- css-map)
+ (dolist (point-face css-map)
+ (let ((pt (car point-face))
+ (fn (cdr point-face))
+ (move-link nil))
+ (goto-char pt)
+ (setq move-link
+ (or (get-text-property pt 'hfy-linkp)
+ (get-text-property pt 'hfy-endl )))
+ (if (eq 'end fn)
+ (insert "</span>")
+ (if (not (and srcdir file))
+ nil
+ (when move-link
+ (remove-text-properties (point) (1+ (point)) '(hfy-endl nil))
+ (put-text-property pt (1+ pt) 'hfy-endl t) ))
+ ;; if we have invisible blocks, we need to do some extra magic:
+ (if invis-ranges
+ (let ((iname (hfy-invisible-name pt invis-ranges))
+ (fname (hfy-lookup fn css-sheet )))
+ (when (assq pt invis-ranges)
+ (insert
+ (format "<span onclick=\"toggle_invis('%s');\">" iname))
+ (insert "…</span>"))
+ (insert
+ (format "<span class=\"%s\" id=\"%s-%d\">" fname iname pt)))
+ (insert (format "<span class=\"%s\">" (hfy-lookup fn css-sheet))))
+ (if (not move-link) nil
+ ;;(message "removing prop2 @ %d" (point))
+ (if (remove-text-properties (point) (1+ (point)) '(hfy-endl nil))
+ (put-text-property pt (1+ pt) 'hfy-endl t))))))
;; #####################################################################
;; Invisibility
;; Maybe just make the text invisible in XHTML?
;; (message "checking to see whether we should link...")
(if (and srcdir file)
(let ((lp 'hfy-link)
- (pt nil)
+ (pt (point-min))
(pr nil)
(rr nil))
;; (message " yes we should.")
- ;; translate 'hfy-anchor properties to anchors
- (setq pt (point-min))
- (while (setq pt (next-single-property-change pt 'hfy-anchor))
- (if (setq pr (get-text-property pt 'hfy-anchor))
- (progn (goto-char pt)
- (remove-text-properties pt (1+ pt) '(hfy-anchor nil))
- (insert (concat "<a name=\"" pr "\"></a>")))))
- ;; translate alternate 'hfy-link and 'hfy-endl props to opening
- ;; and closing links. (this should avoid those spurious closes
- ;; we sometimes get by generating only paired tags)
- (setq pt (point-min))
- (while (setq pt (next-single-property-change pt lp))
- (if (not (setq pr (get-text-property pt lp))) nil
- (goto-char pt)
- (remove-text-properties pt (1+ pt) (list lp nil))
- (cond
- ((eq lp 'hfy-link)
- (if (setq rr (get-text-property pt 'hfy-inst))
- (insert (format "<a name=\"%s\"></a>" rr)))
- (insert (format "<a href=\"%s\">" pr))
- (setq lp 'hfy-endl))
- ((eq lp 'hfy-endl)
- (insert "</a>") (setq lp 'hfy-link)) ))) ))
+ ;; translate 'hfy-anchor properties to anchors
+ (while (setq pt (next-single-property-change pt 'hfy-anchor))
+ (if (setq pr (get-text-property pt 'hfy-anchor))
+ (progn (goto-char pt)
+ (remove-text-properties pt (1+ pt) '(hfy-anchor nil))
+ (insert (concat "<a name=\"" pr "\"></a>")))))
+ ;; translate alternate 'hfy-link and 'hfy-endl props to opening
+ ;; and closing links. (this should avoid those spurious closes
+ ;; we sometimes get by generating only paired tags)
+ (setq pt (point-min))
+ (while (setq pt (next-single-property-change pt lp))
+ (if (not (setq pr (get-text-property pt lp))) nil
+ (goto-char pt)
+ (remove-text-properties pt (1+ pt) (list lp nil))
+ (case lp
+ (hfy-link
+ (if (setq rr (get-text-property pt 'hfy-inst))
+ (insert (format "<a name=\"%s\"></a>" rr)))
+ (insert (format "<a href=\"%s\">" pr))
+ (setq lp 'hfy-endl))
+ (hfy-endl
+ (insert "</a>") (setq lp 'hfy-link)) ))) ))
;; #####################################################################
;; transform the dangerous chars. This changes character positions
(goto-char (point-min))
;;(message "inserting stylesheet")
(insert (hfy-sprintf-stylesheet css-sheet file))
- (insert hfy-javascript)
(if (hfy-opt 'div-wrapper) (insert "<div class=\"default\">"))
(insert "\n<pre>")
(goto-char (point-max))
html-buffer))
(defun hfy-force-fontification ()
- "Try to force font-locking even when it is optimised away."
- (mapc (lambda (fun) (funcall fun)) hfy-init-kludge-hooks)
+ "Try to force font-locking even when it is optimized away."
+ (run-hooks 'hfy-init-kludge-hook)
(eval-and-compile (require 'font-lock))
(if (boundp 'font-lock-cache-position)
(or font-lock-cache-position
(when font-lock-defaults
(font-lock-fontify-buffer)) ))
+;;;###autoload
(defun htmlfontify-buffer (&optional srcdir file)
"Create a new buffer, named for the current buffer + a .html extension,
-containing an inline css-stylesheet and formatted css-markup html
+containing an inline CSS-stylesheet and formatted CSS-markup HTML
that reproduces the look of the current Emacs buffer as closely
as possible.
-Dangerous characters in the existing buffer are turned into html
-entities, so you should even be able to do html-within-html
+Dangerous characters in the existing buffer are turned into HTML
+entities, so you should even be able to do HTML-within-HTML
fontified display.
You should, however, note that random control or eight-bit
characters such as ^L (\x0c) or ¤ (\xa4) won't get mapped yet.
If the SRCDIR and FILE arguments are set, lookup etags derived
-entries in the `hfy-tags-cache' and add html anchors and
+entries in the `hfy-tags-cache' and add HTML anchors and
hyperlinks as appropriate."
(interactive)
;; pick up the file name in case we didn't receive it
(if (not file)
(progn (setq file (or (buffer-file-name) (buffer-name)))
- (if (string-match "/\\([^/]*\\)$" file)
+ (if (string-match "/\\([^/]*\\)\\'" file)
(setq file (match-string 1 file)))) )
(if (not (hfy-opt 'skip-refontification))
"Return a list of files under DIRECTORY.
Strips any leading \"./\" from each filename."
;;(message "hfy-list-files");;DBUG
+ ;; FIXME: this changes the dir of the currrent buffer. Is that right??
(cd directory)
(mapcar (lambda (F) (if (string-match "^./\\(.*\\)" F) (match-string 1 F) F))
(split-string (shell-command-to-string hfy-find-cmd))) )
;; fed pretty carefully, so it should be Ok:
(defun hfy-dirname (file)
"Return everything preceding the last \"/\" from a relative filename FILE,
-on the assumption that this will produce a relative directory name. Hardly
-bombproof, but good enough in the context in which it is being used."
+on the assumption that this will produce a relative directory name.
+Hardly bombproof, but good enough in the context in which it is being used."
;;(message "hfy-dirname");;DBUG
(let ((f (directory-file-name file)))
(and (string-match "^\\(.*\\)/" f) (match-string 1 f))))
;; create a directory, cf mkdir -p
(defun hfy-make-directory (dir)
- "Approx equivalent of mkdir -p DIR."
+ "Approx. equivalent of mkdir -p DIR."
;;(message "hfy-make-directory");;DBUG
(if (file-exists-p dir)
(if (file-directory-p dir) t)
(make-directory dir t)))
(defun hfy-text-p (srcdir file)
- "Is SRCDIR/FILE text? Uses `hfy-istext-command' to determine this."
+ "Is SRCDIR/FILE text? Uses `hfy-istext-command' to determine this."
(let* ((cmd (format hfy-istext-command (expand-file-name file srcdir)))
(rsp (shell-command-to-string cmd)))
- (if (string-match "text" rsp) t nil)))
+ (string-match "text" rsp)))
;; open a file, check fontification, if fontified, write a fontified copy
;; to the destination directory, otherwise just copy the file:
(kill-buffer source)) ))
;; list of tags in file in srcdir
-(defun hfy-tags-for-file (srcdir file)
+(defun hfy-tags-for-file (cache-hash file)
"List of etags tags that have definitions in this FILE.
-Looks up the tags cache in `hfy-tags-cache' using SRCDIR as the key."
+CACHE-HASH is the tags cache."
;;(message "hfy-tags-for-file");;DBUG
- (let ((cache-entry (assoc srcdir hfy-tags-cache))
- (cache-hash nil)
- (tag-list nil))
- (if (setq cache-hash (cadr cache-entry))
+ (let* ((tag-list nil))
+ (if cache-hash
(maphash
(lambda (K V)
(if (assoc file V)
- (setq tag-list (cons K tag-list)))) cache-hash))
+ (setq tag-list (cons K tag-list))))
+ cache-hash))
tag-list))
;; mark the tags native to this file for anchors
(defun hfy-mark-tag-names (srcdir file)
- "Mark tags in FILE (lookup SRCDIR in `hfy-tags-cache') with the \'hfy-anchor
+ "Mark tags in FILE (lookup SRCDIR in `hfy-tags-cache') with the `hfy-anchor'
property, with a value of \"tag.line-number\"."
;;(message "(hfy-mark-tag-names %s %s)" srcdir file);;DBUG
- (let ((cache-entry (assoc srcdir hfy-tags-cache))
- (cache-hash nil))
- (if (setq cache-hash (cadr cache-entry))
+ (let* ((cache-entry (assoc srcdir hfy-tags-cache))
+ (cache-hash (cadr cache-entry)))
+ (if cache-hash
(mapcar
(lambda (TAG)
(mapcar
(+ 2 chr)
'hfy-anchor link))))
(gethash TAG cache-hash)))
- (hfy-tags-for-file srcdir file)))))
+ (hfy-tags-for-file cache-hash file)))))
(defun hfy-relstub (file &optional start)
"Return a \"../\" stub of the appropriate length for the current source
-tree depth \(as determined from FILE \(a filename\)\).
+tree depth, as determined from FILE (a filename).
START is the offset at which to start looking for the / character in FILE."
;;(message "hfy-relstub");;DBUG
(let ((c ""))
(while (setq start (string-match "/" file start))
- (setq start (1+ start)) (setq c (concat c "../"))) c))
+ (setq start (1+ start)) (setq c (concat c "../")))
+ c))
(defun hfy-href-stub (this-file def-files tag)
- "Return an href stub for a tag href i THIS-FILE:
-If DEF-FILES \(list of files containing definitions for the tag in question\)
+ "Return an href stub for a tag href in THIS-FILE.
+If DEF-FILES (list of files containing definitions for the tag in question)
contains only one entry, the href should link straight to that file.
Otherwise, the link should be to the index file.\n
We are not yet concerned with the file extensions/tag line number and so on at
If `hfy-split-index' is set, and the href wil be to an index file rather than
a source file, append a .X to `hfy-index-file', where X is the uppercased
first character of TAG.\n
-See also: `hfy-relstub', `hfy-index-file'`'."
+See also `hfy-relstub', `hfy-index-file'."
;;(message "hfy-href-stub");;DBUG
;; FIXME: Why not use something like
;; (file-relative-name (if ...) (file-name-directory this-file)) ? --Stef
THIS-FILE `hfy-link-extn' `hfy-extn' DEF-FILES TAG and TAG-MAP\n
THIS-FILE is the current source file
DEF-FILES is a list of file containing possible link endpoints for TAG
-TAG is the TAG in question
+TAG is the tag in question
TAG-MAP is the entry in `hfy-tags-cache'."
;;(message "hfy-href");;DBUG
(concat
;; mark all tags for hyperlinking, except the tags at
;; their own points of definition, iyswim:
(defun hfy-mark-tag-hrefs (srcdir file)
- "Mark href start points with the \'hfy-link prop \(value: href string\)\n
-Mark href end points with the \'hfy-endl prop \(value t\)\n
+ "Mark href start points with the `hfy-link' prop (value: href string).\n
+Mark href end points with the `hfy-endl' prop (value t).\n
Avoid overlapping links, and mark links in descending length of
tag name in order to prevent subtags from usurping supertags,
\(eg \"term\" for \"terminal\").
(rmap-line nil)
(tag-regex (hfy-word-regex TAG))
(tag-map (gethash TAG cache-hash))
- (tag-files (mapcar (lambda (X) (car X)) tag-map)))
+ (tag-files (mapcar #'car tag-map)))
;; find instances of TAG and do what needs to be done:
(goto-char (point-min))
(while (search-forward TAG nil 'NOERROR)
(setq tag-point (round (string-to-number (match-string 3))))
(setq hash-entry (gethash tag-string cache-hash))
(setq new-entry (list etags-file tag-line tag-point))
- (setq hash-entry (cons new-entry hash-entry))
+ (push new-entry hash-entry)
;;(message "HASH-ENTRY %s %S" tag-string new-entry)
(puthash tag-string hash-entry cache-hash)))) )))
;; cache a list of tags in descending length order:
- (maphash (lambda (K V) (setq tags-list (cons K tags-list))) cache-hash)
+ (maphash (lambda (K V) (push K tags-list)) cache-hash)
(setq tags-list (sort tags-list (lambda (A B) (< (length B) (length A)))))
;; put the tag list into the cache:
(if tlist-cache (setcar (cdr tlist-cache) tags-list)
- (setq hfy-tags-sortl (cons (list srcdir tags-list) hfy-tags-sortl)))
+ (push (list srcdir tags-list) hfy-tags-sortl))
;; return the number of tags found:
(length tags-list) ))
`hfy-tags-cache' must already have an entry for SRCDIR for this to work.
`hfy-page-header', `hfy-page-footer', `hfy-link-extn' and `hfy-extn'
all play a part here.\n
-If STUB is set, prepare an \(appropriately named\) index buffer
+If STUB is set, prepare an (appropriately named) index buffer
specifically for entries beginning with STUB.\n
If MAP is set, use that instead of `hfy-tags-cache'.
FILENAME is the name of the file being indexed.
(setq cache-hash (cadr cache-entry))
(setq index-buf (get-buffer-create index-file))))
nil ;; noop
- (maphash (lambda (K V) (setq tag-list (cons K tag-list))) cache-hash)
+ (maphash (lambda (K V) (push K tag-list)) cache-hash)
(setq tag-list (sort tag-list 'string<))
(set-buffer index-buf)
(erase-buffer)
(insert (funcall hfy-page-header filename "<!-- CSS -->"))
(insert "<table class=\"index\">\n")
- (mapc
- (lambda (TAG)
- (let ((tag-started nil))
- (mapc
- (lambda (DEF)
- (if (and stub (not (string-match (concat "^" stub) TAG)))
- nil ;; we have a stub and it didn't match: NOOP
- (let ((file (car DEF))
- (line (cadr DEF)))
- (insert
- (format
- (concat
- " <tr> \n"
- " <td>%s</td> \n"
- " <td><a href=\"%s%s\">%s</a></td> \n"
- " <td><a href=\"%s%s#%s.%d\">%d</a></td>\n"
- " </tr> \n")
- (if (string= TAG tag-started) " "
- (format "<a name=\"%s\">%s</a>" TAG TAG))
- file (or hfy-link-extn hfy-extn) file
- file (or hfy-link-extn hfy-extn) TAG line line))
- (setq tag-started TAG))))
- (gethash TAG cache-hash)))) tag-list)
+ (dolist (TAG tag-list)
+ (let ((tag-started nil))
+ (dolist (DEF (gethash TAG cache-hash))
+ (if (and stub (not (string-match (concat "^" stub) TAG)))
+ nil ;; we have a stub and it didn't match: NOOP
+ (let ((file (car DEF))
+ (line (cadr DEF)))
+ (insert
+ (format
+ (concat
+ " <tr> \n"
+ " <td>%s</td> \n"
+ " <td><a href=\"%s%s\">%s</a></td> \n"
+ " <td><a href=\"%s%s#%s.%d\">%d</a></td>\n"
+ " </tr> \n")
+ (if (string= TAG tag-started) " "
+ (format "<a name=\"%s\">%s</a>" TAG TAG))
+ file (or hfy-link-extn hfy-extn) file
+ file (or hfy-link-extn hfy-extn) TAG line line))
+ (setq tag-started TAG))))))
(insert "</table>\n")
(insert (funcall hfy-page-footer filename))
(and dstdir (cd dstdir))
index-buf) ))
(defun hfy-prepare-index (srcdir dstdir)
- "Return a list of index buffer\(s\), as determined by `hfy-split-index'.
+ "Return a list of index buffer(s), as determined by `hfy-split-index'.
SRCDIR and DSTDIR are the source and output directories respectively."
(if (not hfy-split-index)
(list (hfy-prepare-index-i srcdir dstdir hfy-index-file nil))
dstdir
hfy-index-file
stub)
- index-list)) ))) cache-hash) ) index-list)))
+ index-list)) )))
+ cache-hash) )
+ index-list)))
(defun hfy-prepare-tag-map (srcdir dstdir)
- "Prepare the counterpart\(s\) to the index buffer\(s\) - a list of buffers
-with the same structure, but listing \( and linking to \) instances of tags
-\( as opposed to their definitions \).\n
+ "Prepare the counterpart(s) to the index buffer(s) - a list of buffers
+with the same structure, but listing (and linking to) instances of tags
+\(as opposed to their definitions).\n
SRCDIR and DSTDIR are the source and output directories respectively.
-See: `hfy-prepare-index'
- `hfy-split-index'."
+See also `hfy-prepare-index', `hfy-split-index'."
(if (not hfy-split-index)
(list (hfy-prepare-index-i srcdir
dstdir
hfy-instance-file
stub
hfy-tags-rmap)
- index-list)) ))) cache-hash) ) index-list)))
+ index-list)) )))
+ cache-hash) )
+ index-list)))
(defun hfy-subtract-maps (srcdir)
"Internal function - strips definitions of tags from the instance map.
SRCDIR is the directory being \"published\".
-See: `hfy-tags-cache' and `hfy-tags-rmap'"
+See also `hfy-tags-cache', `hfy-tags-rmap'."
(let ((new-list nil)
(old-list nil)
(def-list nil)
(fwd-map (cadr (assoc srcdir hfy-tags-cache)))
(rev-map (cadr (assoc srcdir hfy-tags-rmap )))
(taglist (cadr (assoc srcdir hfy-tags-sortl))))
- (mapc
- (lambda (TAG)
- (setq def-list (gethash TAG fwd-map)
- old-list (gethash TAG rev-map)
- new-list nil
- exc-list nil)
- (mapc
- (lambda (P)
- (setq exc-list (cons (list (car P) (cadr P)) exc-list))) def-list)
- (mapc
- (lambda (P)
- (or (member (list (car P) (cadr P)) exc-list)
- (setq new-list (cons P new-list)))) old-list)
- (puthash TAG new-list rev-map)) taglist) ))
+ (dolist (TAG taglist)
+ (setq def-list (gethash TAG fwd-map)
+ old-list (gethash TAG rev-map)
+ exc-list (mapcar (lambda (P) (list (car P) (cadr P))) def-list)
+ new-list nil)
+ (dolist (P old-list)
+ (or (member (list (car P) (cadr P)) exc-list)
+ (push P new-list)))
+ (puthash TAG new-list rev-map))))
(defun htmlfontify-run-etags (srcdir)
"Load the etags cache for SRCDIR.
-See `hfy-load-tags-cache'."
+See also `hfy-load-tags-cache'."
(interactive "D source directory: ")
- (setq srcdir (directory-file-name srcdir))
- (hfy-load-tags-cache srcdir))
+ (hfy-load-tags-cache (directory-file-name srcdir)))
;;(defun hfy-test-read-args (foo bar)
;; (interactive "D source directory: \nD target directory: ")
;; (message "foo: %S\nbar: %S" foo bar))
(defun hfy-save-kill-buffers (buffer-list &optional dstdir)
- (mapc (lambda (B)
- (set-buffer B)
- (and dstdir (file-directory-p dstdir) (cd dstdir))
- (save-buffer)
- (kill-buffer B)) buffer-list) )
+ (dolist (B buffer-list)
+ (set-buffer B)
+ (and dstdir (file-directory-p dstdir) (cd dstdir))
+ (save-buffer)
+ (kill-buffer B)))
+;;;###autoload
(defun htmlfontify-copy-and-link-dir (srcdir dstdir &optional f-ext l-ext)
"Trawl SRCDIR and write fontified-and-hyperlinked output in DSTDIR.
F-EXT and L-EXT specify values for `hfy-extn' and `hfy-link-extn'.\n
(clrhash (cadr tr-cache))
(hfy-make-directory dstdir)
(setq source-files (hfy-list-files srcdir))
- (mapc (lambda (file)
- (hfy-copy-and-fontify-file srcdir dstdir file)) source-files)
+ (dolist (file source-files)
+ (hfy-copy-and-fontify-file srcdir dstdir file))
(hfy-subtract-maps srcdir)
(hfy-save-kill-buffers (hfy-prepare-index srcdir dstdir) dstdir)
(hfy-save-kill-buffers (hfy-prepare-tag-map srcdir dstdir) dstdir) ))
;; (defalias 'hfy-set-hooks 'custom-set-variables)
;; (defun hfy-pp-hook (H)
-;; (and (string-match "-hook$" (symbol-name H))
+;; (and (string-match "-hook\\'" (symbol-name H))
;; (boundp H)
;; (symbol-value H)
;; (insert (format "\n '(%S %S)" H (symbol-value H)))
(custom-save-delete 'hfy-init-progn)
(setq start-pos (point))
(princ "(hfy-init-progn\n;;auto-generated, only one copy allowed\n")
+ ;; FIXME: This saving&restoring of global customization
+ ;; variables can interfere with other customization settings for
+ ;; those vars (in .emacs or in Customize).
(mapc 'hfy-save-initvar
- (list 'auto-mode-alist 'interpreter-mode-alist))
+ '(auto-mode-alist interpreter-mode-alist))
(princ ")\n")
(indent-region start-pos (point) nil))
(custom-save-all) ))
(let ((file (hfy-initfile)))
(load file 'NOERROR nil nil) ))
+\f
+;;;### (autoloads (hfy-fallback-colour-values htmlfontify-load-rgb-file)
+;;;;;; "hfy-cmap" "hfy-cmap.el" "8dce008297f15826cc6ab82203c46fa6")
+;;; Generated autoloads from hfy-cmap.el
+
+(autoload 'htmlfontify-load-rgb-file "hfy-cmap" "\
+Load an X11 style rgb.txt FILE.
+Search `hfy-rgb-load-path' if FILE is not specified.
+Loads the variable `hfy-rgb-txt-colour-map', which is used by
+`hfy-fallback-colour-values'.
+
+\(fn &optional FILE)" t nil)
+
+(autoload 'hfy-fallback-colour-values "hfy-cmap" "\
+Use a fallback method for obtaining the rgb values for a color.
+
+\(fn COLOUR-STRING)" nil nil)
+
+;;;***
+\f
+
(provide 'htmlfontify)
-;;; htmlfontify.el ends here
+;; Local Variables:
+;; coding: utf-8
+;; End:
+
+;;; htmlfontify.el ends here
HCoop / bpt / emacs.git / blobdiff