aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Monnier2011-01-27 12:04:07 -0500
committerStefan Monnier2011-01-27 12:04:07 -0500
commit153c5428d248cd14341a75c1284d5063357ff3a0 (patch)
tree368d53d8447e608263ae54563535c229c9cce30c
parent14596870e2556fd565f258b87ee3ce5751cbba10 (diff)
downloademacs-153c5428d248cd14341a75c1284d5063357ff3a0.tar.gz
emacs-153c5428d248cd14341a75c1284d5063357ff3a0.zip
* 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.
-rw-r--r--lisp/ChangeLog20
-rw-r--r--lisp/htmlfontify.el294
2 files changed, 148 insertions, 166 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 36e56bf1253..1f3d3d17be9 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,23 @@
12011-01-27 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * htmlfontify.el: Make it obey the font-lock-face text property.
4 Miscellaneous cleanup such as:
5 - Don't hide expressions after a closing paren.
6 - Move initial setq into let.
7 - Hoist common parts out of ifs.
8 (hfy-p-to-face, hfy-p-to-face-lennart): Remove.
9 (hfy-face-at): Use get-text-property instead.
10 (hfy-prop-invisible-p): Use invisible-p if available.
11 (htmlfontify-manual): Use \\[...].
12 (hfy-html-quote-regex): Use [...].
13 (hfy-combined-face-spec): Simplify.
14 (hfy-compile-face-map): Don't presume point-min==1.
15 (hfy-css-name, hfy-buffer, htmlfontify-buffer): Use \' rather than $ to
16 match end of string.
17 (hfy-text-p): η-reduce.
18 (hfy-tags-for-file): Receive cache-hash directly.
19 (hfy-mark-tag-names): Adjust call.
20
12011-01-27 Glenn Morris <rgm@gnu.org> 212011-01-27 Glenn Morris <rgm@gnu.org>
2 22
3 * msb.el (msb-after-load-hooks): Make it an obsolete alias. 23 * msb.el (msb-after-load-hooks): Make it an obsolete alias.
diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el
index d359bb0da86..5ecc529e561 100644
--- a/lisp/htmlfontify.el
+++ b/lisp/htmlfontify.el
@@ -108,13 +108,13 @@
108 `htmlfontify-load-rgb-file' 108 `htmlfontify-load-rgb-file'
109 `htmlfontify-unload-rgb-file'\n 109 `htmlfontify-unload-rgb-file'\n
110In order to:\n 110In order to:\n
111fontify a file you have open: M-x htmlfontify-buffer 111fontify a file you have open: \\[htmlfontify-buffer]
112prepare the etags map for a directory: M-x htmlfontify-run-etags 112prepare the etags map for a directory: \\[htmlfontify-run-etags]
113copy a directory, fontifying as you go: M-x htmlfontify-copy-and-link-dir\n 113copy a directory, fontifying as you go: \\[htmlfontify-copy-and-link-dir]\n
114The following might be useful when running non-windowed or in batch mode: 114The following might be useful when running non-windowed or in batch mode:
115\(note that they shouldn't be necessary - we have a built in map)\n 115\(note that they shouldn't be necessary - we have a built in map)\n
116load an X11 style rgb.txt file: M-x htmlfontify-load-rgb-file 116load an X11 style rgb.txt file: \\[htmlfontify-load-rgb-file]
117unload the current rgb.txt file: M-x htmlfontify-unload-rgb-file\n 117unload the current rgb.txt file: \\[htmlfontify-unload-rgb-file]\n
118And here's a programmatic example:\n 118And here's a programmatic example:\n
119\(defun rtfm-build-page-header (file style) 119\(defun rtfm-build-page-header (file style)
120 (format \"#define TEMPLATE red+black.html 120 (format \"#define TEMPLATE red+black.html
@@ -150,10 +150,12 @@ main-content <=MAIN_CONTENT;\\n\" rtfm-section file style rtfm-section file))
150 :prefix "hfy-") 150 :prefix "hfy-")
151 151
152(defcustom hfy-page-header 'hfy-default-header 152(defcustom hfy-page-header 'hfy-default-header
153 "Function called with two arguments (the filename relative to the top 153 "Function called to build the header of the html source.
154This is called with two arguments (the filename relative to the top
154level source directory being etag'd and fontified), and a string containing 155level source directory being etag'd and fontified), and a string containing
155the <style>...</style> text to embed in the document- the string returned will 156the <style>...</style> text to embed in the document.
156be used as the header for the htmlfontified version of the source file.\n 157It should return the string returned will be used as the header for the
158htmlfontified version of the source file.\n
157See also `hfy-page-footer'." 159See also `hfy-page-footer'."
158 :group 'htmlfontify 160 :group 'htmlfontify
159 ;; FIXME: Why place such a :tag everywhere? Isn't it imposing your 161 ;; FIXME: Why place such a :tag everywhere? Isn't it imposing your
@@ -162,16 +164,17 @@ See also `hfy-page-footer'."
162 :type '(function)) 164 :type '(function))
163 165
164(defcustom hfy-split-index nil 166(defcustom hfy-split-index nil
165 "Whether or not to split the index `hfy-index-file' alphabetically 167 "Whether or not to split the index `hfy-index-file' alphabetically.
166on the first letter of each tag. Useful when the index would otherwise 168If non-nil, the index is split on the first letter of each tag.
169Useful when the index would otherwise
167be large and take a long time to render or be difficult to navigate." 170be large and take a long time to render or be difficult to navigate."
168 :group 'htmlfontify 171 :group 'htmlfontify
169 :tag "split-index" 172 :tag "split-index"
170 :type '(boolean)) 173 :type '(boolean))
171 174
172(defcustom hfy-page-footer 'hfy-default-footer 175(defcustom hfy-page-footer 'hfy-default-footer
173 "As `hfy-page-header', but generates the output footer 176 "As `hfy-page-header', but generates the output footer.
174\(and takes only one argument, the filename)." 177It takes only one argument, the filename."
175 :group 'htmlfontify 178 :group 'htmlfontify
176 :tag "page-footer" 179 :tag "page-footer"
177 :type '(function)) 180 :type '(function))
@@ -204,7 +207,8 @@ code using this should fall back to `hfy-extn'."
204 :type '(choice string (const nil))) 207 :type '(choice string (const nil)))
205 208
206(defcustom hfy-link-style-fun 'hfy-link-style-string 209(defcustom hfy-link-style-fun 'hfy-link-style-string
207 "Set this to a function, which will be called with one argument 210 "Function to customize the appearance of hyperlinks.
211Set this to a function, which will be called with one argument
208\(a \"{ foo: bar; ...}\" CSS style-string) - it should return a copy of 212\(a \"{ foo: bar; ...}\" CSS style-string) - it should return a copy of
209its argument, altered so as to make any changes you want made for text which 213its argument, altered so as to make any changes you want made for text which
210is a hyperlink, in addition to being in the class to which that style would 214is a hyperlink, in addition to being in the class to which that style would
@@ -227,7 +231,7 @@ fontification-and-hyperlinking."
227 :tag "instance-file" 231 :tag "instance-file"
228 :type '(string)) 232 :type '(string))
229 233
230(defcustom hfy-html-quote-regex "\\(<\\|\"\\|&\\|>\\)" 234(defcustom hfy-html-quote-regex "\\([<\"&>]\\)"
231 "Regex to match (with a single back-reference per match) strings in HTML 235 "Regex to match (with a single back-reference per match) strings in HTML
232which should be quoted with `hfy-html-quote' (and `hfy-html-quote-map') 236which should be quoted with `hfy-html-quote' (and `hfy-html-quote-map')
233to make them safe." 237to make them safe."
@@ -555,7 +559,8 @@ therefore no longer care about) will be invalid at any time.\n
555 (while sa 559 (while sa
556 (setq elt (car sa) 560 (setq elt (car sa)
557 sa (cdr sa)) 561 sa (cdr sa))
558 (if (memq elt set-b) (setq interq (cons elt interq)))) interq)) 562 (if (memq elt set-b) (setq interq (cons elt interq))))
563 interq))
559 564
560(defun hfy-colour-vals (colour) 565(defun hfy-colour-vals (colour)
561 "Where COLOUR is a color name or #XXXXXX style triplet, return a 566 "Where COLOUR is a color name or #XXXXXX style triplet, return a
@@ -586,7 +591,8 @@ in a windowing system - try to trick it..."
586 (setq cperl-syntaxify-by-font-lock t))) 591 (setq cperl-syntaxify-by-font-lock t)))
587 (setq hfy-cperl-mode-kludged-p t))) ) 592 (setq hfy-cperl-mode-kludged-p t))) )
588 593
589(defun hfy-opt (symbol) "Is option SYMBOL set." (memq symbol hfy-optimisations)) 594(defun hfy-opt (symbol) "Is option SYMBOL set."
595 (memq symbol hfy-optimisations))
590 596
591(defun hfy-default-header (file style) 597(defun hfy-default-header (file style)
592 "Default value for `hfy-page-header'. 598 "Default value for `hfy-page-header'.
@@ -717,7 +723,8 @@ of the variable `hfy-src-doc-link-style', removing text matching the regex
717 (concat (replace-match hfy-src-doc-link-style 723 (concat (replace-match hfy-src-doc-link-style
718 'fixed-case 724 'fixed-case
719 'literal 725 'literal
720 style-string) " }") style-string)) 726 style-string) " }")
727 style-string))
721 728
722;; utility functions - cast emacs style specification values into their 729;; utility functions - cast emacs style specification values into their
723;; css2 equivalents: 730;; css2 equivalents:
@@ -835,11 +842,11 @@ VAL is ignored here."
835 "Return a `defface' style alist of possible specifications for FACE. 842 "Return a `defface' style alist of possible specifications for FACE.
836Entries resulting from customization (`custom-set-faces') will take 843Entries resulting from customization (`custom-set-faces') will take
837precedence." 844precedence."
838 (let ((spec nil)) 845 (append
839 (setq spec (append (or (get face 'saved-face) (list)) 846 (if (and hfy-display-class hfy-default-face-def (eq face 'default))
840 (or (get face 'face-defface-spec) (list)))) 847 hfy-default-face-def)
841 (if (and hfy-display-class hfy-default-face-def (eq face 'default)) 848 (get face 'saved-face)
842 (setq spec (append hfy-default-face-def spec))) spec)) 849 (get face 'face-defface-spec)))
843 850
844(defun hfy-face-attr-for-class (face &optional class) 851(defun hfy-face-attr-for-class (face &optional class)
845 "Return the face attributes for FACE. 852 "Return the face attributes for FACE.
@@ -1045,10 +1052,9 @@ haven't encountered them yet. Returns a `hfy-style-assoc'."
1045and return a `hfy-style-assoc'.\n 1052and return a `hfy-style-assoc'.\n
1046See also `hfy-face-to-style-i', `hfy-flatten-style'." 1053See also `hfy-face-to-style-i', `hfy-flatten-style'."
1047 ;;(message "hfy-face-to-style");;DBUG 1054 ;;(message "hfy-face-to-style");;DBUG
1048 (let ((face-def (hfy-face-resolve-face fn)) 1055 (let* ((face-def (hfy-face-resolve-face fn))
1049 (final-style nil)) 1056 (final-style
1050 1057 (hfy-flatten-style (hfy-face-to-style-i face-def))))
1051 (setq final-style (hfy-flatten-style (hfy-face-to-style-i face-def)))
1052 ;;(message "%S" final-style) 1058 ;;(message "%S" final-style)
1053 (if (not (assoc "text-decoration" final-style)) 1059 (if (not (assoc "text-decoration" final-style))
1054 (progn (setq final-style 1060 (progn (setq final-style
@@ -1090,8 +1096,9 @@ See also `hfy-face-to-style-i', `hfy-flatten-style'."
1090 (string-match "^[Ii]nfo-\\(.*\\)" face-name)) 1096 (string-match "^[Ii]nfo-\\(.*\\)" face-name))
1091 (progn 1097 (progn
1092 (setq face-name (match-string 1 face-name)) 1098 (setq face-name (match-string 1 face-name))
1093 (if (string-match "\\(.*\\)-face$" face-name) 1099 (if (string-match "\\(.*\\)-face\\'" face-name)
1094 (setq face-name (match-string 1 face-name))) face-name) 1100 (setq face-name (match-string 1 face-name)))
1101 face-name)
1095 face-name)) ) 1102 face-name)) )
1096 1103
1097;; construct an assoc of (stripped-name . "{ css-stuff-here }") pairs 1104;; construct an assoc of (stripped-name . "{ css-stuff-here }") pairs
@@ -1101,91 +1108,45 @@ See also `hfy-face-to-style-i', `hfy-flatten-style'."
1101and return a CSS style specification.\n 1108and return a CSS style specification.\n
1102See also `hfy-face-to-style'." 1109See also `hfy-face-to-style'."
1103 ;;(message "hfy-face-to-css");;DBUG 1110 ;;(message "hfy-face-to-css");;DBUG
1104 (let ((css-list nil) 1111 (let* ((css-list (hfy-face-to-style fn))
1105 (css-text nil) 1112 (seen nil)
1106 (seen nil)) 1113 (css-text
1107 ;;(message "(hfy-face-to-style %S)" fn)
1108 (setq css-list (hfy-face-to-style fn))
1109 (setq css-text
1110 (mapcar 1114 (mapcar
1111 (lambda (E) 1115 (lambda (E)
1112 (if (car E) 1116 (if (car E)
1113 (unless (member (car E) seen) 1117 (unless (member (car E) seen)
1114 (push (car E) seen) 1118 (push (car E) seen)
1115 (format " %s: %s; " (car E) (cdr E))))) 1119 (format " %s: %s; " (car E) (cdr E)))))
1116 css-list)) 1120 css-list)))
1117 (cons (hfy-css-name fn) (format "{%s}" (apply 'concat css-text)))) ) 1121 (cons (hfy-css-name fn) (format "{%s}" (apply 'concat css-text)))) )
1118 1122
1119;; extract a face from a list of char properties, if there is one: 1123(defalias 'hfy-prop-invisible-p
1120(defun hfy-p-to-face (props) 1124 (if (fboundp 'invisible-p) #'invisible-p
1121 "Given PROPS, a list of text properties, return the value of the face 1125 (lambda (prop)
1122property, or nil." 1126 "Is text property PROP an active invisibility property?"
1123 (if props 1127 (or (and (eq buffer-invisibility-spec t) prop)
1124 (if (string= (car props) "face") 1128 (or (memq prop buffer-invisibility-spec)
1125 (let ((propval (cadr props))) 1129 (assq prop buffer-invisibility-spec))))))
1126 (if (and (listp propval) (not (cdr propval)))
1127 (car propval)
1128 propval))
1129 (hfy-p-to-face (cddr props)))
1130 nil))
1131
1132(defun hfy-p-to-face-lennart (props)
1133 "Given PROPS, a list of text properties, return the value of the face
1134property, or nil."
1135 (when props
1136 (let ((face (plist-get props 'face))
1137 (font-lock-face (plist-get props 'font-lock-face))
1138 (button (plist-get props 'button))
1139 ;;(face-rec (memq 'face props))
1140 ;;(button-rec (memq 'button props)))
1141 )
1142 (if button
1143 (let* ((category (plist-get props 'category))
1144 (face (when category (plist-get (symbol-plist category) 'face))))
1145 face)
1146 (or font-lock-face
1147 face)))))
1148
1149;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1150;; (defun hfy-get-face-at (pos)
1151;; ;; (let ((face (get-char-property-and-overlay pos 'face)))
1152;; ;; (when (and face (listp face)) (setq face (car face)))
1153;; ;; (unless (listp face)
1154;; ;; face)))
1155;; ;;(get-char-property pos 'face)
1156;; ;; Overlays are handled later
1157;; (if (or (not show-trailing-whitespace)
1158;; (not (get-text-property pos 'hfy-show-trailing-whitespace)))
1159;; (get-text-property pos 'face)
1160;; (list 'trailing-whitespace (get-text-property pos 'face)))
1161;; )
1162
1163(defun hfy-prop-invisible-p (prop)
1164 "Is text property PROP an active invisibility property?"
1165 (or (and (eq buffer-invisibility-spec t) prop)
1166 (or (memq prop buffer-invisibility-spec)
1167 (assq prop buffer-invisibility-spec))))
1168 1130
1169(defun hfy-find-invisible-ranges () 1131(defun hfy-find-invisible-ranges ()
1170 "Return a list of (start-point . end-point) cons cells of invisible regions." 1132 "Return a list of (start-point . end-point) cons cells of invisible regions."
1171 (let (invisible p i e s) ;; return-value pos invisible end start 1133 (save-excursion
1172 (save-excursion 1134 (let (invisible p i s) ;; return-value pos invisible end start
1173 (setq p (goto-char (point-min))) 1135 (setq p (goto-char (point-min)))
1174 (when (invisible-p p) (setq s p i t)) 1136 (when (invisible-p p) (setq s p i t))
1175 (while (< p (point-max)) 1137 (while (< p (point-max))
1176 (if i ;; currently invisible 1138 (if i ;; currently invisible
1177 (when (not (invisible-p p)) ;; but became visible 1139 (when (not (invisible-p p)) ;; but became visible
1178 (setq e p 1140 (setq i nil
1179 i nil 1141 invisible (cons (cons s p) invisible)))
1180 invisible (cons (cons s e) invisible)))
1181 ;; currently visible: 1142 ;; currently visible:
1182 (when (invisible-p p) ;; but have become invisible 1143 (when (invisible-p p) ;; but have become invisible
1183 (setq s p i t))) 1144 (setq s p i t)))
1184 (setq p (next-char-property-change p))) 1145 (setq p (next-char-property-change p)))
1185 ;; still invisible at buffer end? 1146 ;; still invisible at buffer end?
1186 (when i 1147 (when i
1187 (setq e (point-max) 1148 (setq invisible (cons (cons s (point-max)) invisible)))
1188 invisible (cons (cons s e) invisible))) ) invisible)) 1149 invisible)))
1189 1150
1190(defun hfy-invisible-name (point map) 1151(defun hfy-invisible-name (point map)
1191 "Generate a CSS style name for an invisible section of the buffer. 1152 "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."
1215 ;; not sure why we'd want to remove face-name? -- v 1176 ;; not sure why we'd want to remove face-name? -- v
1216 (let ((overlay-data nil) 1177 (let ((overlay-data nil)
1217 (base-face nil) 1178 (base-face nil)
1218 ;; restored hfy-p-to-face as it handles faces like (bold) as 1179 (face-name (get-text-property p 'face))
1219 ;; well as face like 'bold - hfy-get-face-at doesn't dtrt -- v
1220 (face-name (hfy-p-to-face (text-properties-at p)))
1221 ;; (face-name (hfy-get-face-at p)) 1180 ;; (face-name (hfy-get-face-at p))
1222 (prop-seen nil) 1181 (prop-seen nil)
1223 (extra-props nil) 1182 (extra-props nil)
@@ -1333,9 +1292,9 @@ return a `defface' style list of face properties instead of a face symbol."
1333 extra-props (cons p (cons v extra-props)))))))))) 1292 extra-props (cons p (cons v extra-props))))))))))
1334 ;;(message "+ %d: %s; %S" p face-name extra-props) 1293 ;;(message "+ %d: %s; %S" p face-name extra-props)
1335 (if extra-props 1294 (if extra-props
1336 (if (listp face-name) 1295 (nconc extra-props (if (listp face-name)
1337 (nconc extra-props face-name) 1296 face-name
1338 (nconc extra-props (face-attr-construct face-name))) 1297 (face-attr-construct face-name)))
1339 face-name)) )) 1298 face-name)) ))
1340 1299
1341(defun hfy-overlay-props-at (p) 1300(defun hfy-overlay-props-at (p)
@@ -1378,7 +1337,8 @@ variable `font-lock-mode' and variable `font-lock-fontified' for truth."
1378 (goto-char pt) 1337 (goto-char pt)
1379 (while (and (< pt (point-max)) (not face-name)) 1338 (while (and (< pt (point-max)) (not face-name))
1380 (setq face-name (hfy-face-at pt)) 1339 (setq face-name (hfy-face-at pt))
1381 (setq pt (next-char-property-change pt)))) face-name) 1340 (setq pt (next-char-property-change pt))))
1341 face-name)
1382 font-lock-mode))) 1342 font-lock-mode)))
1383 1343
1384;; remember, the map is in reverse point order: 1344;; remember, the map is in reverse point order:
@@ -1441,12 +1401,13 @@ Returns a modified copy of FACE-MAP."
1441;; Fix-me: save table for multi-buffer 1401;; Fix-me: save table for multi-buffer
1442 "Compile and return a `hfy-facemap-assoc' for the current buffer." 1402 "Compile and return a `hfy-facemap-assoc' for the current buffer."
1443 ;;(message "hfy-compile-face-map");;DBUG 1403 ;;(message "hfy-compile-face-map");;DBUG
1444 (let ((pt (point-min)) 1404 (let* ((pt (point-min))
1445 (pt-narrow 1) 1405 (pt-narrow (save-restriction (widen) (point-min)))
1446 (fn nil) 1406 (offset (- pt pt-narrow))
1447 (map nil) 1407 (fn nil)
1448 (prev-tag nil)) ;; t if the last tag-point was a span-start 1408 (map nil)
1449 ;; nil if it was a span-stop 1409 (prev-tag nil)) ;; t if the last tag-point was a span-start
1410 ;; nil if it was a span-stop
1450 (save-excursion 1411 (save-excursion
1451 (goto-char pt) 1412 (goto-char pt)
1452 (while (< pt (point-max)) 1413 (while (< pt (point-max))
@@ -1457,7 +1418,7 @@ Returns a modified copy of FACE-MAP."
1457 (if prev-tag (push (cons pt-narrow 'end) map)) 1418 (if prev-tag (push (cons pt-narrow 'end) map))
1458 (setq prev-tag nil)) 1419 (setq prev-tag nil))
1459 (setq pt (next-char-property-change pt)) 1420 (setq pt (next-char-property-change pt))
1460 (setq pt-narrow (1+ (- pt (point-min))))) 1421 (setq pt-narrow (+ offset pt)))
1461 (if (and map (not (eq 'end (cdar map)))) 1422 (if (and map (not (eq 'end (cdar map))))
1462 (push (cons (- (point-max) (point-min)) 'end) map))) 1423 (push (cons (- (point-max) (point-min)) 'end) map)))
1463 (if (hfy-opt 'merge-adjacent-tags) (hfy-merge-adjacent-spans map) map))) 1424 (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',
1474 (with-current-buffer buf 1435 (with-current-buffer buf
1475 (setq buffer-file-name 1436 (setq buffer-file-name
1476 (if src (concat src hfy-extn) 1437 (if src (concat src hfy-extn)
1477 (expand-file-name (if (string-match "^.*/\\([^/]*\\)$" name) 1438 (expand-file-name (if (string-match "^.*/\\([^/]*\\)\\'" name)
1478 (match-string 1 name) 1439 (match-string 1 name)
1479 name)))) 1440 name))))
1480 buf))) 1441 buf)))
@@ -1492,23 +1453,22 @@ Uses `hfy-link-style-fun' to do this."
1492 1453
1493(defun hfy-sprintf-stylesheet (css file) 1454(defun hfy-sprintf-stylesheet (css file)
1494 "Return the inline CSS style sheet for FILE as a string." 1455 "Return the inline CSS style sheet for FILE as a string."
1495 (let ((stylesheet nil)) 1456 (let ((stylesheet
1496 (setq stylesheet 1457 (concat
1497 (concat 1458 hfy-meta-tags
1498 hfy-meta-tags 1459 "\n<style type=\"text/css\"><!-- \n"
1499 "\n<style type=\"text/css\"><!-- \n" 1460 ;; Fix-me: Add handling of page breaks here + scan for ^L
1500 ;; Fix-me: Add handling of page breaks here + scan for ^L 1461 ;; where appropriate.
1501 ;; where appropriate. 1462 (format "body %s\n" (cddr (assq 'default css)))
1502 (format "body %s\n" (cddr (assq 'default css))) 1463 (apply 'concat
1503 (apply 'concat 1464 (mapcar
1504 (mapcar 1465 (lambda (style)
1505 (lambda (style) 1466 (format
1506 (format 1467 "span.%s %s\nspan.%s a %s\n"
1507 "span.%s %s\nspan.%s a %s\n" 1468 (cadr style) (cddr style)
1508 (cadr style) (cddr style) 1469 (cadr style) (hfy-link-style (cddr style))))
1509 (cadr style) (hfy-link-style (cddr style)))) 1470 css))
1510 css)) 1471 " --></style>\n")))
1511 " --></style>\n"))
1512 (funcall hfy-page-header file stylesheet))) 1472 (funcall hfy-page-header file stylesheet)))
1513 1473
1514;; tag all the dangerous characters we want to escape 1474;; tag all the dangerous characters we want to escape
@@ -1698,33 +1658,32 @@ FILE, if set, is the file name."
1698 ;; (message "checking to see whether we should link...") 1658 ;; (message "checking to see whether we should link...")
1699 (if (and srcdir file) 1659 (if (and srcdir file)
1700 (let ((lp 'hfy-link) 1660 (let ((lp 'hfy-link)
1701 (pt nil) 1661 (pt (point-min))
1702 (pr nil) 1662 (pr nil)
1703 (rr nil)) 1663 (rr nil))
1704 ;; (message " yes we should.") 1664 ;; (message " yes we should.")
1705 ;; translate 'hfy-anchor properties to anchors 1665 ;; translate 'hfy-anchor properties to anchors
1706 (setq pt (point-min)) 1666 (while (setq pt (next-single-property-change pt 'hfy-anchor))
1707 (while (setq pt (next-single-property-change pt 'hfy-anchor)) 1667 (if (setq pr (get-text-property pt 'hfy-anchor))
1708 (if (setq pr (get-text-property pt 'hfy-anchor)) 1668 (progn (goto-char pt)
1709 (progn (goto-char pt) 1669 (remove-text-properties pt (1+ pt) '(hfy-anchor nil))
1710 (remove-text-properties pt (1+ pt) '(hfy-anchor nil)) 1670 (insert (concat "<a name=\"" pr "\"></a>")))))
1711 (insert (concat "<a name=\"" pr "\"></a>"))))) 1671 ;; translate alternate 'hfy-link and 'hfy-endl props to opening
1712 ;; translate alternate 'hfy-link and 'hfy-endl props to opening 1672 ;; and closing links. (this should avoid those spurious closes
1713 ;; and closing links. (this should avoid those spurious closes 1673 ;; we sometimes get by generating only paired tags)
1714 ;; we sometimes get by generating only paired tags) 1674 (setq pt (point-min))
1715 (setq pt (point-min)) 1675 (while (setq pt (next-single-property-change pt lp))
1716 (while (setq pt (next-single-property-change pt lp)) 1676 (if (not (setq pr (get-text-property pt lp))) nil
1717 (if (not (setq pr (get-text-property pt lp))) nil 1677 (goto-char pt)
1718 (goto-char pt) 1678 (remove-text-properties pt (1+ pt) (list lp nil))
1719 (remove-text-properties pt (1+ pt) (list lp nil)) 1679 (case lp
1720 (case lp 1680 (hfy-link
1721 (hfy-link 1681 (if (setq rr (get-text-property pt 'hfy-inst))
1722 (if (setq rr (get-text-property pt 'hfy-inst)) 1682 (insert (format "<a name=\"%s\"></a>" rr)))
1723 (insert (format "<a name=\"%s\"></a>" rr))) 1683 (insert (format "<a href=\"%s\">" pr))
1724 (insert (format "<a href=\"%s\">" pr)) 1684 (setq lp 'hfy-endl))
1725 (setq lp 'hfy-endl)) 1685 (hfy-endl
1726 (hfy-endl 1686 (insert "</a>") (setq lp 'hfy-link)) ))) ))
1727 (insert "</a>") (setq lp 'hfy-link)) ))) ))
1728 1687
1729 ;; ##################################################################### 1688 ;; #####################################################################
1730 ;; transform the dangerous chars. This changes character positions 1689 ;; transform the dangerous chars. This changes character positions
@@ -1790,7 +1749,7 @@ hyperlinks as appropriate."
1790 ;; pick up the file name in case we didn't receive it 1749 ;; pick up the file name in case we didn't receive it
1791 (if (not file) 1750 (if (not file)
1792 (progn (setq file (or (buffer-file-name) (buffer-name))) 1751 (progn (setq file (or (buffer-file-name) (buffer-name)))
1793 (if (string-match "/\\([^/]*\\)$" file) 1752 (if (string-match "/\\([^/]*\\)\\'" file)
1794 (setq file (match-string 1 file)))) ) 1753 (setq file (match-string 1 file)))) )
1795 1754
1796 (if (not (hfy-opt 'skip-refontification)) 1755 (if (not (hfy-opt 'skip-refontification))
@@ -1833,7 +1792,7 @@ Hardly bombproof, but good enough in the context in which it is being used."
1833 "Is SRCDIR/FILE text? Uses `hfy-istext-command' to determine this." 1792 "Is SRCDIR/FILE text? Uses `hfy-istext-command' to determine this."
1834 (let* ((cmd (format hfy-istext-command (expand-file-name file srcdir))) 1793 (let* ((cmd (format hfy-istext-command (expand-file-name file srcdir)))
1835 (rsp (shell-command-to-string cmd))) 1794 (rsp (shell-command-to-string cmd)))
1836 (if (string-match "text" rsp) t nil))) 1795 (string-match "text" rsp)))
1837 1796
1838;; open a file, check fontification, if fontified, write a fontified copy 1797;; open a file, check fontification, if fontified, write a fontified copy
1839;; to the destination directory, otherwise just copy the file: 1798;; to the destination directory, otherwise just copy the file:
@@ -1866,18 +1825,17 @@ adding an extension of `hfy-extn'. Fontification is actually done by
1866 (kill-buffer source)) )) 1825 (kill-buffer source)) ))
1867 1826
1868;; list of tags in file in srcdir 1827;; list of tags in file in srcdir
1869(defun hfy-tags-for-file (srcdir file) 1828(defun hfy-tags-for-file (cache-hash file)
1870 "List of etags tags that have definitions in this FILE. 1829 "List of etags tags that have definitions in this FILE.
1871Looks up the tags cache in `hfy-tags-cache' using SRCDIR as the key." 1830CACHE-HASH is the tags cache."
1872 ;;(message "hfy-tags-for-file");;DBUG 1831 ;;(message "hfy-tags-for-file");;DBUG
1873 (let ((cache-entry (assoc srcdir hfy-tags-cache)) 1832 (let* ((tag-list nil))
1874 (cache-hash nil) 1833 (if cache-hash
1875 (tag-list nil))
1876 (if (setq cache-hash (cadr cache-entry))
1877 (maphash 1834 (maphash
1878 (lambda (K V) 1835 (lambda (K V)
1879 (if (assoc file V) 1836 (if (assoc file V)
1880 (setq tag-list (cons K tag-list)))) cache-hash)) 1837 (setq tag-list (cons K tag-list))))
1838 cache-hash))
1881 tag-list)) 1839 tag-list))
1882 1840
1883;; mark the tags native to this file for anchors 1841;; 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."
1885 "Mark tags in FILE (lookup SRCDIR in `hfy-tags-cache') with the `hfy-anchor' 1843 "Mark tags in FILE (lookup SRCDIR in `hfy-tags-cache') with the `hfy-anchor'
1886property, with a value of \"tag.line-number\"." 1844property, with a value of \"tag.line-number\"."
1887 ;;(message "(hfy-mark-tag-names %s %s)" srcdir file);;DBUG 1845 ;;(message "(hfy-mark-tag-names %s %s)" srcdir file);;DBUG
1888 (let ((cache-entry (assoc srcdir hfy-tags-cache)) 1846 (let* ((cache-entry (assoc srcdir hfy-tags-cache))
1889 (cache-hash nil)) 1847 (cache-hash (cadr cache-entry)))
1890 (if (setq cache-hash (cadr cache-entry)) 1848 (if cache-hash
1891 (mapcar 1849 (mapcar
1892 (lambda (TAG) 1850 (lambda (TAG)
1893 (mapcar 1851 (mapcar
@@ -1900,7 +1858,7 @@ property, with a value of \"tag.line-number\"."
1900 (+ 2 chr) 1858 (+ 2 chr)
1901 'hfy-anchor link)))) 1859 'hfy-anchor link))))
1902 (gethash TAG cache-hash))) 1860 (gethash TAG cache-hash)))
1903 (hfy-tags-for-file srcdir file))))) 1861 (hfy-tags-for-file cache-hash file)))))
1904 1862
1905(defun hfy-relstub (file &optional start) 1863(defun hfy-relstub (file &optional start)
1906 "Return a \"../\" stub of the appropriate length for the current source 1864 "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."
1909 ;;(message "hfy-relstub");;DBUG 1867 ;;(message "hfy-relstub");;DBUG
1910 (let ((c "")) 1868 (let ((c ""))
1911 (while (setq start (string-match "/" file start)) 1869 (while (setq start (string-match "/" file start))
1912 (setq start (1+ start)) (setq c (concat c "../"))) c)) 1870 (setq start (1+ start)) (setq c (concat c "../")))
1871 c))
1913 1872
1914(defun hfy-href-stub (this-file def-files tag) 1873(defun hfy-href-stub (this-file def-files tag)
1915 "Return an href stub for a tag href in THIS-FILE. 1874 "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."
2183 dstdir 2142 dstdir
2184 hfy-index-file 2143 hfy-index-file
2185 stub) 2144 stub)
2186 index-list)) ))) cache-hash) ) index-list))) 2145 index-list)) )))
2146 cache-hash) )
2147 index-list)))
2187 2148
2188(defun hfy-prepare-tag-map (srcdir dstdir) 2149(defun hfy-prepare-tag-map (srcdir dstdir)
2189 "Prepare the counterpart(s) to the index buffer(s) - a list of buffers 2150 "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'."
2215 hfy-instance-file 2176 hfy-instance-file
2216 stub 2177 stub
2217 hfy-tags-rmap) 2178 hfy-tags-rmap)
2218 index-list)) ))) cache-hash) ) index-list))) 2179 index-list)) )))
2180 cache-hash) )
2181 index-list)))
2219 2182
2220(defun hfy-subtract-maps (srcdir) 2183(defun hfy-subtract-maps (srcdir)
2221 "Internal function - strips definitions of tags from the instance map. 2184 "Internal function - strips definitions of tags from the instance map.
@@ -2242,8 +2205,7 @@ See also `hfy-tags-cache', `hfy-tags-rmap'."
2242 "Load the etags cache for SRCDIR. 2205 "Load the etags cache for SRCDIR.
2243See also `hfy-load-tags-cache'." 2206See also `hfy-load-tags-cache'."
2244 (interactive "D source directory: ") 2207 (interactive "D source directory: ")
2245 (setq srcdir (directory-file-name srcdir)) 2208 (hfy-load-tags-cache (directory-file-name srcdir)))
2246 (hfy-load-tags-cache srcdir))
2247 2209
2248;;(defun hfy-test-read-args (foo bar) 2210;;(defun hfy-test-read-args (foo bar)
2249;; (interactive "D source directory: \nD target directory: ") 2211;; (interactive "D source directory: \nD target directory: ")
@@ -2296,7 +2258,7 @@ You may also want to set `hfy-page-header' and `hfy-page-footer'."
2296;; (defalias 'hfy-set-hooks 'custom-set-variables) 2258;; (defalias 'hfy-set-hooks 'custom-set-variables)
2297 2259
2298;; (defun hfy-pp-hook (H) 2260;; (defun hfy-pp-hook (H)
2299;; (and (string-match "-hook$" (symbol-name H)) 2261;; (and (string-match "-hook\\'" (symbol-name H))
2300;; (boundp H) 2262;; (boundp H)
2301;; (symbol-value H) 2263;; (symbol-value H)
2302;; (insert (format "\n '(%S %S)" H (symbol-value H))) 2264;; (insert (format "\n '(%S %S)" H (symbol-value H)))