diff options
| author | Stefan Monnier | 2011-01-27 12:04:07 -0500 |
|---|---|---|
| committer | Stefan Monnier | 2011-01-27 12:04:07 -0500 |
| commit | 153c5428d248cd14341a75c1284d5063357ff3a0 (patch) | |
| tree | 368d53d8447e608263ae54563535c229c9cce30c | |
| parent | 14596870e2556fd565f258b87ee3ce5751cbba10 (diff) | |
| download | emacs-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/ChangeLog | 20 | ||||
| -rw-r--r-- | lisp/htmlfontify.el | 294 |
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 @@ | |||
| 1 | 2011-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 | |||
| 1 | 2011-01-27 Glenn Morris <rgm@gnu.org> | 21 | 2011-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 |
| 110 | In order to:\n | 110 | In order to:\n |
| 111 | fontify a file you have open: M-x htmlfontify-buffer | 111 | fontify a file you have open: \\[htmlfontify-buffer] |
| 112 | prepare the etags map for a directory: M-x htmlfontify-run-etags | 112 | prepare the etags map for a directory: \\[htmlfontify-run-etags] |
| 113 | copy a directory, fontifying as you go: M-x htmlfontify-copy-and-link-dir\n | 113 | copy a directory, fontifying as you go: \\[htmlfontify-copy-and-link-dir]\n |
| 114 | The following might be useful when running non-windowed or in batch mode: | 114 | The 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 |
| 116 | load an X11 style rgb.txt file: M-x htmlfontify-load-rgb-file | 116 | load an X11 style rgb.txt file: \\[htmlfontify-load-rgb-file] |
| 117 | unload the current rgb.txt file: M-x htmlfontify-unload-rgb-file\n | 117 | unload the current rgb.txt file: \\[htmlfontify-unload-rgb-file]\n |
| 118 | And here's a programmatic example:\n | 118 | And 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. |
| 154 | This is called with two arguments (the filename relative to the top | ||
| 154 | level source directory being etag'd and fontified), and a string containing | 155 | level source directory being etag'd and fontified), and a string containing |
| 155 | the <style>...</style> text to embed in the document- the string returned will | 156 | the <style>...</style> text to embed in the document. |
| 156 | be used as the header for the htmlfontified version of the source file.\n | 157 | It should return the string returned will be used as the header for the |
| 158 | htmlfontified version of the source file.\n | ||
| 157 | See also `hfy-page-footer'." | 159 | See 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. |
| 166 | on the first letter of each tag. Useful when the index would otherwise | 168 | If non-nil, the index is split on the first letter of each tag. |
| 169 | Useful when the index would otherwise | ||
| 167 | be large and take a long time to render or be difficult to navigate." | 170 | be 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)." | 177 | It 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. |
| 211 | Set 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 |
| 209 | its argument, altered so as to make any changes you want made for text which | 213 | its argument, altered so as to make any changes you want made for text which |
| 210 | is a hyperlink, in addition to being in the class to which that style would | 214 | is 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 |
| 232 | which should be quoted with `hfy-html-quote' (and `hfy-html-quote-map') | 236 | which should be quoted with `hfy-html-quote' (and `hfy-html-quote-map') |
| 233 | to make them safe." | 237 | to 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. |
| 836 | Entries resulting from customization (`custom-set-faces') will take | 843 | Entries resulting from customization (`custom-set-faces') will take |
| 837 | precedence." | 844 | precedence." |
| 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'." | |||
| 1045 | and return a `hfy-style-assoc'.\n | 1052 | and return a `hfy-style-assoc'.\n |
| 1046 | See also `hfy-face-to-style-i', `hfy-flatten-style'." | 1053 | See 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'." | |||
| 1101 | and return a CSS style specification.\n | 1108 | and return a CSS style specification.\n |
| 1102 | See also `hfy-face-to-style'." | 1109 | See 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) |
| 1122 | property, 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 | ||
| 1134 | property, 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. |
| 1871 | Looks up the tags cache in `hfy-tags-cache' using SRCDIR as the key." | 1830 | CACHE-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' |
| 1886 | property, with a value of \"tag.line-number\"." | 1844 | property, 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. |
| 2243 | See also `hfy-load-tags-cache'." | 2206 | See 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))) |