Mercurial > emacs

comparison lisp/gnus/gnus-ems.el @ 31716:9968f55ad26e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Update to emacs-21-branch of the Gnus CVS repository.
author Gerd Moellmann <gerd@gnu.org>
date Tue, 19 Sep 2000 13:37:09 +0000
parents 15fc6acbae7a
children bdb5ce245f0e
comparison
equal deleted inserted replaced
31715:7c896543d225 31716:9968f55ad26e
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,96,97,98 Free Software Foundation, Inc. 2 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
3 ;; Free Software Foundation, Inc.
3 4
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5 ;; Keywords: news 6 ;; Keywords: news
6 7
7 ;; This file is part of GNU Emacs. 8 ;; This file is part of GNU Emacs.
27 28
28 (eval-when-compile (require 'cl)) 29 (eval-when-compile (require 'cl))
29 30
30 ;;; Function aliases later to be redefined for XEmacs usage. 31 ;;; Function aliases later to be redefined for XEmacs usage.
31 32
32 (defvar gnus-xemacs (string-match "XEmacs\\|Lucid" emacs-version) 33 (eval-and-compile
33 "Non-nil if running under XEmacs.") 34 (defvar gnus-xemacs (featurep 'xemacs)
35 "Non-nil if running under XEmacs."))
34 36
35 (defvar gnus-mouse-2 [mouse-2]) 37 (defvar gnus-mouse-2 [mouse-2])
38 (defvar gnus-down-mouse-3 [down-mouse-3])
36 (defvar gnus-down-mouse-2 [down-mouse-2]) 39 (defvar gnus-down-mouse-2 [down-mouse-2])
40 (defvar gnus-widget-button-keymap nil)
37 (defvar gnus-mode-line-modified 41 (defvar gnus-mode-line-modified
38 (if (or gnus-xemacs 42 (if (or gnus-xemacs
39 (< emacs-major-version 20)) 43 (< emacs-major-version 20))
40 '("--**-" . "-----") 44 '("--**-" . "-----")
41 '("**" "--"))) 45 '("**" "--")))
43 (eval-and-compile 47 (eval-and-compile
44 (autoload 'gnus-xmas-define "gnus-xmas") 48 (autoload 'gnus-xmas-define "gnus-xmas")
45 (autoload 'gnus-xmas-redefine "gnus-xmas") 49 (autoload 'gnus-xmas-redefine "gnus-xmas")
46 (autoload 'appt-select-lowest-window "appt")) 50 (autoload 'appt-select-lowest-window "appt"))
47 51
48 (or (fboundp 'mail-file-babyl-p)
49 (fset 'mail-file-babyl-p 'rmail-file-p))
50
51 ;;; Mule functions. 52 ;;; Mule functions.
52 53
53 (defun gnus-mule-cite-add-face (number prefix face)
54 ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
55 (when face
56 (let ((inhibit-point-motion-hooks t)
57 from to)
58 (goto-line number)
59 (unless (eobp) ; Sometimes things become confused (broken).
60 (if (boundp 'MULE)
61 (forward-char (chars-in-string prefix))
62 (forward-char (length prefix)))
63 (skip-chars-forward " \t")
64 (setq from (point))
65 (end-of-line 1)
66 (skip-chars-backward " \t")
67 (setq to (point))
68 (when (< from to)
69 (push (setq overlay (gnus-make-overlay from to))
70 gnus-cite-overlay-list)
71 (gnus-overlay-put (gnus-make-overlay from to) 'face face))))))
72
73 (defun gnus-mule-max-width-function (el max-width) 54 (defun gnus-mule-max-width-function (el max-width)
74 (` (let* ((val (eval (, el))) 55 `(let* ((val (eval (, el)))
75 (valstr (if (numberp val) 56 (valstr (if (numberp val)
76 (int-to-string val) val))) 57 (int-to-string val) val)))
77 (if (> (length valstr) (, max-width)) 58 (if (> (length valstr) ,max-width)
78 (truncate-string valstr (, max-width)) 59 (truncate-string-to-width valstr ,max-width)
79 valstr)))) 60 valstr)))
80 61
81 (defun gnus-encode-coding-string (string system) 62 (eval-and-compile
82 string) 63 (if gnus-xemacs
83 64 (gnus-xmas-define)
84 (defun gnus-decode-coding-string (string system)
85 string)
86
87 (defun gnus-encode-coding-string (string system)
88 string)
89
90 (eval-and-compile
91 (if (string-match "XEmacs\\|Lucid" emacs-version)
92 nil
93
94 (defvar gnus-mouse-face-prop 'mouse-face 65 (defvar gnus-mouse-face-prop 'mouse-face
95 "Property used for highlighting mouse regions.")) 66 "Property used for highlighting mouse regions.")))
96
97 (cond
98 ((string-match "XEmacs\\|Lucid" emacs-version)
99 (gnus-xmas-define))
100
101 ((or (not (boundp 'emacs-minor-version))
102 (and (< emacs-major-version 20)
103 (< emacs-minor-version 30)))
104 ;; Remove the `intangible' prop.
105 (let ((props (and (boundp 'gnus-hidden-properties)
106 gnus-hidden-properties)))
107 (while (and props (not (eq (car (cdr props)) 'intangible)))
108 (setq props (cdr props)))
109 (when props
110 (setcdr props (cdr (cdr (cdr props))))))
111 (unless (fboundp 'buffer-substring-no-properties)
112 (defun buffer-substring-no-properties (beg end)
113 (format "%s" (buffer-substring beg end)))))
114
115 ((boundp 'MULE)
116 (provide 'gnusutil))))
117 67
118 (eval-and-compile 68 (eval-and-compile
119 (cond 69 (cond
120 ((not window-system) 70 ((not window-system)
121 (defun gnus-dummy-func (&rest args))
122 (let ((funcs '(mouse-set-point set-face-foreground 71 (let ((funcs '(mouse-set-point set-face-foreground
123 set-face-background x-popup-menu))) 72 set-face-background x-popup-menu)))
124 (while funcs 73 (while funcs
125 (unless (fboundp (car funcs)) 74 (unless (fboundp (car funcs))
126 (fset (car funcs) 'gnus-dummy-func)) 75 (defalias (car funcs) 'ignore))
127 (setq funcs (cdr funcs)))))) 76 (setq funcs (cdr funcs)))))))
128 (unless (fboundp 'file-regular-p)
129 (defun file-regular-p (file)
130 (and (not (file-directory-p file))
131 (not (file-symlink-p file))
132 (file-exists-p file))))
133 (unless (fboundp 'face-list)
134 (defun face-list (&rest args))))
135 77
136 (eval-and-compile 78 (eval-and-compile
137 (let ((case-fold-search t)) 79 (let ((case-fold-search t))
138 (cond 80 (cond
139 ((string-match "windows-nt\\|os/2\\|emx\\|cygwin" 81 ((string-match "windows-nt\\|os/2\\|emx\\|cygwin32"
140 (symbol-name system-type)) 82 (symbol-name system-type))
141 (setq nnheader-file-name-translation-alist 83 (setq nnheader-file-name-translation-alist
142 (append nnheader-file-name-translation-alist 84 (append nnheader-file-name-translation-alist
143 '((?: . ?_) 85 (mapcar (lambda (c) (cons c ?_))
144 (?+ . ?-)))))))) 86 '(?: ?* ?\" ?< ?> ??))
87 '((?+ . ?-))))))))
145 88
146 (defvar gnus-tmp-unread) 89 (defvar gnus-tmp-unread)
147 (defvar gnus-tmp-replied) 90 (defvar gnus-tmp-replied)
148 (defvar gnus-tmp-score-char) 91 (defvar gnus-tmp-score-char)
149 (defvar gnus-tmp-indentation) 92 (defvar gnus-tmp-indentation)
153 (defvar gnus-tmp-closing-bracket) 96 (defvar gnus-tmp-closing-bracket)
154 (defvar gnus-tmp-subject-or-nil) 97 (defvar gnus-tmp-subject-or-nil)
155 98
156 (defun gnus-ems-redefine () 99 (defun gnus-ems-redefine ()
157 (cond 100 (cond
158 ((string-match "XEmacs\\|Lucid" emacs-version) 101 (gnus-xemacs
159 (gnus-xmas-redefine)) 102 (gnus-xmas-redefine))
160 103
161 ((featurep 'mule) 104 ((featurep 'mule)
162 ;; Mule and new Emacs definitions 105 ;; Mule and new Emacs definitions
163 106
164 ;; [Note] Now there are three kinds of mule implementations, 107 ;; [Note] Now there are three kinds of mule implementations,
165 ;; original MULE, XEmacs/mule and beta version of Emacs including 108 ;; original MULE, XEmacs/mule and Emacs 20+ including
166 ;; some mule features. Unfortunately these API are different. In 109 ;; MULE features. Unfortunately these API are different. In
167 ;; particular, Emacs (including original MULE) and XEmacs are 110 ;; particular, Emacs (including original MULE) and XEmacs are
168 ;; quite different. 111 ;; quite different. Howvere, this version of Gnus doesn't support
112 ;; anything other than XEmacs 20+ and Emacs 20.3+.
113
169 ;; Predicates to check are following: 114 ;; Predicates to check are following:
170 ;; (boundp 'MULE) is t only if MULE (original; anything older than 115 ;; (boundp 'MULE) is t only if MULE (original; anything older than
171 ;; Mule 2.3) is running. 116 ;; Mule 2.3) is running.
172 ;; (featurep 'mule) is t when every mule variants are running. 117 ;; (featurep 'mule) is t when every mule variants are running.
173 118
174 ;; These implementations may be able to share between original 119 ;; It is possible to detect XEmacs/mule by (featurep 'mule) and
175 ;; MULE and beta version of new Emacs. In addition, it is able to 120 ;; checking `emacs-version'. In this case, the implementation for
176 ;; detect XEmacs/mule by (featurep 'mule) and to check variable 121 ;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule.
177 ;; `emacs-version'. In this case, implementation for XEmacs/mule
178 ;; may be able to share between XEmacs and XEmacs/mule.
179
180 (defalias 'gnus-truncate-string 'truncate-string)
181 122
182 (defvar gnus-summary-display-table nil 123 (defvar gnus-summary-display-table nil
183 "Display table used in summary mode buffers.") 124 "Display table used in summary mode buffers.")
184 (fset 'gnus-cite-add-face 'gnus-mule-cite-add-face) 125 (defalias 'gnus-max-width-function 'gnus-mule-max-width-function)
185 (fset 'gnus-max-width-function 'gnus-mule-max-width-function)
186 (fset 'gnus-summary-set-display-table (lambda ()))
187 (fset 'gnus-encode-coding-string 'encode-coding-string)
188 (fset 'gnus-decode-coding-string 'decode-coding-string)
189 126
190 (when (boundp 'gnus-check-before-posting) 127 (when (boundp 'gnus-check-before-posting)
191 (setq gnus-check-before-posting 128 (setq gnus-check-before-posting
192 (delq 'long-lines 129 (delq 'long-lines
193 (delq 'control-chars gnus-check-before-posting)))) 130 (delq 'control-chars gnus-check-before-posting))))
201 (insert 138 (insert
202 gnus-tmp-opening-bracket 139 gnus-tmp-opening-bracket
203 (format "%4d: %-20s" 140 (format "%4d: %-20s"
204 gnus-tmp-lines 141 gnus-tmp-lines
205 (if (> (length gnus-tmp-name) 20) 142 (if (> (length gnus-tmp-name) 20)
206 (truncate-string gnus-tmp-name 20) 143 (truncate-string-to-width gnus-tmp-name 20)
207 gnus-tmp-name)) 144 gnus-tmp-name))
208 gnus-tmp-closing-bracket) 145 gnus-tmp-closing-bracket)
209 (point)) 146 (point))
210 gnus-mouse-face-prop gnus-mouse-face) 147 gnus-mouse-face-prop gnus-mouse-face)
211 (insert " " gnus-tmp-subject-or-nil "\n")) 148 (insert " " gnus-tmp-subject-or-nil "\n")))))
212
213 (when (and (boundp 'enable-multibyte-characters)
214 enable-multibyte-characters)
215 (require 'gnus-mule)
216 (gnus-mule-initialize))
217 )))
218 149
219 (defun gnus-region-active-p () 150 (defun gnus-region-active-p ()
220 "Say whether the region is active." 151 "Say whether the region is active."
221 (and (boundp 'transient-mark-mode) 152 (and (boundp 'transient-mark-mode)
222 transient-mark-mode 153 transient-mark-mode
223 (boundp 'mark-active) 154 (boundp 'mark-active)
224 mark-active)) 155 mark-active))
225 156
226 (defun gnus-add-minor-mode (mode name map) 157 (if (fboundp 'add-minor-mode)
227 (if (fboundp 'add-minor-mode) 158 (defalias 'gnus-add-minor-mode 'add-minor-mode)
228 (add-minor-mode mode name map) 159 (defun gnus-add-minor-mode (mode name map &rest rest)
229 (set (make-local-variable mode) t) 160 (set (make-local-variable mode) t)
230 (unless (assq mode minor-mode-alist) 161 (unless (assq mode minor-mode-alist)
231 (push `(,mode ,name) minor-mode-alist)) 162 (push `(,mode ,name) minor-mode-alist))
232 (unless (assq mode minor-mode-map-alist) 163 (unless (assq mode minor-mode-map-alist)
233 (push (cons mode map) 164 (push (cons mode map)
240 (save-excursion 171 (save-excursion
241 (switch-to-buffer (gnus-get-buffer-create gnus-group-buffer)) 172 (switch-to-buffer (gnus-get-buffer-create gnus-group-buffer))
242 (let ((buffer-read-only nil)) 173 (let ((buffer-read-only nil))
243 (erase-buffer) 174 (erase-buffer)
244 (when (and dir 175 (when (and dir
245 (file-exists-p (setq file (concat dir "x-splash")))) 176 (file-exists-p (setq file
246 (nnheader-temp-write nil 177 (expand-file-name "x-splash" dir))))
178 (with-temp-buffer
247 (insert-file-contents file) 179 (insert-file-contents file)
248 (goto-char (point-min)) 180 (goto-char (point-min))
249 (ignore-errors 181 (ignore-errors
250 (setq pixmap (read (current-buffer)))))) 182 (setq pixmap (read (current-buffer))))))
251 (when pixmap 183 (when pixmap
252 (erase-buffer) 184 (make-face 'gnus-splash)
253 (unless (facep 'gnus-splash)
254 (make-face 'gnus-splash))
255 (setq height (/ (car pixmap) (frame-char-height)) 185 (setq height (/ (car pixmap) (frame-char-height))
256 width (/ (cadr pixmap) (frame-char-width))) 186 width (/ (cadr pixmap) (frame-char-width)))
257 (set-face-foreground 'gnus-splash "ForestGreen") 187 (set-face-foreground 'gnus-splash "Brown")
258 (set-face-stipple 'gnus-splash pixmap) 188 (set-face-stipple 'gnus-splash pixmap)
259 (insert-char ?\n (* (/ (window-height) 2 height) height)) 189 (insert-char ?\n (* (/ (window-height) 2 height) height))
260 (setq i height) 190 (setq i height)
261 (while (> i 0) 191 (while (> i 0)
262 (insert-char ? (* (+ (/ (window-width) 2 width) 1) width)) 192 (insert-char ?\ (* (/ (window-width) 2 width) width))
263 (setq beg (point)) 193 (setq beg (point))
264 (insert-char ? width) 194 (insert-char ?\ width)
265 (set-text-properties beg (point) '(face gnus-splash)) 195 (set-text-properties beg (point) '(face gnus-splash))
266 (insert "\n") 196 (insert ?\n)
267 (decf i)) 197 (decf i))
268 (goto-char (point-min)) 198 (goto-char (point-min))
269 (sit-for 0)))))) 199 (sit-for 0))))))
270 200
271 (if (fboundp 'split-string) 201 (defvar gnus-article-xface-ring-internal nil
272 (fset 'gnus-split-string 'split-string) 202 "Cache for face data.")
273 (defun gnus-split-string (string pattern) 203
274 "Return a list of substrings of STRING which are separated by PATTERN." 204 ;; Worth customizing?
275 (let (parts (start 0)) 205 (defvar gnus-article-xface-ring-size 6
276 (while (string-match pattern string start) 206 "Length of the ring used for `gnus-article-xface-ring-internal'.")
277 (setq parts (cons (substring string start (match-beginning 0)) parts) 207
278 start (match-end 0))) 208 (defun gnus-article-display-xface (beg end)
279 (nreverse (cons (substring string start) parts))))) 209 "Display an XFace header from between BEG and END in the current article.
210 Requires support for images in your Emacs and the external programs
211 `uncompface', `icontopbm' and `ppmtoxbm'. On a GNU/Linux system these
212 might be in packages with names like `compface' or `faces-xface' and
213 `netpbm' or `libgr-progs', for instance.
214
215 This function is for Emacs 21+. See `gnus-xmas-article-display-xface'
216 for XEmacs."
217 ;; It might be worth converting uncompface's output in Lisp.
218
219 (unless gnus-article-xface-ring-internal ; Only load ring when needed.
220 (setq gnus-article-xface-ring-internal
221 (make-ring gnus-article-xface-ring-size)))
222 (save-excursion
223 (let* ((cur (current-buffer))
224 (data (buffer-substring beg end))
225 (image (cdr-safe (assoc data (ring-elements
226 gnus-article-xface-ring-internal)))))
227 (when (if (fboundp 'display-graphic-p)
228 (display-graphic-p))
229 (unless image
230 (let ((coding-system-for-read 'binary)
231 (coding-system-for-write 'binary))
232 (with-temp-buffer
233 (insert data)
234 (and (eq 0 (call-process-region (point-min) (point-max)
235 "uncompface"
236 'delete '(t nil)))
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 (eq 0 (call-process-region (point-min) (point-max)
243 "pbmtoxbm"
244 'delete '(t nil)))
245 ;; Miles Bader says that faces don't look right as
246 ;; light on dark.
247 (if (eq 'dark (cdr-safe (assq 'background-mode
248 (frame-parameters))))
249 (setq image (create-image (buffer-string) 'xbm t
250 :ascent 'center
251 :foreground "black"
252 :background "white"))
253 (setq image (create-image (buffer-string) 'xbm t
254 :ascent 'center))))))
255 (ring-insert gnus-article-xface-ring-internal (cons data image))))
256 (when image
257 (goto-char (point-min))
258 (re-search-forward "^From:" nil 'move)
259 (insert-image image)))))
280 260
281 (provide 'gnus-ems) 261 (provide 'gnus-ems)
282 262
283 ;; Local Variables: 263 ;; Local Variables:
284 ;; byte-compile-warnings: '(redefine callargs) 264 ;; byte-compile-warnings: '(redefine callargs)