Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-xmas.el @ 16:0293115a14e9 r19-15b91

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b91
author cvs
date Mon, 13 Aug 2007 08:49:20 +0200
parents ac2d302a0011
children d95e72db5c07
comparison
equal deleted inserted replaced
15:ad457d5f7d04 16:0293115a14e9
1 ;;; gnus-xmas.el --- Gnus functions for XEmacs 1 ;;; gnus-xmas.el --- Gnus functions for XEmacs
2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc. 2 ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
3 3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
5 ;; Keywords: news 5 ;; Keywords: news
6 6
7 ;; This file is part of GNU Emacs. 7 ;; This file is part of GNU Emacs.
24 ;;; Commentary: 24 ;;; Commentary:
25 25
26 ;;; Code: 26 ;;; Code:
27 27
28 (require 'text-props) 28 (require 'text-props)
29 (eval-when-compile (require 'cl))
30 (defvar menu-bar-mode (featurep 'menubar)) 29 (defvar menu-bar-mode (featurep 'menubar))
31 (require 'messagexmas) 30 (require 'messagexmas)
32 31
33 (defvar gnus-xmas-glyph-directory nil 32 (defvar gnus-xmas-glyph-directory nil
34 "*Directory where Gnus logos and icons are located. 33 "*Directory where Gnus logos and icons are located.
35 If this variable is nil, Gnus will try to locate the directory 34 If this variable is nil, Gnus will try to locate the directory
36 automatically.") 35 automatically.")
37 36
38 (defvar gnus-xmas-logo-color-alist 37 (defvar gnus-xmas-logo-color-alist
39 '((flame "#cc3300" "#ff2200") 38 '((flame "#cc3300" "#ff2200")
40 (pine "#c0cc93" "#f8ffb8") 39 (pine "#c0cc93" "#f8ffb8")
41 (moss "#a1cc93" "#d2ffb8") 40 (moss "#a1cc93" "#d2ffb8")
42 (irish "#04cc90" "#05ff97") 41 (irish "#04cc90" "#05ff97")
43 (sky "#049acc" "#05deff") 42 (sky "#049acc" "#05deff")
44 (tin "#6886cc" "#82b6ff") 43 (tin "#6886cc" "#82b6ff")
45 (velvet "#7c68cc" "#8c82ff") 44 (velvet "#7c68cc" "#8c82ff")
48 (berry "#cc6485" "#ff7db5") 47 (berry "#cc6485" "#ff7db5")
49 (neutral "#b4b4b4" "#878787") 48 (neutral "#b4b4b4" "#878787")
50 (september "#bf9900" "#ffcc00")) 49 (september "#bf9900" "#ffcc00"))
51 "Color alist used for the Gnus logo.") 50 "Color alist used for the Gnus logo.")
52 51
53 (defvar gnus-xmas-logo-color-style 'september 52 (defvar gnus-xmas-logo-color-style 'flame
54 "Color styles used for the Gnus logo.") 53 "Color styles used for the Gnus logo.")
55 54
56 (defvar gnus-xmas-logo-colors 55 (defvar gnus-xmas-logo-colors
57 (cdr (assq gnus-xmas-logo-color-style gnus-xmas-logo-color-alist)) 56 (cdr (assq gnus-xmas-logo-color-style gnus-xmas-logo-color-alist))
58 "Colors used for the Gnus logo.") 57 "Colors used for the Gnus logo.")
116 (defvar gnus-tree-minimize-window) 115 (defvar gnus-tree-minimize-window)
117 116
118 (defun gnus-xmas-set-text-properties (start end props &optional buffer) 117 (defun gnus-xmas-set-text-properties (start end props &optional buffer)
119 "You should NEVER use this function. It is ideologically blasphemous. 118 "You should NEVER use this function. It is ideologically blasphemous.
120 It is provided only to ease porting of broken FSF Emacs programs." 119 It is provided only to ease porting of broken FSF Emacs programs."
121 (if (stringp buffer) 120 (if (stringp buffer)
122 nil 121 nil
123 (map-extents (lambda (extent ignored) 122 (map-extents (lambda (extent ignored)
124 (remove-text-properties 123 (remove-text-properties
125 start end 124 start end
126 (list (extent-property extent 'text-prop) nil) 125 (list (extent-property extent 'text-prop) nil)
129 (gnus-add-text-properties start end props buffer))) 128 (gnus-add-text-properties start end props buffer)))
130 129
131 (defun gnus-xmas-highlight-selected-summary () 130 (defun gnus-xmas-highlight-selected-summary ()
132 ;; Highlight selected article in summary buffer 131 ;; Highlight selected article in summary buffer
133 (when gnus-summary-selected-face 132 (when gnus-summary-selected-face
134 (if gnus-newsgroup-selected-overlay 133 (when gnus-newsgroup-selected-overlay
135 (delete-extent gnus-newsgroup-selected-overlay)) 134 (delete-extent gnus-newsgroup-selected-overlay))
136 (setq gnus-newsgroup-selected-overlay 135 (setq gnus-newsgroup-selected-overlay
137 (make-extent (gnus-point-at-bol) (gnus-point-at-eol))) 136 (make-extent (point-at-bol) (point-at-eol)))
138 (set-extent-face gnus-newsgroup-selected-overlay 137 (set-extent-face gnus-newsgroup-selected-overlay
139 gnus-summary-selected-face))) 138 gnus-summary-selected-face)))
139
140 (defvar gnus-xmas-force-redisplay t
141 "If non-nil, force a redisplay before recentering the summary buffer.
142 This is ugly, but it works around a bug in `window-displayed-height'.")
140 143
141 (defun gnus-xmas-summary-recenter () 144 (defun gnus-xmas-summary-recenter ()
142 "\"Center\" point in the summary window. 145 "\"Center\" point in the summary window.
143 If `gnus-auto-center-summary' is nil, or the article buffer isn't 146 If `gnus-auto-center-summary' is nil, or the article buffer isn't
144 displayed, no centering will be performed." 147 displayed, no centering will be performed."
145 ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle). 148 ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle).
146 ;; Recenter only when requested. Suggested by popovich@park.cs.columbia.edu. 149 ;; Recenter only when requested. Suggested by popovich@park.cs.columbia.edu.
150 ;; Force redisplay to get properly computed window height.
151 (when gnus-xmas-force-redisplay
152 (sit-for 0))
147 (when gnus-auto-center-summary 153 (when gnus-auto-center-summary
148 (let* ((height (if (fboundp 'window-displayed-height) 154 (let* ((height (if (fboundp 'window-displayed-height)
149 (window-displayed-height) 155 (window-displayed-height)
150 (- (window-height) 2))) 156 (- (window-height) 2)))
151 (top (cond ((< height 4) 0) 157 (top (cond ((< height 4) 0)
159 ;; Only do recentering when the article buffer is displayed, 165 ;; Only do recentering when the article buffer is displayed,
160 ;; Set the window start to either `bottom', which is the biggest 166 ;; Set the window start to either `bottom', which is the biggest
161 ;; possible valid number, or the second line from the top, 167 ;; possible valid number, or the second line from the top,
162 ;; whichever is the least. 168 ;; whichever is the least.
163 (set-window-start 169 (set-window-start
164 window (min bottom (save-excursion 170 window (min bottom (save-excursion (forward-line (- top)) (point)))))
165 (forward-line (- top)) (point)))))
166 ;; Do horizontal recentering while we're at it. 171 ;; Do horizontal recentering while we're at it.
167 (when (and (get-buffer-window (current-buffer) t) 172 (when (and (get-buffer-window (current-buffer) t)
168 (not (eq gnus-auto-center-summary 'vertical))) 173 (not (eq gnus-auto-center-summary 'vertical)))
169 (let ((selected (selected-window))) 174 (let ((selected (selected-window)))
170 (select-window (get-buffer-window (current-buffer) t)) 175 (select-window (get-buffer-window (current-buffer) t))
195 (interactive "e") 200 (interactive "e")
196 (set-buffer (window-buffer (event-window event))) 201 (set-buffer (window-buffer (event-window event)))
197 (let* ((pos (event-closest-point event)) 202 (let* ((pos (event-closest-point event))
198 (data (get-text-property pos 'gnus-data)) 203 (data (get-text-property pos 'gnus-data))
199 (fun (get-text-property pos 'gnus-callback))) 204 (fun (get-text-property pos 'gnus-callback)))
200 (if fun (funcall fun data)))) 205 (when fun
206 (funcall fun data))))
201 207
202 (defun gnus-xmas-move-overlay (extent start end &optional buffer) 208 (defun gnus-xmas-move-overlay (extent start end &optional buffer)
203 (set-extent-endpoints extent start end)) 209 (set-extent-endpoints extent start end))
204 210
205 ;; Fixed by Christopher Davis <ckd@loiosh.kei.com>. 211 ;; Fixed by Christopher Davis <ckd@loiosh.kei.com>.
206 (defun gnus-xmas-article-add-button (from to fun &optional data) 212 (defun gnus-xmas-article-add-button (from to fun &optional data)
207 "Create a button between FROM and TO with callback FUN and data DATA." 213 "Create a button between FROM and TO with callback FUN and data DATA."
208 (and gnus-article-button-face 214 (when gnus-article-button-face
209 (gnus-overlay-put (gnus-make-overlay from to) 215 (gnus-overlay-put (gnus-make-overlay from to)
210 'face gnus-article-button-face)) 216 'face gnus-article-button-face))
211 (gnus-add-text-properties 217 (gnus-add-text-properties
212 from to 218 from to
213 (nconc 219 (nconc
214 (and gnus-article-mouse-face 220 (and gnus-article-mouse-face
215 (list 'mouse-face gnus-article-mouse-face)) 221 (list 'mouse-face gnus-article-mouse-face))
247 (while window-search 253 (while window-search
248 (let* ((this-window (next-window)) 254 (let* ((this-window (next-window))
249 (next-bottom-edge (car (cdr (cdr (cdr 255 (next-bottom-edge (car (cdr (cdr (cdr
250 (window-pixel-edges 256 (window-pixel-edges
251 this-window))))))) 257 this-window)))))))
252 (if (< bottom-edge next-bottom-edge) 258 (when (< bottom-edge next-bottom-edge)
253 (progn 259 (setq bottom-edge next-bottom-edge)
254 (setq bottom-edge next-bottom-edge) 260 (setq lowest-window this-window))
255 (setq lowest-window this-window)))
256 261
257 (select-window this-window) 262 (select-window this-window)
258 (if (eq last-window this-window) 263 (when (eq last-window this-window)
259 (progn 264 (select-window lowest-window)
260 (select-window lowest-window) 265 (setq window-search nil))))))
261 (setq window-search nil)))))))
262 266
263 (defmacro gnus-xmas-menu-add (type &rest menus) 267 (defmacro gnus-xmas-menu-add (type &rest menus)
264 `(gnus-xmas-menu-add-1 ',type ',menus)) 268 `(gnus-xmas-menu-add-1 ',type ',menus))
265 (put 'gnus-xmas-menu-add 'lisp-indent-function 1) 269 (put 'gnus-xmas-menu-add 'lisp-indent-function 1)
266 (put 'gnus-xmas-menu-add 'lisp-indent-hook 1)
267 270
268 (defun gnus-xmas-menu-add-1 (type menus) 271 (defun gnus-xmas-menu-add-1 (type menus)
269 (when (and menu-bar-mode 272 (when (and menu-bar-mode
270 (gnus-visual-p (intern (format "%s-menu" type)) 'menu)) 273 (gnus-visual-p (intern (format "%s-menu" type)) 'menu))
271 (while menus 274 (while menus
291 294
292 (defun gnus-xmas-pick-menu-add () 295 (defun gnus-xmas-pick-menu-add ()
293 (gnus-xmas-menu-add pick 296 (gnus-xmas-menu-add pick
294 gnus-pick-menu)) 297 gnus-pick-menu))
295 298
299 (defun gnus-xmas-topic-menu-add ()
300 (gnus-xmas-menu-add topic
301 gnus-topic-menu))
302
296 (defun gnus-xmas-binary-menu-add () 303 (defun gnus-xmas-binary-menu-add ()
297 (gnus-xmas-menu-add binary 304 (gnus-xmas-menu-add binary
298 gnus-binary-menu)) 305 gnus-binary-menu))
299 306
300 (defun gnus-xmas-tree-menu-add () 307 (defun gnus-xmas-tree-menu-add ()
313 (gnus-xmas-menu-add grouplens 320 (gnus-xmas-menu-add grouplens
314 gnus-grouplens-menu)) 321 gnus-grouplens-menu))
315 322
316 (defun gnus-xmas-read-event-char () 323 (defun gnus-xmas-read-event-char ()
317 "Get the next event." 324 "Get the next event."
318 (let ((event (next-event))) 325 (let ((event (next-command-event)))
326 (sit-for 0)
319 ;; We junk all non-key events. Is this naughty? 327 ;; We junk all non-key events. Is this naughty?
320 (while (not (key-press-event-p event)) 328 (while (not (key-press-event-p event))
321 (setq event (next-event))) 329 (setq event (next-command-event)))
322 (cons (and (key-press-event-p event) 330 (cons (and (key-press-event-p event)
323 ; (numberp (event-key event))
324 (event-to-character event)) 331 (event-to-character event))
325 event))) 332 event)))
326 333
327 (defun gnus-xmas-group-remove-excess-properties () 334 (defun gnus-xmas-group-remove-excess-properties ()
328 (let ((end (point)) 335 (let ((end (point))
363 (* (float tday) 60 60 24)))) 370 (* (float tday) 60 60 24))))
364 371
365 (defun gnus-xmas-define () 372 (defun gnus-xmas-define ()
366 (setq gnus-mouse-2 [button2]) 373 (setq gnus-mouse-2 [button2])
367 374
368 (or (memq 'underline (face-list)) 375 (unless (memq 'underline (face-list))
369 (and (fboundp 'make-face) 376 (and (fboundp 'make-face)
370 (funcall (intern "make-face") 'underline))) 377 (funcall (intern "make-face") 'underline)))
371 ;; Must avoid calling set-face-underline-p directly, because it 378 ;; Must avoid calling set-face-underline-p directly, because it
372 ;; is a defsubst in emacs19, and will make the .elc files non 379 ;; is a defsubst in emacs19, and will make the .elc files non
373 ;; portable! 380 ;; portable!
374 (or (face-differs-from-default-p 'underline) 381 (unless (face-differs-from-default-p 'underline)
375 (funcall (intern "set-face-underline-p") 'underline t)) 382 (funcall (intern "set-face-underline-p") 'underline t))
383
384 (cond
385 ((fboundp 'char-or-char-int-p)
386 ;; Handle both types of marks for XEmacs-20.x.
387 (fset 'gnus-characterp 'char-or-char-int-p))
388 ;; V19 of XEmacs, probably.
389 (t
390 (fset 'gnus-characterp 'characterp)))
376 391
377 (fset 'gnus-make-overlay 'make-extent) 392 (fset 'gnus-make-overlay 'make-extent)
378 (fset 'gnus-overlay-put 'set-extent-property) 393 (fset 'gnus-overlay-put 'set-extent-property)
379 (fset 'gnus-move-overlay 'gnus-xmas-move-overlay) 394 (fset 'gnus-move-overlay 'gnus-xmas-move-overlay)
380 (fset 'gnus-overlay-end 'extent-end-position) 395 (fset 'gnus-overlay-end 'extent-end-position)
381 (fset 'gnus-extent-detached-p 'extent-detached-p) 396 (fset 'gnus-extent-detached-p 'extent-detached-p)
382 (fset 'gnus-add-text-properties 'gnus-xmas-add-text-properties) 397 (fset 'gnus-add-text-properties 'gnus-xmas-add-text-properties)
383 (fset 'gnus-put-text-property 'gnus-xmas-put-text-property) 398 (fset 'gnus-put-text-property 'gnus-xmas-put-text-property)
384 399
385 (require 'text-props) 400 (require 'text-props)
386 (if (< emacs-minor-version 14) 401 (if (and (<= emacs-major-version 19)
402 (< emacs-minor-version 14))
387 (fset 'gnus-set-text-properties 'gnus-xmas-set-text-properties)) 403 (fset 'gnus-set-text-properties 'gnus-xmas-set-text-properties))
388 404
389 (or (boundp 'standard-display-table) (setq standard-display-table nil)) 405 (when (fboundp 'turn-off-scroll-in-place)
406 (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place))
407
408 (unless (boundp 'standard-display-table)
409 (setq standard-display-table nil))
390 410
391 (defvar gnus-mouse-face-prop 'highlight) 411 (defvar gnus-mouse-face-prop 'highlight)
392 412
393 (unless (fboundp 'encode-time) 413 (unless (fboundp 'encode-time)
394 (defun encode-time (sec minute hour day month year &optional zone) 414 (defun encode-time (sec minute hour day month year &optional zone)
404 "Return a form that can be `eval'ed based on FUNC." 424 "Return a form that can be `eval'ed based on FUNC."
405 (let ((fval (symbol-function func))) 425 (let ((fval (symbol-function func)))
406 (if (compiled-function-p fval) 426 (if (compiled-function-p fval)
407 (list 'funcall fval) 427 (list 'funcall fval)
408 (cons 'progn (cdr (cdr fval)))))) 428 (cons 'progn (cdr (cdr fval))))))
409
410 ;; Fix by "jeff (j.d.) sparkes" <jsparkes@bnr.ca>.
411 (defvar gnus-display-type (device-class)
412 "A symbol indicating the display Emacs is running under.
413 The symbol should be one of `color', `grayscale' or `mono'. If Emacs
414 guesses this display attribute wrongly, either set this variable in
415 your `~/.emacs' or set the resource `Emacs.displayType' in your
416 `~/.Xdefaults'. See also `gnus-background-mode'.
417
418 This is a meta-variable that will affect what default values other
419 variables get. You would normally not change this variable, but
420 pounce directly on the real variables themselves.")
421
422 429
423 (fset 'gnus-x-color-values 430 (fset 'gnus-x-color-values
424 (if (fboundp 'x-color-values) 431 (if (fboundp 'x-color-values)
425 'x-color-values 432 'x-color-values
426 (lambda (color) 433 (lambda (color)
427 (color-instance-rgb-components 434 (color-instance-rgb-components
428 (make-color-instance color))))) 435 (make-color-instance color))))))
429
430 (defvar gnus-background-mode
431 (let* ((bg-resource
432 (condition-case ()
433 (x-get-resource ".backgroundMode" "BackgroundMode" 'string)
434 (error nil)))
435 (params (frame-parameters))
436 (color (condition-case ()
437 (or (assq 'background-color params)
438 (color-instance-name
439 (specifier-instance
440 (face-background 'default))))
441 (error nil))))
442 (cond (bg-resource (intern (downcase bg-resource)))
443 ((and color
444 (< (apply '+ (gnus-x-color-values color))
445 (/ (apply '+ (gnus-x-color-values "white")) 3)))
446 'dark)
447 (t 'light)))
448 "A symbol indicating the Emacs background brightness.
449 The symbol should be one of `light' or `dark'.
450 If Emacs guesses this frame attribute wrongly, either set this variable in
451 your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
452 `~/.Xdefaults'.
453 See also `gnus-display-type'.
454
455 This is a meta-variable that will affect what default values other
456 variables get. You would normally not change this variable, but
457 pounce directly on the real variables themselves.")
458 )
459
460 436
461 437
462 (defun gnus-xmas-redefine () 438 (defun gnus-xmas-redefine ()
463 "Redefine lots of Gnus functions for XEmacs." 439 "Redefine lots of Gnus functions for XEmacs."
464 (fset 'gnus-summary-make-display-table 'ignore) 440 (fset 'gnus-summary-make-display-table 'ignore)
475 'gnus-xmas-appt-select-lowest-window) 451 'gnus-xmas-appt-select-lowest-window)
476 (fset 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names) 452 (fset 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names)
477 (fset 'gnus-make-local-hook 'make-local-variable) 453 (fset 'gnus-make-local-hook 'make-local-variable)
478 (fset 'gnus-add-hook 'gnus-xmas-add-hook) 454 (fset 'gnus-add-hook 'gnus-xmas-add-hook)
479 (fset 'gnus-character-to-event 'character-to-event) 455 (fset 'gnus-character-to-event 'character-to-event)
480 (fset 'gnus-article-show-hidden-text 'gnus-xmas-article-show-hidden-text)
481 (fset 'gnus-mode-line-buffer-identification 456 (fset 'gnus-mode-line-buffer-identification
482 'gnus-xmas-mode-line-buffer-identification) 457 'gnus-xmas-mode-line-buffer-identification)
458 (fset 'gnus-key-press-event-p 'key-press-event-p)
483 459
484 (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add) 460 (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add)
485 (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add) 461 (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add)
486 (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add) 462 (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add)
487 (add-hook 'gnus-score-mode-hook 'gnus-xmas-score-menu-add) 463 (add-hook 'gnus-score-mode-hook 'gnus-xmas-score-menu-add)
488 464
489 (add-hook 'gnus-pick-mode-hook 'gnus-xmas-pick-menu-add) 465 (add-hook 'gnus-pick-mode-hook 'gnus-xmas-pick-menu-add)
466 (add-hook 'gnus-topic-mode-hook 'gnus-xmas-topic-menu-add)
490 (add-hook 'gnus-tree-mode-hook 'gnus-xmas-tree-menu-add) 467 (add-hook 'gnus-tree-mode-hook 'gnus-xmas-tree-menu-add)
491 (add-hook 'gnus-binary-mode-hook 'gnus-xmas-binary-menu-add) 468 (add-hook 'gnus-binary-mode-hook 'gnus-xmas-binary-menu-add)
492 (add-hook 'gnus-grouplens-mode-hook 'gnus-xmas-grouplens-menu-add) 469 (add-hook 'gnus-grouplens-mode-hook 'gnus-xmas-grouplens-menu-add)
493 (add-hook 'gnus-server-mode-hook 'gnus-xmas-server-menu-add) 470 (add-hook 'gnus-server-mode-hook 'gnus-xmas-server-menu-add)
494 (add-hook 'gnus-browse-mode-hook 'gnus-xmas-browse-menu-add) 471 (add-hook 'gnus-browse-mode-hook 'gnus-xmas-browse-menu-add)
496 (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar) 473 (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar)
497 (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar) 474 (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar)
498 475
499 (when (and (<= emacs-major-version 19) 476 (when (and (<= emacs-major-version 19)
500 (<= emacs-minor-version 13)) 477 (<= emacs-minor-version 13))
501 (setq gnus-article-x-face-too-ugly (if (eq (device-type) 'tty) ".")) 478 (setq gnus-article-x-face-too-ugly (when (eq (device-type) 'tty)
479 "."))
502 (fset 'gnus-highlight-selected-summary 480 (fset 'gnus-highlight-selected-summary
503 'gnus-xmas-highlight-selected-summary) 481 'gnus-xmas-highlight-selected-summary)
504 (fset 'gnus-group-remove-excess-properties 482 (fset 'gnus-group-remove-excess-properties
505 'gnus-xmas-group-remove-excess-properties) 483 'gnus-xmas-group-remove-excess-properties)
506 (fset 'gnus-topic-remove-excess-properties 484 (fset 'gnus-topic-remove-excess-properties
507 'gnus-xmas-topic-remove-excess-properties) 485 'gnus-xmas-topic-remove-excess-properties)
508 (fset 'gnus-mode-line-buffer-identification 'identity) 486 (fset 'gnus-mode-line-buffer-identification 'identity)
509 (unless (boundp 'shell-command-switch) 487 (unless (boundp 'shell-command-switch)
510 (setq shell-command-switch "-c")) 488 (setq shell-command-switch "-c"))))
511 ))
512 489
513 490
514 ;;; XEmacs logo and toolbar. 491 ;;; XEmacs logo and toolbar.
515 492
516 (defun gnus-xmas-group-startup-message (&optional x y) 493 (defun gnus-xmas-group-startup-message (&optional x y)
568 __ 545 __
569 546
570 " 547 "
571 "")) 548 ""))
572 ;; And then hack it. 549 ;; And then hack it.
573 (gnus-indent-rigidly (point-min) (point-max) 550 (gnus-indent-rigidly (point-min) (point-max)
574 (/ (max (- (window-width) (or x 46)) 0) 2)) 551 (/ (max (- (window-width) (or x 46)) 0) 2))
575 (goto-char (point-min)) 552 (goto-char (point-min))
576 (forward-line 1) 553 (forward-line 1)
577 (let* ((pheight (count-lines (point-min) (point-max))) 554 (let* ((pheight (count-lines (point-min) (point-max)))
578 (wheight (window-height)) 555 (wheight (window-height))
579 (rest (- wheight pheight))) 556 (rest (- wheight pheight)))
580 (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))) 557 (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
581 ;; Fontify some. 558 ;; Fontify some.
582 (goto-char (point-min)) 559 (goto-char (point-min))
583 (and (search-forward "Praxis" nil t) 560 (put-text-property (point-min) (point-max) 'face 'gnus-splash-face)
584 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
585 (goto-char (point-min)) 561 (goto-char (point-min))
586 (let* ((mode-string (gnus-group-set-mode-line))) 562 (setq modeline-buffer-identification
587 (setq modeline-buffer-identification 563 (list (concat gnus-version ": *Group*")))
588 (list (concat gnus-version ": *Group*"))) 564 (set-buffer-modified-p t)))
589 (set-buffer-modified-p t))))
590 565
591 566
592 ;;; The toolbar. 567 ;;; The toolbar.
593 568
594 (defvar gnus-use-toolbar (if (featurep 'toolbar) 569 (defvar gnus-use-toolbar (if (featurep 'toolbar)
598 If it is non-nil, it must be a toolbar. The five legal values are 573 If it is non-nil, it must be a toolbar. The five legal values are
599 `default-toolbar', `top-toolbar', `bottom-toolbar', 574 `default-toolbar', `top-toolbar', `bottom-toolbar',
600 `right-toolbar', and `left-toolbar'.") 575 `right-toolbar', and `left-toolbar'.")
601 576
602 (defvar gnus-group-toolbar 577 (defvar gnus-group-toolbar
603 '( 578 '([gnus-group-get-new-news gnus-group-get-new-news t "Get new news"]
604 [gnus-group-get-new-news gnus-group-get-new-news t "Get new news"]
605 [gnus-group-get-new-news-this-group 579 [gnus-group-get-new-news-this-group
606 gnus-group-get-new-news-this-group t "Get new news in this group"] 580 gnus-group-get-new-news-this-group t "Get new news in this group"]
607 [gnus-group-catchup-current 581 [gnus-group-catchup-current
608 gnus-group-catchup-current t "Catchup group"] 582 gnus-group-catchup-current t "Catchup group"]
609 [gnus-group-describe-group 583 [gnus-group-describe-group
610 gnus-group-describe-group t "Describe group"] 584 gnus-group-describe-group t "Describe group"]
585 [gnus-group-unsubscribe gnus-group-unsubscribe t "Unsubscribe group"]
586 [gnus-group-subscribe gnus-group-subscribe t "Subscribe group"]
611 [gnus-group-kill-group gnus-group-kill-group t "Kill group"] 587 [gnus-group-kill-group gnus-group-kill-group t "Kill group"]
612 [gnus-group-exit gnus-group-exit t "Exit Gnus"] 588 [gnus-group-exit gnus-group-exit t "Exit Gnus"]
613 ) 589 )
614 "The group buffer toolbar.") 590 "The group buffer toolbar.")
615 591
616 (defvar gnus-summary-toolbar 592 (defvar gnus-summary-toolbar
617 '( 593 '([gnus-summary-prev-unread
618 [gnus-summary-prev-unread
619 gnus-summary-prev-unread-article t "Prev unread article"] 594 gnus-summary-prev-unread-article t "Prev unread article"]
620 [gnus-summary-next-unread 595 [gnus-summary-next-unread
621 gnus-summary-next-unread-article t "Next unread article"] 596 gnus-summary-next-unread-article t "Next unread article"]
622 [gnus-summary-post-news 597 [gnus-summary-post-news
623 gnus-summary-post-news t "Post an article"] 598 gnus-summary-post-news t "Post an article"]
640 gnus-summary-save-article t "Save article"] 615 gnus-summary-save-article t "Save article"]
641 [gnus-uu-post-news 616 [gnus-uu-post-news
642 gnus-uu-post-news t "Post an uuencoded article"] 617 gnus-uu-post-news t "Post an uuencoded article"]
643 [gnus-summary-cancel-article 618 [gnus-summary-cancel-article
644 gnus-summary-cancel-article t "Cancel article"] 619 gnus-summary-cancel-article t "Cancel article"]
620 [gnus-summary-catchup
621 gnus-summary-catchup t "Catchup"]
645 [gnus-summary-catchup-and-exit 622 [gnus-summary-catchup-and-exit
646 gnus-summary-catchup-and-exit t "Catchup and exit"] 623 gnus-summary-catchup-and-exit t "Catchup and exit"]
647 [gnus-summary-exit gnus-summary-exit t "Exit this summary"] 624 [gnus-summary-exit gnus-summary-exit t "Exit this summary"]
648 ) 625 )
649 "The summary buffer toolbar.") 626 "The summary buffer toolbar.")
653 [gnus-summary-prev-unread 630 [gnus-summary-prev-unread
654 gnus-summary-prev-unread-article t "Prev unread article"] 631 gnus-summary-prev-unread-article t "Prev unread article"]
655 [gnus-summary-next-unread 632 [gnus-summary-next-unread
656 gnus-summary-next-unread-article t "Next unread article"] 633 gnus-summary-next-unread-article t "Next unread article"]
657 [gnus-summary-mail-reply gnus-summary-reply t "Reply"] 634 [gnus-summary-mail-reply gnus-summary-reply t "Reply"]
658 [gnus-summary-mail-get gnus-mail-get t "Message get"] 635 ; [gnus-summary-mail-get gnus-mail-get t "Message get"]
659 [gnus-summary-mail-originate gnus-summary-post-news t "Originate"] 636 [gnus-summary-mail-originate gnus-summary-post-news t "Originate"]
660 [gnus-summary-mail-save gnus-summary-save-article t "Save"] 637 [gnus-summary-mail-save gnus-summary-save-article t "Save"]
661 [gnus-summary-mail-copy gnus-summary-copy-article t "Copy message"] 638 [gnus-summary-mail-copy gnus-summary-copy-article t "Copy message"]
662 ; [gnus-summary-mail-delete gnus-summary-delete-article t "Delete message"] 639 ; [gnus-summary-mail-delete gnus-summary-delete-article t "Delete message"]
663 [gnus-summary-mail-forward gnus-summary-mail-forward t "Forward message"] 640 [gnus-summary-mail-forward gnus-summary-mail-forward t "Forward message"]
669 gnus-uu-decode-uu t "Decode uuencoded articles"] 646 gnus-uu-decode-uu t "Decode uuencoded articles"]
670 [gnus-summary-save-article-file 647 [gnus-summary-save-article-file
671 gnus-summary-save-article-file t "Save article in file"] 648 gnus-summary-save-article-file t "Save article in file"]
672 [gnus-summary-save-article 649 [gnus-summary-save-article
673 gnus-summary-save-article t "Save article"] 650 gnus-summary-save-article t "Save article"]
651 [gnus-summary-catchup
652 gnus-summary-catchup t "Catchup"]
674 [gnus-summary-catchup-and-exit 653 [gnus-summary-catchup-and-exit
675 gnus-summary-catchup-and-exit t "Catchup and exit"] 654 gnus-summary-catchup-and-exit t "Catchup and exit"]
676 [gnus-summary-exit gnus-summary-exit t "Exit this summary"] 655 [gnus-summary-exit gnus-summary-exit t "Exit this summary"]
677 ) 656 )
678 "The summary buffer mail toolbar.") 657 "The summary buffer mail toolbar.")
733 (goto-char (point-min)) 712 (goto-char (point-min))
734 (re-search-forward "^From:" nil t) 713 (re-search-forward "^From:" nil t)
735 (set-extent-begin-glyph 714 (set-extent-begin-glyph
736 (make-extent (point) (1+ (point))) xface-glyph)))) 715 (make-extent (point) (1+ (point))) xface-glyph))))
737 716
738 (defun gnus-xmas-article-show-hidden-text (type &optional hide) 717 (defvar gnus-xmas-pointer-glyph
739 "Show all hidden text of type TYPE. 718 (progn
740 If HIDE, hide the text instead." 719 (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
741 (save-excursion 720 (make-pointer-glyph (concat gnus-xmas-glyph-directory "gnus-pointer."
742 (set-buffer gnus-article-buffer) 721 (if (featurep 'xpm) "xpm" "xbm")))))
743 (let ((buffer-read-only nil) 722
744 (inhibit-point-motion-hooks t) 723 (defvar gnus-xmas-modeline-left-extent
745 (beg (point-min))) 724 (let ((ext (copy-extent modeline-buffer-id-left-extent)))
746 (while (gnus-goto-char (text-property-any 725 ;(set-extent-property ext 'pointer gnus-xmas-pointer-glyph)
747 beg (point-max) 'gnus-type type)) 726 ext))
748 (setq beg (point)) 727
749 (forward-char) 728 (defvar gnus-xmas-modeline-right-extent
750 (if hide 729 (let ((ext (copy-extent modeline-buffer-id-right-extent)))
751 (gnus-hide-text beg (point) gnus-hidden-properties) 730 ;(set-extent-property ext 'pointer gnus-xmas-pointer-glyph)
752 (gnus-unhide-text beg (point))) 731 ext))
753 (setq beg (point))) 732
754 (save-window-excursion 733 (defvar gnus-xmas-modeline-glyph
755 (select-window (get-buffer-window (current-buffer))) 734 (progn
756 (recenter)) 735 (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
757 t))) 736 (let* ((file (concat gnus-xmas-glyph-directory "gnus-pointer."
737 (if (featurep 'xpm) "xpm" "xbm")))
738 (glyph (make-glyph file)))
739 (when (and (featurep 'x)
740 (file-exists-p file))
741 (set-glyph-face glyph 'modeline-buffer-id))
742 (set-glyph-property glyph 'image (cons 'tty "Gnus:"))
743 glyph)))
758 744
759 (defun gnus-xmas-mode-line-buffer-identification (line) 745 (defun gnus-xmas-mode-line-buffer-identification (line)
760 (let ((line (car line)) 746 (let ((line (car line))
761 chop) 747 chop)
762 (if (not (stringp line)) 748 (if (not (stringp line))
763 (list line) 749 (list line)
764 (unless (setq chop (string-match ":" line)) 750 (when (string-match "^Gnus:" line)
765 (setq chop (/ (length line) 2))) 751 (setq chop (match-end 0))
766 (list (cons modeline-buffer-id-left-extent (substring line 0 chop)) 752 (list
767 (cons modeline-buffer-id-right-extent (substring line chop)))))) 753 (if gnus-xmas-modeline-glyph
754 (cons gnus-xmas-modeline-left-extent gnus-xmas-modeline-glyph)
755 (cons gnus-xmas-modeline-left-extent (substring line 0 chop)))
756 (cons gnus-xmas-modeline-right-extent (substring line chop)))))))
757
758 (defun gnus-xmas-splash ()
759 (when (eq (device-type) 'x)
760 (gnus-splash)))
768 761
769 (provide 'gnus-xmas) 762 (provide 'gnus-xmas)
770 763
771 ;;; gnus-xmas.el ends here 764 ;;; gnus-xmas.el ends here