1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-06 06:20:55 -08:00

* lisp/htmlfontify.el: Make it obey the font-lock-face text property.

Miscellaneous cleanup such as:
- Don't hide expressions after a closing paren.
- Move initial setq into let.
- Hoist common parts out of ifs.
(hfy-p-to-face, hfy-p-to-face-lennart): Remove.
(hfy-face-at): Use get-text-property instead.
(hfy-prop-invisible-p): Use invisible-p if available.
(htmlfontify-manual): Use \\[...].
(hfy-html-quote-regex): Use [...].
(hfy-combined-face-spec): Simplify.
(hfy-compile-face-map): Don't presume point-min==1.
(hfy-css-name, hfy-buffer, htmlfontify-buffer): Use \' rather than $ to
match end of string.
(hfy-text-p): η-reduce.
(hfy-tags-for-file): Receive cache-hash directly.
(hfy-mark-tag-names): Adjust call.
This commit is contained in:
Stefan Monnier 2011-01-27 12:04:07 -05:00
parent 14596870e2
commit 153c5428d2
2 changed files with 148 additions and 166 deletions

View file

@ -1,3 +1,23 @@
2011-01-27 Stefan Monnier <monnier@iro.umontreal.ca>
* htmlfontify.el: Make it obey the font-lock-face text property.
Miscellaneous cleanup such as:
- Don't hide expressions after a closing paren.
- Move initial setq into let.
- Hoist common parts out of ifs.
(hfy-p-to-face, hfy-p-to-face-lennart): Remove.
(hfy-face-at): Use get-text-property instead.
(hfy-prop-invisible-p): Use invisible-p if available.
(htmlfontify-manual): Use \\[...].
(hfy-html-quote-regex): Use [...].
(hfy-combined-face-spec): Simplify.
(hfy-compile-face-map): Don't presume point-min==1.
(hfy-css-name, hfy-buffer, htmlfontify-buffer): Use \' rather than $ to
match end of string.
(hfy-text-p): η-reduce.
(hfy-tags-for-file): Receive cache-hash directly.
(hfy-mark-tag-names): Adjust call.
2011-01-27 Glenn Morris <rgm@gnu.org>
* msb.el (msb-after-load-hooks): Make it an obsolete alias.

View file

@ -108,13 +108,13 @@
`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
@ -150,10 +150,12 @@ main-content <=MAIN_CONTENT;\\n\" rtfm-section file style rtfm-section file))
: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
@ -162,16 +164,17 @@ See also `hfy-page-footer'."
: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))
@ -204,7 +207,8 @@ code using this should fall back to `hfy-extn'."
: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
@ -227,7 +231,7 @@ fontification-and-hyperlinking."
: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."
@ -555,7 +559,8 @@ therefore no longer care about) will be invalid at any time.\n
(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
@ -586,7 +591,8 @@ in a windowing system - try to trick it..."
(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'.
@ -717,7 +723,8 @@ of the variable `hfy-src-doc-link-style', removing text matching the regex
(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:
@ -835,11 +842,11 @@ VAL is ignored here."
"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.
@ -1045,10 +1052,9 @@ haven't encountered them yet. Returns a `hfy-style-assoc'."
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
@ -1090,8 +1096,9 @@ See also `hfy-face-to-style-i', `hfy-flatten-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
@ -1101,91 +1108,45 @@ See also `hfy-face-to-style-i', `hfy-flatten-style'."
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.
@ -1215,9 +1176,7 @@ return a `defface' style list of face properties instead of a face symbol."
;; 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)
@ -1333,9 +1292,9 @@ return a `defface' style list of face properties instead of a face symbol."
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)
@ -1378,7 +1337,8 @@ 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:
@ -1441,12 +1401,13 @@ Returns a modified copy of FACE-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))
@ -1457,7 +1418,7 @@ Returns a modified copy of FACE-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))))
(push (cons (- (point-max) (point-min)) 'end) map)))
(if (hfy-opt 'merge-adjacent-tags) (hfy-merge-adjacent-spans map) map)))
@ -1474,7 +1435,7 @@ Otherwise a plausible filename is constructed from `default-directory',
(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)))
@ -1492,23 +1453,22 @@ Uses `hfy-link-style-fun' to do this."
(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
@ -1698,33 +1658,32 @@ FILE, if set, is the file name."
;; (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
@ -1790,7 +1749,7 @@ hyperlinks as appropriate."
;; 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))
@ -1833,7 +1792,7 @@ Hardly bombproof, but good enough in the context in which it is being used."
"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:
@ -1866,18 +1825,17 @@ adding an extension of `hfy-extn'. Fontification is actually done by
(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
@ -1885,9 +1843,9 @@ Looks up the tags cache in `hfy-tags-cache' using SRCDIR as the key."
"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
@ -1900,7 +1858,7 @@ property, with a value of \"tag.line-number\"."
(+ 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
@ -1909,7 +1867,8 @@ 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 in THIS-FILE.
@ -2183,7 +2142,9 @@ SRCDIR and DSTDIR are the source and output directories respectively."
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
@ -2215,7 +2176,9 @@ See also `hfy-prepare-index', `hfy-split-index'."
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.
@ -2242,8 +2205,7 @@ See also `hfy-tags-cache', `hfy-tags-rmap'."
"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: ")
@ -2296,7 +2258,7 @@ You may also want to set `hfy-page-header' and `hfy-page-footer'."
;; (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)))