;;; htmlfontify.el --- htmlise a buffer/source tree with optional hyperlinks
-;; Copyright (C) 2002, 2003, 2009, 2010 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.
`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
+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
:prefix "hfy-")
(defcustom hfy-page-header 'hfy-default-header
- "Function called with two arguments (the filename relative to the top
+ "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- the string returned will
-be used as the header for the htmlfontified version of the source file.\n
+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
: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 one 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))
: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
+ "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
:tag "instance-file"
:type '(string))
-(defcustom hfy-html-quote-regex "\\(<\\|\"\\|&\\|>\\)"
+(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."
(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 color name or #XXXXXX style triplet, return a
(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'.
(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:
"Return a `defface' style alist of possible specifications for FACE.
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.
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:
and return a `hfy-style-assoc'.\n
See also `hfy-face-to-style-i', `hfy-flatten-style'."
;;(message "hfy-face-to-style");;DBUG
- (let ((face-def (hfy-face-resolve-face 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
(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
and return a CSS style specification.\n
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
+ (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))
+ 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)
- (or 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.
;; 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 (get-text-property p 'face))
;; (face-name (hfy-get-face-at p))
(prop-seen nil)
(extra-props nil)
extra-props (cons p (cons v extra-props))))))))))
;;(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)))
+ (nconc extra-props (if (listp face-name)
+ face-name
+ (face-attr-construct face-name)))
face-name)) ))
(defun hfy-overlay-props-at (p)
(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:
;; 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 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))))
(push (cons (- (point-max) (point-min)) 'end) map)))
(if (hfy-opt 'merge-adjacent-tags) (hfy-merge-adjacent-spans map) map)))
(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)))
;; tag all the dangerous characters we want to escape
;; (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))
- (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)) ))) ))
+ ;; 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
;; 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))
"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
"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
;;(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 in THIS-FILE.
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
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.
"Load the etags cache for SRCDIR.
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: ")
;; (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)))
\f
;;;### (autoloads (hfy-fallback-colour-values htmlfontify-load-rgb-file)
-;;;;;; "hfy-cmap" "hfy-cmap.el" "3de2db2d213813bb3afe170ffd66cdde")
+;;;;;; "hfy-cmap" "hfy-cmap.el" "f7f81749b08e0aec14aac431f8b5ac8b")
;;; Generated autoloads from hfy-cmap.el
(autoload 'htmlfontify-load-rgb-file "hfy-cmap" "\
(provide 'htmlfontify)
-;; arch-tag: 944e5e63-c81d-4baa-a82a-0275f9c30e61
+;; Local Variables:
+;; coding: utf-8
+;; End:
+
;;; htmlfontify.el ends here
HCoop / bpt / emacs.git / blobdiff