-;;; htmlfontify.el --- htmlise a buffer/source tree with optional hyperlinks
+;;; htmlfontify.el --- htmlize a buffer/source tree with optional hyperlinks
-;; Copyright (C) 2002-2003, 2009-2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2003, 2009-2013 Free Software Foundation, Inc.
;; Emacs Lisp Archive Entry
;; Package: htmlfontify
;; Author: Vivek Dasmohapatra <vivek@etla.org>
;; Maintainer: Vivek Dasmohapatra <vivek@etla.org>
;; Created: 2002-01-05
-;; Description: htmlise a buffer/source tree with optional hyperlinks
+;; Description: htmlize a buffer/source tree with optional hyperlinks
;; URL: http://rtfm.etla.org/emacs/htmlfontify/
;; Compatibility: Emacs23, Emacs22
;; Incompatibility: Emacs19, Emacs20, Emacs21
:prefix "hfy-")
(defcustom hfy-page-header 'hfy-default-header
- "Function called to build the header of the html source.
+ "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
+It should return a string that will be used as the header for the
htmlfontified version of the source file.\n
See also `hfy-page-footer'."
:group 'htmlfontify
(defcustom hfy-split-index nil
"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."
+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))
:tag "page-footer"
:type '(function))
-(defcustom hfy-extn ".html"
+(defcustom hfy-extn ".html"
"File extension used for output files."
:group 'htmlfontify
:tag "extension"
:tag "init-kludge-hooks"
:type '(hook))
-(defcustom hfy-post-html-hooks nil
+(define-obsolete-variable-alias 'hfy-post-html-hooks 'hfy-post-html-hook "24.3")
+(defcustom hfy-post-html-hook 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."
+These functions will be called with the HTML buffer as the current buffer."
:group 'htmlfontify
:tag "post-html-hooks"
:options '(set-auto-mode)
:group 'htmlfontify
:tag "html-quote-map"
:type '(alist :key-type (string)))
-(eval-and-compile
- (defconst hfy-e2x-etags-cmd "for src in `find . -type f`;
+(defconst hfy-e2x-etags-cmd "for src in `find . -type f`;
do
ETAGS=%s;
case ${src} in
esac;
done;")
- (defconst hfy-etags-cmd-alist-default
- `(("emacs etags" . ,hfy-e2x-etags-cmd)
- ("exuberant ctags" . "%s -R -f -" )))
+(defconst hfy-etags-cmd-alist-default
+ `(("emacs etags" . ,hfy-e2x-etags-cmd)
+ ("exuberant ctags" . "%s -R -f -" )))
- (defcustom hfy-etags-cmd-alist
- hfy-etags-cmd-alist-default
- "Alist of possible shell commands that will generate etags output that
+(defcustom hfy-etags-cmd-alist
+ hfy-etags-cmd-alist-default
+ "Alist of possible shell commands that will generate etags output that
`htmlfontify' can use. '%s' will be replaced by `hfy-etags-bin'."
- :group 'htmlfontify
- :tag "etags-cmd-alist"
- :type '(alist :key-type (string) :value-type (string)) ))
+ :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
: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))
:type '(repeat symbol))
(defun hfy-which-etags ()
- "Return a string indicating which flavour of etags we are using."
+ "Return a string indicating which flavor 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)))
+ ;; We used to wrap this in a `eval-and-compile', but:
+ ;; - it had no effect because this expression was not seen by the
+ ;; byte-compiler (defcustom used to quote this argument).
+ ;; - it signals an error (`hfy-which-etags' is not defined at compile-time).
+ ;; - we want this auto-detection to reflect the system on which Emacs is run
+ ;; rather than the one on which it's compiled.
+ (cdr (assoc (hfy-which-etags) hfy-etags-cmd-alist))
"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
+Two canned commands are provided - they drive Emacs's etags and
exuberant-ctags' etags respectively."
:group 'htmlfontify
:tag "etags-command"
- :type (eval-and-compile
- (let ((clist (list '(string))))
- (dolist (C hfy-etags-cmd-alist)
- (push (list 'const :tag (car C) (cdr C)) clist))
- (cons 'choice clist)) ))
+ :type (let ((clist (list '(string))))
+ (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
(const :tag "Lucid Toolkit" lucid )
(const :tag "Motif Toolkit" motif )))
- (class (choice (const :tag "Colour" color )
- (const :tag "Greyscale" grayscale)))
+ (class (choice (const :tag "Color" color )
+ (const :tag "Grayscale" grayscale)))
(background (choice (const :tag "Dark" dark )
(const :tag "Bright" light ))) ))
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
+ body-text-only : Emit only body-text. In concrete terms,
+ 1. Suppress calls to `hfy-page-header'and
+ `hfy-page-footer'
+ 2. Pretend that `div-wrapper' option above is
+ turned off
+ 3. Don't enclose output in <pre> </pre> tags
And the following are planned but not yet available:\n
kill-context-leak : Suppress hyperlinking between files highlighted by
different modes.\n
(const :tag "skip-refontification" skip-refontification)
(const :tag "kill-context-leak" kill-context-leak )
(const :tag "div-wrapper" div-wrapper )
- (const :tag "keep-overlays" keep-overlays ))
+ (const :tag "keep-overlays" keep-overlays )
+ (const :tag "body-text-only" body-text-only ))
:group 'htmlfontify
:tag "optimizations")
(color-values colour)
;;(message "[%S]" window-system)
(x-color-values colour))
- ;; blarg - tty colours are no good - go fetch some X colours:
+ ;; blarg - tty colors are no good - go fetch some X colors:
(hfy-fallback-colour-values colour))))
(defvar hfy-cperl-mode-kludged-p nil)
(defun hfy-kludge-cperl-mode ()
- "CPerl mode does its damndest not to do some of its fontification when not
+ "CPerl mode does its damnedest not to do some of its fontification when not
in a windowing system - try to trick it..."
(if (not hfy-cperl-mode-kludged-p)
(progn (if (not window-system)
(setq cperl-syntaxify-by-font-lock t)))
(setq hfy-cperl-mode-kludged-p t))) )
-(defun hfy-opt (symbol) "Is option SYMBOL set."
+(defun hfy-opt (symbol)
+ "Is option SYMBOL set."
(memq symbol hfy-optimisations))
(defun hfy-default-header (file style)
--> </script>
</head>
<body onload=\"stripe('index'); return true;\">\n"
- file style))
+ (mapconcat 'hfy-html-quote (mapcar 'char-to-string file) "") style))
-(defun hfy-default-footer (file)
+(defun hfy-default-footer (_file)
"Default value for `hfy-page-footer'.
FILE is the name of the file being rendered, in case it is needed."
"\n </body>\n</html>\n")
((stringp box) (list (cons "border" (format "solid %s 1px" box))))
((listp box) (hfy-box-to-style box) ))) )
-(defun hfy-decor (tag val)
+(defun hfy-decor (tag _val)
"Derive CSS text-decoration specifiers from various Emacs font attributes.
TAG is an Emacs font attribute key (eg :underline).
VAL is ignored."
(:overline (cons "text-decoration" "overline" ))
(:strike-through (cons "text-decoration" "line-through")))))
-(defun hfy-invisible (&optional val)
+(defun hfy-invisible (&optional _val)
"This text should be invisible.
Do something in CSS to make that happen.
VAL is ignored here."
in which case the first face specification returned by `hfy-combined-face-spec'
which *doesn't* clash with CLASS is returned.\n
\(A specification with a class of t is considered to match any class you
-specify - this matches Emacs' behavior when deciding on which face attributes
+specify - this matches Emacs's 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,
+If CLASS is nil, then you just get whatever `face-attr-construct' returns,
ie the current specification in effect for FACE.\n
*NOTE*: This function forces any face that is not 'default and which has
no :inherit property to inherit from 'default (this is because 'default
-is magical in that Emacs' fonts behave as if they inherit implicitly from
+is magical in that Emacs's fonts behave as if they inherit implicitly from
'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
((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.
+ (facep (symbol-value fn)))
(hfy-face-attr-for-class (symbol-value fn) hfy-display-class))
(t nil)))
;; text-decoration is not inherited.
;; but it's not wrong and if this ever changes it will
;; be needed, so I think it's better to leave it in? -- v
- (nconc final-style '(("text-decoration"."none"))))))
+ (nconc final-style '(("text-decoration" . "none"))))))
final-style))
;; strip redundant bits from a name. Technically, this could result in
;; construct an assoc of (stripped-name . "{ css-stuff-here }") pairs
;; from a face:
-(defun hfy-face-to-css (fn)
- "Take FN, a font or `defface' specification (cf `face-attr-construct')
-and return a CSS style specification.\n
-See also `hfy-face-to-style'."
+(defun hfy-face-to-css-default (fn)
+ "Default handler for mapping faces to styles.
+See also `hfy-face-to-css'."
;;(message "hfy-face-to-css");;DBUG
(let* ((css-list (hfy-face-to-style fn))
(seen nil)
css-list)))
(cons (hfy-css-name fn) (format "{%s}" (apply 'concat css-text)))) )
+(defvar hfy-face-to-css 'hfy-face-to-css-default
+ "Handler for mapping faces to styles.
+The signature of the handler is of the form \(lambda (FN) ...\).
+FN is a font or `defface' specification (cf
+`face-attr-construct'). The handler should return a cons cell of
+the form (STYLE-NAME . STYLE-SPEC).
+
+The default handler is `hfy-face-to-css-default'.
+
+See also `hfy-face-to-style'.")
+
(defalias 'hfy-prop-invisible-p
(if (fboundp 'invisible-p) #'invisible-p
(lambda (prop)
(setq p (next-char-property-change p)))
;; still invisible at buffer end?
(when i
- (setq invisible (cons (cons s (point-max)) invisible)))
+ (setq invisible (cons (cons s (point-max)) invisible)))
invisible)))
(defun hfy-invisible-name (point map)
;; construct an assoc of (face-name . (css-name . "{ css-style }")) elements:
(defun hfy-compile-stylesheet ()
- "Trawl the current buffer, construct and return a `hfy-sheet-assoc'."
+ "Trawl the current buffer, construct and return a `hfy-sheet-assoc'.
+If `hfy-user-sheet-assoc' is currently bound then use it to
+collect new styles discovered during this run. Otherwise create
+a new assoc."
;;(message "hfy-compile-stylesheet");;DBUG
(let ((pt (point-min))
;; Make the font stack stay:
;;(hfy-tmpfont-stack nil)
(fn nil)
- (style nil))
+ (style (and (boundp 'hfy-user-sheet-assoc) hfy-user-sheet-assoc)))
(save-excursion
(goto-char pt)
(while (< pt (point-max))
(if (and (setq fn (hfy-face-at pt)) (not (assoc fn style)))
- (push (cons fn (hfy-face-to-css fn)) style))
- (setq pt (next-char-property-change pt))) )
- (push (cons 'default (hfy-face-to-css 'default)) style)))
+ (push (cons fn (funcall hfy-face-to-css fn)) style))
+ (setq pt (next-char-property-change pt))))
+ (unless (assoc 'default style)
+ (push (cons 'default (funcall hfy-face-to-css 'default)) style))
+ (when (boundp 'hfy-user-sheet-assoc)
+ (setq hfy-user-sheet-assoc style))
+ style))
(defun hfy-fontified-p ()
"`font-lock' doesn't like to say it's been fontified when in batch
(setq pt (next-char-property-change pt))
(setq pt-narrow (+ offset pt)))
(if (and map (not (eq 'end (cdar map))))
- (push (cons (- (point-max) (point-min)) 'end) map)))
+ (push (cons (1+ (- (point-max) (point-min))) 'end) map)))
(if (hfy-opt 'merge-adjacent-tags) (hfy-merge-adjacent-spans map) map)))
(defun hfy-buffer ()
(remove-text-properties (point-min) (point-max)
'(hfy-show-trailing-whitespace)))))
+(defun hfy-begin-span (style text-block text-id text-begins-block-p)
+ "Default handler to begin a span of text.
+Insert \"<span class=\"STYLE\" ...>\". See
+`hfy-begin-span-handler' for more information."
+ (when text-begins-block-p
+ (insert
+ (format "<span onclick=\"toggle_invis('%s');\">…</span>" text-block)))
+
+ (insert
+ (if text-block
+ (format "<span class=\"%s\" id=\"%s-%d\">" style text-block text-id)
+ (format "<span class=\"%s\">" style))))
+
+(defun hfy-end-span ()
+ "Default handler to end a span of text.
+Insert \"</span>\". See `hfy-end-span-handler' for more
+information."
+ (insert "</span>"))
+
+(defvar hfy-begin-span-handler 'hfy-begin-span
+ "Handler to begin a span of text.
+The signature of the handler is \(lambda (STYLE TEXT-BLOCK
+TEXT-ID TEXT-BEGINS-BLOCK-P) ...\). The handler must insert
+appropriate tags to begin a span of text.
+
+STYLE is the name of the style that begins at point. It is
+derived from the face attributes as part of `hfy-face-to-css'
+callback. The other arguments TEXT-BLOCK, TEXT-ID,
+TEXT-BEGINS-BLOCK-P are non-nil only if the buffer contains
+invisible text.
+
+TEXT-BLOCK is a string that identifies a single chunk of visible
+or invisible text of which the current position is a part. For
+visible portions, it's value is \"nil\". For invisible portions,
+it's value is computed as part of `hfy-invisible-name'.
+
+TEXT-ID marks a unique position within a block. It is set to
+value of `point' at the current buffer position.
+
+TEXT-BEGINS-BLOCK-P is a boolean and is non-nil if the current
+span also begins a invisible portion of text.
+
+An implementation can use TEXT-BLOCK, TEXT-ID,
+TEXT-BEGINS-BLOCK-P to implement fold/unfold-on-mouse-click like
+behaviour.
+
+The default handler is `hfy-begin-span'.")
+
+(defvar hfy-end-span-handler 'hfy-end-span
+ "Handler to end a span of text.
+The signature of the handler is \(lambda () ...\). The handler
+must insert appropriate tags to end a span of text.
+
+The default handler is `hfy-end-span'.")
+
(defun hfy-fontify-buffer (&optional srcdir file)
"Implement the guts of `htmlfontify-buffer'.
SRCDIR, if set, is the directory being htmlfontified.
(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:
+ ;; rip out props that could interfere with our htmlization of the buffer:
(remove-text-properties (point-min) (point-max) hfy-ignored-properties)
;; Apply overlay invisible spec
(setq orig-ovls
(or (get-text-property pt 'hfy-linkp)
(get-text-property pt 'hfy-endl )))
(if (eq 'end fn)
- (insert "</span>")
+ (funcall hfy-end-span-handler)
(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))))
+ (funcall hfy-begin-span-handler
+ (hfy-lookup fn css-sheet)
+ (and invis-ranges
+ (format "%s" (hfy-invisible-name pt invis-ranges)))
+ (and invis-ranges pt)
+ (and invis-ranges (assq pt invis-ranges)))
(if (not move-link) nil
;;(message "removing prop2 @ %d" (point))
(if (remove-text-properties (point) (1+ (point)) '(hfy-endl nil))
;; so we have to do this after we use said properties:
;; (message "munging dangerous characters")
(hfy-html-dekludge-buffer)
- ;; insert the stylesheet at the top:
- (goto-char (point-min))
- ;;(message "inserting stylesheet")
- (insert (hfy-sprintf-stylesheet css-sheet file))
- (if (hfy-opt 'div-wrapper) (insert "<div class=\"default\">"))
- (insert "\n<pre>")
- (goto-char (point-max))
- (insert "</pre>\n")
- (if (hfy-opt 'div-wrapper) (insert "</div>"))
- ;;(message "inserting footer")
- (insert (funcall hfy-page-footer file))
+ (unless (hfy-opt 'body-text-only)
+ ;; insert the stylesheet at the top:
+ (goto-char (point-min))
+
+ ;;(message "inserting stylesheet")
+ (insert (hfy-sprintf-stylesheet css-sheet file))
+
+ (if (hfy-opt 'div-wrapper) (insert "<div class=\"default\">"))
+ (insert "\n<pre>")
+ (goto-char (point-max))
+ (insert "</pre>\n")
+ (if (hfy-opt 'div-wrapper) (insert "</div>"))
+ ;;(message "inserting footer")
+ (insert (funcall hfy-page-footer file)))
;; call any post html-generation hooks:
- (run-hooks 'hfy-post-html-hooks)
+ (run-hooks 'hfy-post-html-hook)
;; return the html buffer
(set-buffer-modified-p nil)
html-buffer))
+(defun htmlfontify-string (string)
+ "Take a STRING and return a fontified version of it.
+It is assumed that STRING has text properties that allow it to be
+fontified. This is a simple convenience wrapper around
+`htmlfontify-buffer'."
+ (let* ((hfy-optimisations-1 (copy-sequence hfy-optimisations))
+ (hfy-optimisations (add-to-list 'hfy-optimisations-1
+ 'skip-refontification)))
+ (with-temp-buffer
+ (insert string)
+ (htmlfontify-buffer)
+ (buffer-string))))
+
(defun hfy-force-fontification ()
"Try to force font-locking even when it is optimized away."
(run-hooks 'hfy-init-kludge-hook)
(if (not (hfy-opt 'skip-refontification))
(save-excursion ;; Keep region
(hfy-force-fontification)))
- (if (interactive-p) ;; display the buffer in interactive mode:
+ (if (called-interactively-p 'any) ;; display the buffer in interactive mode:
(switch-to-buffer (hfy-fontify-buffer srcdir file))
(hfy-fontify-buffer srcdir file)))
"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??
+ ;; FIXME: this changes the dir of the current 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))) )
-;; strip the filename off, return a directiry name
-;; not a particularly thorough implementaion, but it will be
+;; strip the filename off, return a directory name
+;; not a particularly thorough implementation, but it will be
;; fed pretty carefully, so it should be Ok:
(defun hfy-dirname (file)
"Return everything preceding the last \"/\" from a relative filename FILE,
tags-list) )))
(defun hfy-shell ()
- "Return `shell-file-name', or \"/bin/sh\" if it is a non-bourne shell."
+ "Return `shell-file-name', or \"/bin/sh\" if it is a non-Bourne shell."
(if (string-match "\\<bash\\>\\|\\<sh\\>\\|\\<dash\\>" shell-file-name)
shell-file-name
(or hfy-shell-file-name "/bin/sh")))
(hash-entry nil) (tag-string nil) (tag-line nil)
(tag-point nil) (new-entry nil) (etags-file nil))
- ;; (re)initialise the tag reverse map:
+ ;; (re)initialize the tag reverse map:
(if trmap-cache (setq trmap-hash (cadr trmap-cache))
(setq trmap-hash (make-hash-table :test 'equal))
(setq hfy-tags-rmap (list (list srcdir trmap-hash) hfy-tags-rmap)))
(clrhash trmap-hash)
- ;; (re)initialise the tag cache:
+ ;; (re)initialize the tag cache:
(if cache-entry (setq cache-hash (cadr cache-entry))
(setq cache-hash (make-hash-table :test 'equal))
(setq hfy-tags-cache (list (list srcdir cache-hash) hfy-tags-cache)))
(puthash tag-string hash-entry cache-hash)))) )))
;; cache a list of tags in descending length order:
- (maphash (lambda (K V) (push 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:
(setq cache-hash (cadr cache-entry))
(setq index-buf (get-buffer-create index-file))))
nil ;; noop
- (maphash (lambda (K V) (push 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)
(cache-entry (assoc srcdir hfy-tags-cache)))
(if (and cache-entry (setq cache-hash (cadr cache-entry)))
(maphash
- (lambda (K V)
+ (lambda (K _V)
(let ((stub (upcase (substring K 0 1))))
(if (member stub stub-list)
nil ;; seen this already: NOOP
(if (and cache-entry (setq cache-hash (cadr cache-entry)))
(maphash
- (lambda (K V)
+ (lambda (K _V)
(let ((stub (upcase (substring K 0 1))))
(if (member stub stub-list)
nil ;; seen this already: NOOP
\f
;;;### (autoloads (hfy-fallback-colour-values htmlfontify-load-rgb-file)
-;;;;;; "hfy-cmap" "hfy-cmap.el" "8dce008297f15826cc6ab82203c46fa6")
+;;;;;; "hfy-cmap" "hfy-cmap.el" "3f97eeabe72027099da579f6ef9ae0bd")
;;; Generated autoloads from hfy-cmap.el
(autoload 'htmlfontify-load-rgb-file "hfy-cmap" "\