Mercurial > emacs

comparison lisp/gnus-ems.el @ 13401:178d730efae2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
entered into RCS
author Lars Magne Ingebrigtsen <larsi@gnus.org>
date Sat, 04 Nov 1995 03:54:42 +0000
parents
children 187735b53d52
comparison
equal deleted inserted replaced
13400:4a57cda2a39a 13401:178d730efae2
1 ;;; gnus-ems.el --- functions for making Gnus work under different Emacsen
2 ;; Copyright (C) 1995 Free Software Foundation, Inc.
3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
5 ;; Keywords: news
6
7 ;; This file is part of GNU Emacs.
8
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
12 ;; any later version.
13
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
18
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING. If not, write to
21 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
22
23 ;;; Commentary:
24
25 ;;; Code:
26
27 (defvar gnus-mouse-2 [mouse-2])
28 (defvar gnus-group-mode-hook ())
29 (defvar gnus-summary-mode-hook ())
30 (defvar gnus-article-mode-hook ())
31
32 (defalias 'gnus-make-overlay 'make-overlay)
33 (defalias 'gnus-overlay-put 'overlay-put)
34 (defalias 'gnus-move-overlay 'move-overlay)
35
36 (or (fboundp 'mail-file-babyl-p)
37 (fset 'mail-file-babyl-p 'rmail-file-p))
38
39 ;; Don't warn about these undefined variables.
40 ;defined in gnus.el
41 (defvar gnus-active-hashtb)
42 (defvar gnus-article-buffer)
43 (defvar gnus-auto-center-summary)
44 (defvar gnus-buffer-list)
45 (defvar gnus-current-headers)
46 (defvar gnus-level-killed)
47 (defvar gnus-level-zombie)
48 (defvar gnus-newsgroup-bookmarks)
49 (defvar gnus-newsgroup-dependencies)
50 (defvar gnus-newsgroup-headers-hashtb-by-number)
51 (defvar gnus-newsgroup-selected-overlay)
52 (defvar gnus-newsrc-hashtb)
53 (defvar gnus-read-mark)
54 (defvar gnus-refer-article-method)
55 (defvar gnus-reffed-article-number)
56 (defvar gnus-unread-mark)
57 (defvar gnus-version)
58 (defvar gnus-view-pseudos)
59 (defvar gnus-view-pseudos-separately)
60 (defvar gnus-visual)
61 (defvar gnus-zombie-list)
62 ;defined in gnus-msg.el
63 (defvar gnus-article-copy)
64 (defvar gnus-check-before-posting)
65 ;defined in gnus-vis.el
66 (defvar gnus-article-button-face)
67 (defvar gnus-article-mouse-face)
68 (defvar gnus-summary-selected-face)
69
70
71 ;; We do not byte-compile this file, because error messages are such a
72 ;; bore.
73
74 (defun gnus-set-text-properties-xemacs (start end props &optional buffer)
75 "You should NEVER use this function. It is ideologically blasphemous.
76 It is provided only to ease porting of broken FSF Emacs programs."
77 (if (and (stringp buffer) (not (setq buffer (get-buffer buffer))))
78 nil
79 (map-extents (lambda (extent ignored)
80 (remove-text-properties
81 start end
82 (list (extent-property extent 'text-prop) nil)
83 buffer))
84 buffer start end nil nil 'text-prop)
85 (add-text-properties start end props buffer)))
86
87 (eval
88 '(progn
89 (if (string-match "XEmacs\\|Lucid" emacs-version)
90 ()
91 ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
92 (defvar gnus-display-type
93 (condition-case nil
94 (let ((display-resource (x-get-resource ".displayType" "DisplayType")))
95 (cond (display-resource (intern (downcase display-resource)))
96 ((x-display-color-p) 'color)
97 ((x-display-grayscale-p) 'grayscale)
98 (t 'mono)))
99 (error 'mono))
100 "A symbol indicating the display Emacs is running under.
101 The symbol should be one of `color', `grayscale' or `mono'. If Emacs
102 guesses this display attribute wrongly, either set this variable in
103 your `~/.emacs' or set the resource `Emacs.displayType' in your
104 `~/.Xdefaults'. See also `gnus-background-mode'.
105
106 This is a meta-variable that will affect what default values other
107 variables get. You would normally not change this variable, but
108 pounce directly on the real variables themselves.")
109
110 (defvar gnus-background-mode
111 (condition-case nil
112 (let ((bg-resource (x-get-resource ".backgroundMode"
113 "BackgroundMode"))
114 (params (frame-parameters)))
115 (cond (bg-resource (intern (downcase bg-resource)))
116 ((and (cdr (assq 'background-color params))
117 (< (apply '+ (x-color-values
118 (cdr (assq 'background-color params))))
119 (/ (apply '+ (x-color-values "white")) 3)))
120 'dark)
121 (t 'light)))
122 (error 'light))
123 "A symbol indicating the Emacs background brightness.
124 The symbol should be one of `light' or `dark'.
125 If Emacs guesses this frame attribute wrongly, either set this variable in
126 your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
127 `~/.Xdefaults'.
128 See also `gnus-display-type'.
129
130 This is a meta-variable that will affect what default values other
131 variables get. You would normally not change this variable, but
132 pounce directly on the real variables themselves."))
133
134 (cond
135 ((string-match "XEmacs\\|Lucid" emacs-version)
136 ;; XEmacs definitions.
137
138 (setq gnus-mouse-2 [button2])
139
140 (or (memq 'underline (list-faces))
141 (and (fboundp 'make-face)
142 (funcall (intern "make-face") 'underline)))
143 ;; Must avoid calling set-face-underline-p directly, because it
144 ;; is a defsubst in emacs19, and will make the .elc files non
145 ;; portable!
146 (or (face-differs-from-default-p 'underline)
147 (funcall 'set-face-underline-p 'underline t))
148
149 (defalias 'gnus-make-overlay 'make-extent)
150 (defalias 'gnus-overlay-put 'set-extent-property)
151 (defun gnus-move-overlay (extent start end &optional buffer)
152 (set-extent-endpoints extent start end))
153
154 (require 'text-props)
155 (fset 'set-text-properties 'gnus-set-text-properties-xemacs)
156
157 (or (boundp 'standard-display-table) (setq standard-display-table nil))
158 (or (boundp 'read-event) (fset 'read-event 'next-command-event))
159
160 ;; Fix by "jeff (j.d.) sparkes" <jsparkes@bnr.ca>.
161 (defvar gnus-display-type (device-class)
162 "A symbol indicating the display Emacs is running under.
163 The symbol should be one of `color', `grayscale' or `mono'. If Emacs
164 guesses this display attribute wrongly, either set this variable in
165 your `~/.emacs' or set the resource `Emacs.displayType' in your
166 `~/.Xdefaults'. See also `gnus-background-mode'.
167
168 This is a meta-variable that will affect what default values other
169 variables get. You would normally not change this variable, but
170 pounce directly on the real variables themselves.")
171
172
173 (or (fboundp 'x-color-values)
174 (fset 'x-color-values
175 (lambda (color)
176 (color-instance-rgb-components
177 (make-color-instance color)))))
178
179 (defvar gnus-background-mode
180 (let ((bg-resource
181 (condition-case ()
182 (x-get-resource ".backgroundMode" "BackgroundMode" 'string)
183 (error nil)))
184 (params (frame-parameters)))
185 (cond (bg-resource (intern (downcase bg-resource)))
186 ((and (assq 'background-color params)
187 (< (apply '+ (x-color-values
188 (cdr (assq 'background-color params))))
189 (/ (apply '+ (x-color-values "white")) 3)))
190 'dark)
191 (t 'light)))
192 "A symbol indicating the Emacs background brightness.
193 The symbol should be one of `light' or `dark'.
194 If Emacs guesses this frame attribute wrongly, either set this variable in
195 your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
196 `~/.Xdefaults'.
197 See also `gnus-display-type'.
198
199 This is a meta-variable that will affect what default values other
200 variables get. You would normally not change this variable, but
201 pounce directly on the real variables themselves.")
202
203
204 (defun gnus-install-mouse-tracker ()
205 (require 'mode-motion)
206 (setq mode-motion-hook 'mode-motion-highlight-line)))
207
208 ((and (not (string-match "28.9" emacs-version))
209 (not (string-match "29" emacs-version)))
210 ;; Remove the `intangible' prop.
211 (let ((props (and (boundp 'gnus-hidden-properties)
212 gnus-hidden-properties)))
213 (while (and props (not (eq (car (cdr props)) 'intangible)))
214 (setq props (cdr props)))
215 (and props (setcdr props (cdr (cdr (cdr props))))))
216 (or (fboundp 'buffer-substring-no-properties)
217 (defun buffer-substring-no-properties (beg end)
218 (format "%s" (buffer-substring beg end)))))
219
220 ((boundp 'MULE)
221 (provide 'gnusutil))
222
223 )))
224
225 (eval-and-compile
226 (cond
227 ((not window-system)
228 (defun gnus-dummy-func (&rest args))
229 (let ((funcs '(mouse-set-point set-face-foreground
230 set-face-background x-popup-menu)))
231 (while funcs
232 (or (fboundp (car funcs))
233 (fset (car funcs) 'gnus-dummy-func))
234 (setq funcs (cdr funcs))))))
235 (or (fboundp 'file-regular-p)
236 (defun file-regular-p (file)
237 (and (not (file-directory-p file))
238 (not (file-symlink-p file))
239 (file-exists-p file))))
240 (or (fboundp 'face-list)
241 (defun face-list (&rest args)))
242 )
243
244 (defun gnus-highlight-selected-summary-xemacs ()
245 ;; Highlight selected article in summary buffer
246 (if gnus-summary-selected-face
247 (progn
248 (if gnus-newsgroup-selected-overlay
249 (delete-extent gnus-newsgroup-selected-overlay))
250 (setq gnus-newsgroup-selected-overlay
251 (make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
252 (set-extent-face gnus-newsgroup-selected-overlay
253 gnus-summary-selected-face))))
254
255 (defun gnus-summary-recenter-xemacs ()
256 (let* ((top (cond ((< (window-height) 4) 0)
257 ((< (window-height) 7) 1)
258 (t 2)))
259 (height (- (window-height) 2))
260 (bottom (save-excursion (goto-char (point-max))
261 (forward-line (- height))
262 (point)))
263 (window (get-buffer-window (current-buffer))))
264 (and
265 ;; The user has to want it,
266 gnus-auto-center-summary
267 ;; the article buffer must be displayed,
268 (get-buffer-window gnus-article-buffer)
269 ;; Set the window start to either `bottom', which is the biggest
270 ;; possible valid number, or the second line from the top,
271 ;; whichever is the least.
272 (set-window-start
273 window (min bottom (save-excursion (forward-line (- top))
274 (point)))))))
275
276 (defun gnus-group-insert-group-line-info-xemacs (group)
277 (let ((entry (gnus-gethash group gnus-newsrc-hashtb))
278 (beg (point))
279 active info)
280 (if entry
281 (progn
282 (setq info (nth 2 entry))
283 (gnus-group-insert-group-line
284 nil group (nth 1 info) (nth 3 info) (car entry) (nth 4 info)))
285 (setq active (gnus-gethash group gnus-active-hashtb))
286
287 (gnus-group-insert-group-line
288 nil group (if (member group gnus-zombie-list) gnus-level-zombie
289 gnus-level-killed)
290 nil (if active (- (1+ (cdr active)) (car active)) 0) nil))
291 (save-excursion
292 (goto-char beg)
293 (remove-text-properties
294 (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
295 '(gnus-group nil)))))
296
297 (defun gnus-summary-refer-article-xemacs (message-id)
298 "Refer article specified by MESSAGE-ID.
299 NOTE: This command only works with newsgroups that use real or simulated NNTP."
300 (interactive "sMessage-ID: ")
301 (if (or (not (stringp message-id))
302 (zerop (length message-id)))
303 ()
304 ;; Construct the correct Message-ID if necessary.
305 ;; Suggested by tale@pawl.rpi.edu.
306 (or (string-match "^<" message-id)
307 (setq message-id (concat "<" message-id)))
308 (or (string-match ">$" message-id)
309 (setq message-id (concat message-id ">")))
310 (let ((header (car (gnus-gethash (downcase message-id)
311 gnus-newsgroup-dependencies))))
312 (if header
313 (or (gnus-summary-goto-article (mail-header-number header))
314 ;; The header has been read, but the article had been
315 ;; expunged, so we insert it again.
316 (let ((beg (point)))
317 (gnus-summary-insert-line
318 nil header 0 nil gnus-read-mark nil nil
319 (mail-header-subject header))
320 (save-excursion
321 (goto-char beg)
322 (remove-text-properties
323 (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
324 '(gnus-number nil gnus-mark nil gnus-level nil)))
325 (forward-line -1)
326 (mail-header-number header)))
327 (let ((gnus-override-method gnus-refer-article-method)
328 (gnus-ancient-mark gnus-read-mark)
329 (tmp-point (window-start
330 (get-buffer-window gnus-article-buffer)))
331 number tmp-buf)
332 (and gnus-refer-article-method
333 (gnus-check-server gnus-refer-article-method))
334 ;; Save the old article buffer.
335 (save-excursion
336 (set-buffer gnus-article-buffer)
337 (gnus-kill-buffer " *temp Article*")
338 (setq tmp-buf (rename-buffer " *temp Article*")))
339 (prog1
340 (if (gnus-article-prepare
341 message-id nil (gnus-read-header message-id))
342 (progn
343 (setq number (mail-header-number gnus-current-headers))
344 (gnus-rebuild-thread message-id)
345 (gnus-summary-goto-subject number)
346 (gnus-summary-recenter)
347 (gnus-article-set-window-start
348 (cdr (assq number gnus-newsgroup-bookmarks)))
349 message-id)
350 ;; We restore the old article buffer.
351 (save-excursion
352 (kill-buffer gnus-article-buffer)
353 (set-buffer tmp-buf)
354 (rename-buffer gnus-article-buffer)
355 (let ((buffer-read-only nil))
356 (and tmp-point
357 (set-window-start (get-buffer-window (current-buffer))
358 tmp-point)))))))))))
359
360 (defun gnus-summary-insert-pseudos-xemacs (pslist &optional not-view)
361 (let ((buffer-read-only nil)
362 (article (gnus-summary-article-number))
363 b)
364 (or (gnus-summary-goto-subject article)
365 (error (format "No such article: %d" article)))
366 (or gnus-newsgroup-headers-hashtb-by-number
367 (gnus-make-headers-hashtable-by-number))
368 (gnus-summary-position-cursor)
369 ;; If all commands are to be bunched up on one line, we collect
370 ;; them here.
371 (if gnus-view-pseudos-separately
372 ()
373 (let ((ps (setq pslist (sort pslist 'gnus-pseudos<)))
374 files action)
375 (while ps
376 (setq action (cdr (assq 'action (car ps))))
377 (setq files (list (cdr (assq 'name (car ps)))))
378 (while (and ps (cdr ps)
379 (string= (or action "1")
380 (or (cdr (assq 'action (car (cdr ps)))) "2")))
381 (setq files (cons (cdr (assq 'name (car (cdr ps)))) files))
382 (setcdr ps (cdr (cdr ps))))
383 (if (not files)
384 ()
385 (if (not (string-match "%s" action))
386 (setq files (cons " " files)))
387 (setq files (cons " " files))
388 (and (assq 'execute (car ps))
389 (setcdr (assq 'execute (car ps))
390 (funcall (if (string-match "%s" action)
391 'format 'concat)
392 action
393 (mapconcat (lambda (f) f) files " ")))))
394 (setq ps (cdr ps)))))
395 (if (and gnus-view-pseudos (not not-view))
396 (while pslist
397 (and (assq 'execute (car pslist))
398 (gnus-execute-command (cdr (assq 'execute (car pslist)))
399 (eq gnus-view-pseudos 'not-confirm)))
400 (setq pslist (cdr pslist)))
401 (save-excursion
402 (while pslist
403 (gnus-summary-goto-subject (or (cdr (assq 'article (car pslist)))
404 (gnus-summary-article-number)))
405 (forward-line 1)
406 (setq b (point))
407 (insert " "
408 (file-name-nondirectory (cdr (assq 'name (car pslist))))
409 ": " (or (cdr (assq 'execute (car pslist))) "") "\n")
410 (add-text-properties
411 b (1+ b) (list 'gnus-number gnus-reffed-article-number
412 'gnus-mark gnus-unread-mark
413 'gnus-level 0
414 'gnus-pseudo (car pslist)))
415 ;; Fucking XEmacs redisplay bug with truncated lines.
416 (goto-char b)
417 (sit-for 0)
418 ;; Grumble.. Fucking XEmacs stickyness of text properties.
419 (remove-text-properties
420 (1+ b) (1+ (gnus-point-at-eol))
421 '(gnus-number nil gnus-mark nil gnus-level nil))
422 (forward-line -1)
423 (gnus-sethash (int-to-string gnus-reffed-article-number)
424 (car pslist) gnus-newsgroup-headers-hashtb-by-number)
425 (setq gnus-reffed-article-number (1- gnus-reffed-article-number))
426 (setq pslist (cdr pslist)))))))
427
428
429 (defun gnus-copy-article-buffer-xemacs (&optional article-buffer)
430 (setq gnus-article-copy (get-buffer-create " *gnus article copy*"))
431 (buffer-disable-undo gnus-article-copy)
432 (or (memq gnus-article-copy gnus-buffer-list)
433 (setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list)))
434 (let ((article-buffer (or article-buffer gnus-article-buffer))
435 buf)
436 (if (and (get-buffer article-buffer)
437 (buffer-name (get-buffer article-buffer)))
438 (save-excursion
439 (set-buffer article-buffer)
440 (widen)
441 (setq buf (buffer-substring (point-min) (point-max)))
442 (set-buffer gnus-article-copy)
443 (erase-buffer)
444 (insert (format "%s" buf))))))
445
446 (defun gnus-article-push-button-xemacs (event)
447 "Check text under the mouse pointer for a callback function.
448 If the text under the mouse pointer has a `gnus-callback' property,
449 call it with the value of the `gnus-data' text property."
450 (interactive "e")
451 (set-buffer (window-buffer (event-window event)))
452 (let* ((pos (event-closest-point event))
453 (data (get-text-property pos 'gnus-data))
454 (fun (get-text-property pos 'gnus-callback)))
455 (if fun (funcall fun data))))
456
457 ;; Re-build the thread containing ID.
458 (defun gnus-rebuild-thread-xemacs (id)
459 (let ((dep gnus-newsgroup-dependencies)
460 (buffer-read-only nil)
461 parent headers refs thread art)
462 (while (and id (setq headers
463 (car (setq art (gnus-gethash (downcase id)
464 dep)))))
465 (setq parent art)
466 (setq id (and (setq refs (mail-header-references headers))
467 (string-match "\\(<[^>]+>\\) *$" refs)
468 (substring refs (match-beginning 1) (match-end 1)))))
469 (setq thread (gnus-make-sub-thread (car parent)))
470 (gnus-rebuild-remove-articles thread)
471 (let ((beg (point)))
472 (gnus-summary-prepare-threads (list thread) 0)
473 (save-excursion
474 (while (and (>= (point) beg)
475 (not (bobp)))
476 (or (eobp)
477 (remove-text-properties
478 (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
479 '(gnus-number nil gnus-mark nil gnus-level nil)))
480 (forward-line -1)))
481 (gnus-summary-update-lines beg (point)))))
482
483
484 ;; Fixed by Christopher Davis <ckd@loiosh.kei.com>.
485 (defun gnus-article-add-button-xemacs (from to fun &optional data)
486 "Create a button between FROM and TO with callback FUN and data DATA."
487 (and gnus-article-button-face
488 (gnus-overlay-put (gnus-make-overlay from to) 'face gnus-article-button-face))
489 (add-text-properties from to
490 (append
491 (and gnus-article-mouse-face
492 (list 'mouse-face gnus-article-mouse-face))
493 (list 'gnus-callback fun)
494 (and data (list 'gnus-data data))
495 (list 'highlight t))))
496
497 (defun gnus-window-top-edge-xemacs (&optional window)
498 (nth 1 (window-pixel-edges window)))
499
500 ;; Select the lowest window on the frame.
501 (defun gnus-appt-select-lowest-window-xemacs ()
502 (let* ((lowest-window (selected-window))
503 (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
504 (last-window (previous-window))
505 (window-search t))
506 (while window-search
507 (let* ((this-window (next-window))
508 (next-bottom-edge (car (cdr (cdr (cdr
509 (window-pixel-edges
510 this-window)))))))
511 (if (< bottom-edge next-bottom-edge)
512 (progn
513 (setq bottom-edge next-bottom-edge)
514 (setq lowest-window this-window)))
515
516 (select-window this-window)
517 (if (eq last-window this-window)
518 (progn
519 (select-window lowest-window)
520 (setq window-search nil)))))))
521
522 (defun gnus-ems-redefine ()
523 (cond
524 ((string-match "XEmacs\\|Lucid" emacs-version)
525 ;; XEmacs definitions.
526 (fset 'gnus-mouse-face-function 'identity)
527 (fset 'gnus-summary-make-display-table (lambda () nil))
528 (fset 'gnus-visual-turn-off-edit-menu 'identity)
529 (fset 'gnus-highlight-selected-summary
530 'gnus-highlight-selected-summary-xemacs)
531 (fset 'gnus-summary-recenter 'gnus-summary-recenter-xemacs)
532 (fset 'gnus-group-insert-group-line-info
533 'gnus-group-insert-group-line-info-xemacs)
534 (fset 'gnus-copy-article-buffer 'gnus-copy-article-buffer-xemacs)
535 (fset 'gnus-summary-refer-article 'gnus-summary-refer-article-xemacs)
536 (fset 'gnus-summary-insert-pseudos 'gnus-summary-insert-pseudos-xemacs)
537 (fset 'gnus-article-push-button 'gnus-article-push-button-xemacs)
538 (fset 'gnus-rebuild-thread 'gnus-rebuild-thread-xemacs)
539 (fset 'gnus-article-add-button 'gnus-article-add-button-xemacs)
540 (fset 'gnus-window-top-edge 'gnus-window-top-edge-xemacs)
541 (fset 'set-text-properties 'gnus-set-text-properties-xemacs)
542
543 (or (fboundp 'appt-select-lowest-window)
544 (fset 'appt-select-lowest-window
545 'gnus-appt-select-lowest-window-xemacs))
546
547 (if (not gnus-visual)
548 ()
549 (setq gnus-group-mode-hook
550 (cons
551 '(lambda ()
552 (easy-menu-add gnus-group-reading-menu)
553 (easy-menu-add gnus-group-group-menu)
554 (easy-menu-add gnus-group-misc-menu)
555 (gnus-install-mouse-tracker))
556 gnus-group-mode-hook))
557 (setq gnus-summary-mode-hook
558 (cons
559 '(lambda ()
560 (easy-menu-add gnus-summary-article-menu)
561 (easy-menu-add gnus-summary-thread-menu)
562 (easy-menu-add gnus-summary-misc-menu)
563 (easy-menu-add gnus-summary-post-menu)
564 (easy-menu-add gnus-summary-kill-menu)
565 (gnus-install-mouse-tracker))
566 gnus-summary-mode-hook))
567 (setq gnus-article-mode-hook
568 (cons
569 '(lambda ()
570 (easy-menu-add gnus-article-article-menu)
571 (easy-menu-add gnus-article-treatment-menu))
572 gnus-article-mode-hook)))
573
574 (defvar gnus-logo (make-glyph (make-specifier 'image)))
575
576 (defun gnus-group-startup-xmessage (&optional x y)
577 "Insert startup message in current buffer."
578 ;; Insert the message.
579 (erase-buffer)
580 (if (featurep 'xpm)
581 (progn
582 (set-glyph-property gnus-logo 'image "~/tmp/gnus.xpm")
583 (set-glyph-image gnus-logo "~/tmp/gnus.xpm" 'global 'x)
584
585 (insert " ")
586 (set-extent-begin-glyph (make-extent (point) (point)) gnus-logo)
587 (insert "
588 Gnus * A newsreader for Emacsen
589 A Praxis Release * larsi@ifi.uio.no")
590 (goto-char (point-min))
591 (while (not (eobp))
592 (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
593 ? ))
594 (forward-line 1))
595 (goto-char (point-min))
596 ;; +4 is fuzzy factor.
597 (insert-char ?\n (/ (max (- (window-height) (or y 24)) 0) 2)))
598
599 (insert
600 (format "
601 %s
602 A newsreader
603 for GNU Emacs
604
605 Based on GNUS
606 written by
607 Masanobu UMEDA
608
609 A Praxis Release
610 larsi@ifi.uio.no
611 "
612 gnus-version))
613 ;; And then hack it.
614 ;; 18 is the longest line.
615 (indent-rigidly (point-min) (point-max)
616 (/ (max (- (window-width) (or x 28)) 0) 2))
617 (goto-char (point-min))
618 ;; +4 is fuzzy factor.
619 (insert-char ?\n (/ (max (- (window-height) (or y 12)) 0) 2)))
620
621 ;; Fontify some.
622 (goto-char (point-min))
623 (search-forward "Praxis")
624 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)
625 (goto-char (point-min)))
626
627
628
629 )
630
631 ((boundp 'MULE)
632 ;; Mule definitions
633 (if (not (fboundp 'truncate-string))
634 (defun truncate-string (str width)
635 (let ((w (string-width str))
636 (col 0) (idx 0) (p-idx 0) chr)
637 (if (<= w width)
638 str
639 (while (< col width)
640 (setq chr (aref str idx)
641 col (+ col (char-width chr))
642 p-idx idx
643 idx (+ idx (char-bytes chr))
644 ))
645 (substring str 0 (if (= col width)
646 idx
647 p-idx))
648 )))
649 )
650 (defalias 'gnus-truncate-string 'truncate-string)
651
652 (defun gnus-cite-add-face (number prefix face)
653 ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
654 (if face
655 (let ((inhibit-point-motion-hooks t)
656 from to)
657 (goto-line number)
658 (if (boundp 'MULE)
659 (forward-char (chars-in-string prefix))
660 (forward-char (length prefix)))
661 (skip-chars-forward " \t")
662 (setq from (point))
663 (end-of-line 1)
664 (skip-chars-backward " \t")
665 (setq to (point))
666 (if (< from to)
667 (gnus-overlay-put (gnus-make-overlay from to) 'face face)))))
668
669 (defun gnus-max-width-function (el max-width)
670 (` (let* ((val (eval (, el)))
671 (valstr (if (numberp val)
672 (int-to-string val) val)))
673 (if (> (length valstr) (, max-width))
674 (truncate-string valstr (, max-width))
675 valstr))))
676
677 (fset 'gnus-summary-make-display-table (lambda () nil))
678
679 (if (boundp 'gnus-check-before-posting)
680 (setq gnus-check-before-posting
681 (delq 'long-lines
682 (delq 'control-chars gnus-check-before-posting)))
683 )
684 )
685 ))
686
687 (provide 'gnus-ems)
688
689 ;; Local Variables:
690 ;; byte-compile-warnings: '(redefine callargs)
691 ;; End:
692
693 ;;; gnus-ems.el ends here