1 |
;;; gnus-ems.el --- functions for making Gnus work under different Emacsen |
;;; gnus-ems.el --- functions for making Gnus work under different Emacsen |
2 |
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 |
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 |
3 |
;; Free Software Foundation, Inc. |
;; Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
45 |
(eval-and-compile |
(eval-and-compile |
46 |
(autoload 'gnus-xmas-define "gnus-xmas") |
(autoload 'gnus-xmas-define "gnus-xmas") |
47 |
(autoload 'gnus-xmas-redefine "gnus-xmas") |
(autoload 'gnus-xmas-redefine "gnus-xmas") |
48 |
(autoload 'appt-select-lowest-window "appt")) |
(autoload 'appt-select-lowest-window "appt") |
49 |
|
(autoload 'gnus-get-buffer-create "gnus") |
50 |
(if (featurep 'xemacs) |
(autoload 'nnheader-find-etc-directory "nnheader")) |
51 |
(autoload 'gnus-smiley-display "smiley") |
|
52 |
(autoload 'gnus-smiley-display "smiley-ems") ; override XEmacs version |
(autoload 'smiley-region "smiley") |
53 |
) |
;; Fixme: shouldn't require message |
54 |
|
(autoload 'message-text-with-property "message") |
55 |
|
|
56 |
(defun gnus-kill-all-overlays () |
(defun gnus-kill-all-overlays () |
57 |
"Delete all overlays in the current buffer." |
"Delete all overlays in the current buffer." |
72 |
valstr))) |
valstr))) |
73 |
|
|
74 |
(eval-and-compile |
(eval-and-compile |
75 |
|
(defalias 'gnus-char-width |
76 |
|
(if (fboundp 'char-width) |
77 |
|
'char-width |
78 |
|
(lambda (ch) 1)))) ;; A simple hack. |
79 |
|
|
80 |
|
(eval-and-compile |
81 |
(if (featurep 'xemacs) |
(if (featurep 'xemacs) |
82 |
(gnus-xmas-define) |
(gnus-xmas-define) |
83 |
(defvar gnus-mouse-face-prop 'mouse-face |
(defvar gnus-mouse-face-prop 'mouse-face |
84 |
"Property used for highlighting mouse regions."))) |
"Property used for highlighting mouse regions."))) |
85 |
|
|
86 |
(defvar gnus-tmp-unread) |
(eval-when-compile |
87 |
(defvar gnus-tmp-replied) |
(defvar gnus-tmp-unread) |
88 |
(defvar gnus-tmp-score-char) |
(defvar gnus-tmp-replied) |
89 |
(defvar gnus-tmp-indentation) |
(defvar gnus-tmp-score-char) |
90 |
(defvar gnus-tmp-opening-bracket) |
(defvar gnus-tmp-indentation) |
91 |
(defvar gnus-tmp-lines) |
(defvar gnus-tmp-opening-bracket) |
92 |
(defvar gnus-tmp-name) |
(defvar gnus-tmp-lines) |
93 |
(defvar gnus-tmp-closing-bracket) |
(defvar gnus-tmp-name) |
94 |
(defvar gnus-tmp-subject-or-nil) |
(defvar gnus-tmp-closing-bracket) |
95 |
|
(defvar gnus-tmp-subject-or-nil) |
96 |
|
(defvar gnus-check-before-posting) |
97 |
|
(defvar gnus-mouse-face) |
98 |
|
(defvar gnus-group-buffer)) |
99 |
|
|
100 |
(defun gnus-ems-redefine () |
(defun gnus-ems-redefine () |
101 |
(cond |
(cond |
107 |
|
|
108 |
;; [Note] Now there are three kinds of mule implementations, |
;; [Note] Now there are three kinds of mule implementations, |
109 |
;; original MULE, XEmacs/mule and Emacs 20+ including |
;; original MULE, XEmacs/mule and Emacs 20+ including |
110 |
;; MULE features. Unfortunately these API are different. In |
;; MULE features. Unfortunately these APIs are different. In |
111 |
;; particular, Emacs (including original MULE) and XEmacs are |
;; particular, Emacs (including original Mule) and XEmacs are |
112 |
;; quite different. However, this version of Gnus doesn't support |
;; quite different. However, this version of Gnus doesn't support |
113 |
;; anything other than XEmacs 20+ and Emacs 20.3+. |
;; anything other than XEmacs 20+ and Emacs 20.3+. |
114 |
|
|
115 |
;; Predicates to check are following: |
;; Predicates to check are following: |
116 |
;; (boundp 'MULE) is t only if MULE (original; anything older than |
;; (boundp 'MULE) is t only if Mule (original; anything older than |
117 |
;; Mule 2.3) is running. |
;; Mule 2.3) is running. |
118 |
;; (featurep 'mule) is t when every mule variants are running. |
;; (featurep 'mule) is t when other mule variants are running. |
119 |
|
|
120 |
;; It is possible to detect XEmacs/mule by (featurep 'mule) and |
;; It is possible to detect XEmacs/mule by (featurep 'mule) and |
121 |
;; checking `emacs-version'. In this case, the implementation for |
;; (featurep 'xemacs). In this case, the implementation for |
122 |
;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule. |
;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule. |
123 |
|
|
124 |
(defvar gnus-summary-display-table nil |
(defvar gnus-summary-display-table nil |
155 |
(boundp 'mark-active) |
(boundp 'mark-active) |
156 |
mark-active)) |
mark-active)) |
157 |
|
|
158 |
|
(defun gnus-mark-active-p () |
159 |
|
"Non-nil means the mark and region are currently active in this buffer." |
160 |
|
mark-active) ; aliased to region-exists-p in XEmacs. |
161 |
|
|
162 |
(if (fboundp 'add-minor-mode) |
(if (fboundp 'add-minor-mode) |
163 |
(defalias 'gnus-add-minor-mode 'add-minor-mode) |
(defalias 'gnus-add-minor-mode 'add-minor-mode) |
164 |
(defun gnus-add-minor-mode (mode name map &rest rest) |
(defun gnus-add-minor-mode (mode name map &rest rest) |
181 |
(when (and dir |
(when (and dir |
182 |
(file-exists-p (setq file |
(file-exists-p (setq file |
183 |
(expand-file-name "x-splash" dir)))) |
(expand-file-name "x-splash" dir)))) |
184 |
(with-temp-buffer |
(let ((coding-system-for-read 'raw-text) |
185 |
(insert-file-contents file) |
default-enable-multibyte-characters) |
186 |
(goto-char (point-min)) |
(with-temp-buffer |
187 |
(ignore-errors |
(insert-file-contents file) |
188 |
(setq pixmap (read (current-buffer)))))) |
(goto-char (point-min)) |
189 |
|
(ignore-errors |
190 |
|
(setq pixmap (read (current-buffer))))))) |
191 |
(when pixmap |
(when pixmap |
192 |
(make-face 'gnus-splash) |
(make-face 'gnus-splash) |
193 |
(setq height (/ (car pixmap) (frame-char-height)) |
(setq height (/ (car pixmap) (frame-char-height)) |
206 |
(goto-char (point-min)) |
(goto-char (point-min)) |
207 |
(sit-for 0)))))) |
(sit-for 0)))))) |
208 |
|
|
209 |
(defvar gnus-article-xface-ring-internal nil |
;;; Image functions. |
|
"Cache for face data.") |
|
210 |
|
|
211 |
;; Worth customizing? |
(defun gnus-image-type-available-p (type) |
212 |
(defvar gnus-article-xface-ring-size 6 |
(and (fboundp 'image-type-available-p) |
213 |
"Length of the ring used for `gnus-article-xface-ring-internal'.") |
(image-type-available-p type))) |
214 |
|
|
215 |
(defvar gnus-article-compface-xbm |
(defun gnus-create-image (file &optional type data-p &rest props) |
216 |
(eq 0 (string-match "#define" (shell-command-to-string "uncompface -X"))) |
(let ((face (plist-get props :face))) |
217 |
"Non-nil means the compface program supports the -X option. |
(when face |
218 |
That produces XBM output.") |
(setq props (plist-put props :foreground (face-foreground face))) |
219 |
|
(setq props (plist-put props :background (face-background face)))) |
220 |
(defun gnus-article-display-xface (beg end) |
(apply 'create-image file type data-p props))) |
221 |
"Display an XFace header from between BEG and END in the current article. |
|
222 |
Requires support for images in your Emacs and the external programs |
(defun gnus-put-image (glyph &optional string category) |
223 |
`uncompface', and `icontopbm'. On a GNU/Linux system these |
(let ((point (point))) |
224 |
might be in packages with names like `compface' or `faces-xface' and |
(insert-image glyph (or string " ")) |
225 |
`netpbm' or `libgr-progs', for instance. See also |
(put-text-property point (point) 'gnus-image-category category) |
226 |
`gnus-article-compface-xbm'. |
(unless string |
227 |
|
(put-text-property (1- (point)) (point) |
228 |
This function is for Emacs 21+. See `gnus-xmas-article-display-xface' |
'gnus-image-text-deletable t)) |
229 |
for XEmacs." |
glyph)) |
230 |
;; It might be worth converting uncompface's output in Lisp. |
|
231 |
|
(defun gnus-remove-image (image &optional category) |
232 |
(when (if (fboundp 'display-graphic-p) |
(dolist (position (message-text-with-property 'display)) |
233 |
(display-graphic-p)) |
(when (and (equal (get-text-property position 'display) image) |
234 |
(unless gnus-article-xface-ring-internal ; Only load ring when needed. |
(equal (get-text-property position 'gnus-image-category) |
235 |
(setq gnus-article-xface-ring-internal |
category)) |
236 |
(make-ring gnus-article-xface-ring-size))) |
(put-text-property position (1+ position) 'display nil) |
237 |
(save-excursion |
(when (get-text-property position 'gnus-image-text-deletable) |
238 |
(let* ((cur (current-buffer)) |
(delete-region position (1+ position)))))) |
|
(data (buffer-substring beg end)) |
|
|
(image (cdr-safe (assoc data (ring-elements |
|
|
gnus-article-xface-ring-internal)))) |
|
|
default-enable-multibyte-characters) |
|
|
(unless image |
|
|
(with-temp-buffer |
|
|
(insert data) |
|
|
(and (eq 0 (apply #'call-process-region (point-min) (point-max) |
|
|
"uncompface" |
|
|
'delete '(t nil) nil |
|
|
(if gnus-article-compface-xbm |
|
|
'("-X")))) |
|
|
(if gnus-article-compface-xbm |
|
|
t |
|
|
(goto-char (point-min)) |
|
|
(progn (insert "/* Width=48, Height=48 */\n") t) |
|
|
(eq 0 (call-process-region (point-min) (point-max) |
|
|
"icontopbm" |
|
|
'delete '(t nil)))) |
|
|
;; Miles Bader says that faces don't look right as |
|
|
;; light on dark. |
|
|
(if (eq 'dark (cdr-safe (assq 'background-mode |
|
|
(frame-parameters)))) |
|
|
(setq image (create-image (buffer-string) |
|
|
(if gnus-article-compface-xbm |
|
|
'xbm |
|
|
'pbm) |
|
|
t |
|
|
:ascent 'center |
|
|
:foreground "black" |
|
|
:background "white")) |
|
|
(setq image (create-image (buffer-string) |
|
|
(if gnus-article-compface-xbm |
|
|
'xbm |
|
|
'pbm) |
|
|
t |
|
|
:ascent 'center))))) |
|
|
(ring-insert gnus-article-xface-ring-internal (cons data image))) |
|
|
(when image |
|
|
(goto-char (point-min)) |
|
|
(re-search-forward "^From:" nil 'move) |
|
|
(while (get-text-property (point) 'display) |
|
|
(goto-char (next-single-property-change (point) 'display))) |
|
|
(insert-image image)))))) |
|
239 |
|
|
240 |
(provide 'gnus-ems) |
(provide 'gnus-ems) |
241 |
|
|