Mercurial > emacs
comparison lisp/gnus/gnus-ems.el @ 88155:d7ddb3e565de
sync with trunk
author | Henrik Enberg <henrik.enberg@telia.com> |
---|---|
date | Mon, 16 Jan 2006 00:03:54 +0000 |
parents | 963ff40e6512 |
children |
comparison
equal
deleted
inserted
replaced
88154:8ce476d3ba36 | 88155:d7ddb3e565de |
---|---|
1 ;;; gnus-ems.el --- functions for making Gnus work under different Emacsen | 1 ;;; gnus-ems.el --- functions for making Gnus work under different Emacsen |
2 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 | 2 |
3 ;; Free Software Foundation, Inc. | 3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, |
4 ;; 2004, 2005 Free Software Foundation, Inc. | |
4 | 5 |
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> | 6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
6 ;; Keywords: news | 7 ;; Keywords: news |
7 | 8 |
8 ;; This file is part of GNU Emacs. | 9 ;; This file is part of GNU Emacs. |
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
18 ;; GNU General Public License for more details. | 19 ;; GNU General Public License for more details. |
19 | 20 |
20 ;; You should have received a copy of the GNU General Public License | 21 ;; You should have received a copy of the GNU General Public License |
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the | 22 ;; along with GNU Emacs; see the file COPYING. If not, write to the |
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | 23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
23 ;; Boston, MA 02111-1307, USA. | 24 ;; Boston, MA 02110-1301, USA. |
24 | 25 |
25 ;;; Commentary: | 26 ;;; Commentary: |
26 | 27 |
27 ;;; Code: | 28 ;;; Code: |
28 | 29 |
43 '("**" "--"))) | 44 '("**" "--"))) |
44 | 45 |
45 (eval-and-compile | 46 (eval-and-compile |
46 (autoload 'gnus-xmas-define "gnus-xmas") | 47 (autoload 'gnus-xmas-define "gnus-xmas") |
47 (autoload 'gnus-xmas-redefine "gnus-xmas") | 48 (autoload 'gnus-xmas-redefine "gnus-xmas") |
48 (autoload 'appt-select-lowest-window "appt")) | 49 (autoload 'appt-select-lowest-window "appt") |
49 | 50 (autoload 'gnus-get-buffer-create "gnus") |
50 (if (featurep 'xemacs) | 51 (autoload 'nnheader-find-etc-directory "nnheader")) |
51 (autoload 'gnus-smiley-display "smiley") | 52 |
52 (autoload 'gnus-smiley-display "smiley-ems") ; override XEmacs version | 53 (autoload 'smiley-region "smiley") |
53 ) | 54 ;; Fixme: shouldn't require message |
55 (autoload 'message-text-with-property "message") | |
54 | 56 |
55 (defun gnus-kill-all-overlays () | 57 (defun gnus-kill-all-overlays () |
56 "Delete all overlays in the current buffer." | 58 "Delete all overlays in the current buffer." |
57 (let* ((overlayss (overlay-lists)) | 59 (let* ((overlayss (overlay-lists)) |
58 (buffer-read-only nil) | 60 (buffer-read-only nil) |
69 (if (> (length valstr) ,max-width) | 71 (if (> (length valstr) ,max-width) |
70 (truncate-string-to-width valstr ,max-width) | 72 (truncate-string-to-width valstr ,max-width) |
71 valstr))) | 73 valstr))) |
72 | 74 |
73 (eval-and-compile | 75 (eval-and-compile |
76 (defalias 'gnus-char-width | |
77 (if (fboundp 'char-width) | |
78 'char-width | |
79 (lambda (ch) 1)))) ;; A simple hack. | |
80 | |
81 (eval-and-compile | |
74 (if (featurep 'xemacs) | 82 (if (featurep 'xemacs) |
75 (gnus-xmas-define) | 83 (gnus-xmas-define) |
76 (defvar gnus-mouse-face-prop 'mouse-face | 84 (defvar gnus-mouse-face-prop 'mouse-face |
77 "Property used for highlighting mouse regions."))) | 85 "Property used for highlighting mouse regions."))) |
78 | 86 |
79 (defvar gnus-tmp-unread) | 87 (eval-when-compile |
80 (defvar gnus-tmp-replied) | 88 (defvar gnus-tmp-unread) |
81 (defvar gnus-tmp-score-char) | 89 (defvar gnus-tmp-replied) |
82 (defvar gnus-tmp-indentation) | 90 (defvar gnus-tmp-score-char) |
83 (defvar gnus-tmp-opening-bracket) | 91 (defvar gnus-tmp-indentation) |
84 (defvar gnus-tmp-lines) | 92 (defvar gnus-tmp-opening-bracket) |
85 (defvar gnus-tmp-name) | 93 (defvar gnus-tmp-lines) |
86 (defvar gnus-tmp-closing-bracket) | 94 (defvar gnus-tmp-name) |
87 (defvar gnus-tmp-subject-or-nil) | 95 (defvar gnus-tmp-closing-bracket) |
96 (defvar gnus-tmp-subject-or-nil) | |
97 (defvar gnus-check-before-posting) | |
98 (defvar gnus-mouse-face) | |
99 (defvar gnus-group-buffer)) | |
88 | 100 |
89 (defun gnus-ems-redefine () | 101 (defun gnus-ems-redefine () |
90 (cond | 102 (cond |
91 ((featurep 'xemacs) | 103 ((featurep 'xemacs) |
92 (gnus-xmas-redefine)) | 104 (gnus-xmas-redefine)) |
94 ((featurep 'mule) | 106 ((featurep 'mule) |
95 ;; Mule and new Emacs definitions | 107 ;; Mule and new Emacs definitions |
96 | 108 |
97 ;; [Note] Now there are three kinds of mule implementations, | 109 ;; [Note] Now there are three kinds of mule implementations, |
98 ;; original MULE, XEmacs/mule and Emacs 20+ including | 110 ;; original MULE, XEmacs/mule and Emacs 20+ including |
99 ;; MULE features. Unfortunately these API are different. In | 111 ;; MULE features. Unfortunately these APIs are different. In |
100 ;; particular, Emacs (including original MULE) and XEmacs are | 112 ;; particular, Emacs (including original Mule) and XEmacs are |
101 ;; quite different. However, this version of Gnus doesn't support | 113 ;; quite different. However, this version of Gnus doesn't support |
102 ;; anything other than XEmacs 20+ and Emacs 20.3+. | 114 ;; anything other than XEmacs 20+ and Emacs 20.3+. |
103 | 115 |
104 ;; Predicates to check are following: | 116 ;; Predicates to check are following: |
105 ;; (boundp 'MULE) is t only if MULE (original; anything older than | 117 ;; (boundp 'MULE) is t only if Mule (original; anything older than |
106 ;; Mule 2.3) is running. | 118 ;; Mule 2.3) is running. |
107 ;; (featurep 'mule) is t when every mule variants are running. | 119 ;; (featurep 'mule) is t when other mule variants are running. |
108 | 120 |
109 ;; It is possible to detect XEmacs/mule by (featurep 'mule) and | 121 ;; It is possible to detect XEmacs/mule by (featurep 'mule) and |
110 ;; checking `emacs-version'. In this case, the implementation for | 122 ;; (featurep 'xemacs). In this case, the implementation for |
111 ;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule. | 123 ;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule. |
112 | 124 |
113 (defvar gnus-summary-display-table nil | 125 (defvar gnus-summary-display-table nil |
114 "Display table used in summary mode buffers.") | 126 "Display table used in summary mode buffers.") |
115 (defalias 'gnus-max-width-function 'gnus-mule-max-width-function) | 127 (defalias 'gnus-max-width-function 'gnus-mule-max-width-function) |
142 (and (boundp 'transient-mark-mode) | 154 (and (boundp 'transient-mark-mode) |
143 transient-mark-mode | 155 transient-mark-mode |
144 (boundp 'mark-active) | 156 (boundp 'mark-active) |
145 mark-active)) | 157 mark-active)) |
146 | 158 |
159 (defun gnus-mark-active-p () | |
160 "Non-nil means the mark and region are currently active in this buffer." | |
161 mark-active) ; aliased to region-exists-p in XEmacs. | |
162 | |
147 (if (fboundp 'add-minor-mode) | 163 (if (fboundp 'add-minor-mode) |
148 (defalias 'gnus-add-minor-mode 'add-minor-mode) | 164 (defalias 'gnus-add-minor-mode 'add-minor-mode) |
149 (defun gnus-add-minor-mode (mode name map &rest rest) | 165 (defun gnus-add-minor-mode (mode name map &rest rest) |
150 (set (make-local-variable mode) t) | 166 (set (make-local-variable mode) t) |
151 (unless (assq mode minor-mode-alist) | 167 (unless (assq mode minor-mode-alist) |
164 width height) | 180 width height) |
165 (erase-buffer) | 181 (erase-buffer) |
166 (when (and dir | 182 (when (and dir |
167 (file-exists-p (setq file | 183 (file-exists-p (setq file |
168 (expand-file-name "x-splash" dir)))) | 184 (expand-file-name "x-splash" dir)))) |
169 (with-temp-buffer | 185 (let ((coding-system-for-read 'raw-text) |
170 (insert-file-contents file) | 186 default-enable-multibyte-characters) |
171 (goto-char (point-min)) | 187 (with-temp-buffer |
172 (ignore-errors | 188 (insert-file-contents file) |
173 (setq pixmap (read (current-buffer)))))) | 189 (goto-char (point-min)) |
190 (ignore-errors | |
191 (setq pixmap (read (current-buffer))))))) | |
174 (when pixmap | 192 (when pixmap |
175 (make-face 'gnus-splash) | 193 (make-face 'gnus-splash) |
176 (setq height (/ (car pixmap) (frame-char-height)) | 194 (setq height (/ (car pixmap) (frame-char-height)) |
177 width (/ (cadr pixmap) (frame-char-width))) | 195 width (/ (cadr pixmap) (frame-char-width))) |
178 (set-face-foreground 'gnus-splash "Brown") | 196 (set-face-foreground 'gnus-splash "Brown") |
187 (insert ?\n) | 205 (insert ?\n) |
188 (decf i)) | 206 (decf i)) |
189 (goto-char (point-min)) | 207 (goto-char (point-min)) |
190 (sit-for 0)))))) | 208 (sit-for 0)))))) |
191 | 209 |
192 (defvar gnus-article-xface-ring-internal nil | 210 ;;; Image functions. |
193 "Cache for face data.") | 211 |
194 | 212 (defun gnus-image-type-available-p (type) |
195 ;; Worth customizing? | 213 (and (fboundp 'image-type-available-p) |
196 (defvar gnus-article-xface-ring-size 6 | 214 (image-type-available-p type))) |
197 "Length of the ring used for `gnus-article-xface-ring-internal'.") | 215 |
198 | 216 (defun gnus-create-image (file &optional type data-p &rest props) |
199 (defvar gnus-article-compface-xbm | 217 (let ((face (plist-get props :face))) |
200 (eq 0 (string-match "#define" (shell-command-to-string "uncompface -X"))) | 218 (when face |
201 "Non-nil means the compface program supports the -X option. | 219 (setq props (plist-put props :foreground (face-foreground face))) |
202 That produces XBM output.") | 220 (setq props (plist-put props :background (face-background face)))) |
203 | 221 (apply 'create-image file type data-p props))) |
204 (defun gnus-article-display-xface (beg end) | 222 |
205 "Display an XFace header from between BEG and END in the current article. | 223 (defun gnus-put-image (glyph &optional string category) |
206 Requires support for images in your Emacs and the external programs | 224 (let ((point (point))) |
207 `uncompface', and `icontopbm'. On a GNU/Linux system these | 225 (insert-image glyph (or string " ")) |
208 might be in packages with names like `compface' or `faces-xface' and | 226 (put-text-property point (point) 'gnus-image-category category) |
209 `netpbm' or `libgr-progs', for instance. See also | 227 (unless string |
210 `gnus-article-compface-xbm'. | 228 (put-text-property (1- (point)) (point) |
211 | 229 'gnus-image-text-deletable t)) |
212 This function is for Emacs 21+. See `gnus-xmas-article-display-xface' | 230 glyph)) |
213 for XEmacs." | 231 |
214 ;; It might be worth converting uncompface's output in Lisp. | 232 (defun gnus-remove-image (image &optional category) |
215 | 233 (dolist (position (message-text-with-property 'display)) |
216 (when (if (fboundp 'display-graphic-p) | 234 (when (and (equal (get-text-property position 'display) image) |
217 (display-graphic-p)) | 235 (equal (get-text-property position 'gnus-image-category) |
218 (unless gnus-article-xface-ring-internal ; Only load ring when needed. | 236 category)) |
219 (setq gnus-article-xface-ring-internal | 237 (put-text-property position (1+ position) 'display nil) |
220 (make-ring gnus-article-xface-ring-size))) | 238 (when (get-text-property position 'gnus-image-text-deletable) |
221 (save-excursion | 239 (delete-region position (1+ position)))))) |
222 (let* ((cur (current-buffer)) | |
223 (data (buffer-substring beg end)) | |
224 (image (cdr-safe (assoc data (ring-elements | |
225 gnus-article-xface-ring-internal)))) | |
226 default-enable-multibyte-characters) | |
227 (unless image | |
228 (with-temp-buffer | |
229 (insert data) | |
230 (and (eq 0 (apply #'call-process-region (point-min) (point-max) | |
231 "uncompface" | |
232 'delete '(t nil) nil | |
233 (if gnus-article-compface-xbm | |
234 '("-X")))) | |
235 (if gnus-article-compface-xbm | |
236 t | |
237 (goto-char (point-min)) | |
238 (progn (insert "/* Width=48, Height=48 */\n") t) | |
239 (eq 0 (call-process-region (point-min) (point-max) | |
240 "icontopbm" | |
241 'delete '(t nil)))) | |
242 ;; Miles Bader says that faces don't look right as | |
243 ;; light on dark. | |
244 (if (eq 'dark (cdr-safe (assq 'background-mode | |
245 (frame-parameters)))) | |
246 (setq image (create-image (buffer-string) | |
247 (if gnus-article-compface-xbm | |
248 'xbm | |
249 'pbm) | |
250 t | |
251 :ascent 'center | |
252 :foreground "black" | |
253 :background "white")) | |
254 (setq image (create-image (buffer-string) | |
255 (if gnus-article-compface-xbm | |
256 'xbm | |
257 'pbm) | |
258 t | |
259 :ascent 'center))))) | |
260 (ring-insert gnus-article-xface-ring-internal (cons data image))) | |
261 (when image | |
262 (goto-char (point-min)) | |
263 (re-search-forward "^From:" nil 'move) | |
264 (while (get-text-property (point) 'display) | |
265 (goto-char (next-single-property-change (point) 'display))) | |
266 (insert-image image)))))) | |
267 | 240 |
268 (provide 'gnus-ems) | 241 (provide 'gnus-ems) |
269 | 242 |
243 ;;; arch-tag: e7360b45-14b5-4171-aa39-69a44aed3cdb | |
270 ;;; gnus-ems.el ends here | 244 ;;; gnus-ems.el ends here |