Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-xmas.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents 8d2a9b52c682
children 821dec489c24
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; gnus-xmas.el --- Gnus functions for XEmacs 1 ;;; gnus-xmas.el --- Gnus functions for XEmacs
2 ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2 ;; Copyright (C) 1995,96 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))
29 (defvar menu-bar-mode (featurep 'menubar)) 30 (defvar menu-bar-mode (featurep 'menubar))
30 (require 'messagexmas) 31 (require 'messagexmas)
31 32
32 (defvar gnus-xmas-glyph-directory nil 33 (defvar gnus-xmas-glyph-directory nil
33 "*Directory where Gnus logos and icons are located. 34 "*Directory where Gnus logos and icons are located.
34 If this variable is nil, Gnus will try to locate the directory 35 If this variable is nil, Gnus will try to locate the directory
35 automatically.") 36 automatically.")
36 37
37 (defvar gnus-xmas-logo-color-alist 38 (defvar gnus-xmas-logo-color-alist
38 '((flame "#cc3300" "#ff2200") 39 '((flame "#cc3300" "#ff2200")
39 (pine "#c0cc93" "#f8ffb8") 40 (pine "#c0cc93" "#f8ffb8")
40 (moss "#a1cc93" "#d2ffb8") 41 (moss "#a1cc93" "#d2ffb8")
41 (irish "#04cc90" "#05ff97") 42 (irish "#04cc90" "#05ff97")
42 (sky "#049acc" "#05deff") 43 (sky "#049acc" "#05deff")
43 (tin "#6886cc" "#82b6ff") 44 (tin "#6886cc" "#82b6ff")
44 (velvet "#7c68cc" "#8c82ff") 45 (velvet "#7c68cc" "#8c82ff")
47 (berry "#cc6485" "#ff7db5") 48 (berry "#cc6485" "#ff7db5")
48 (neutral "#b4b4b4" "#878787") 49 (neutral "#b4b4b4" "#878787")
49 (september "#bf9900" "#ffcc00")) 50 (september "#bf9900" "#ffcc00"))
50 "Color alist used for the Gnus logo.") 51 "Color alist used for the Gnus logo.")
51 52
52 (defvar gnus-xmas-logo-color-style 'flame 53 (defvar gnus-xmas-logo-color-style 'september
53 "Color styles used for the Gnus logo.") 54 "Color styles used for the Gnus logo.")
54 55
55 (defvar gnus-xmas-logo-colors 56 (defvar gnus-xmas-logo-colors
56 (cdr (assq gnus-xmas-logo-color-style gnus-xmas-logo-color-alist)) 57 (cdr (assq gnus-xmas-logo-color-style gnus-xmas-logo-color-alist))
57 "Colors used for the Gnus logo.") 58 "Colors used for the Gnus logo.")
115 (defvar gnus-tree-minimize-window) 116 (defvar gnus-tree-minimize-window)
116 117
117 (defun gnus-xmas-set-text-properties (start end props &optional buffer) 118 (defun gnus-xmas-set-text-properties (start end props &optional buffer)
118 "You should NEVER use this function. It is ideologically blasphemous. 119 "You should NEVER use this function. It is ideologically blasphemous.
119 It is provided only to ease porting of broken FSF Emacs programs." 120 It is provided only to ease porting of broken FSF Emacs programs."
120 (if (stringp buffer) 121 (if (stringp buffer)
121 nil 122 nil
122 (map-extents (lambda (extent ignored) 123 (map-extents (lambda (extent ignored)
123 (remove-text-properties 124 (remove-text-properties
124 start end 125 start end
125 (list (extent-property extent 'text-prop) nil) 126 (list (extent-property extent 'text-prop) nil)
126 buffer)) 127 buffer))
127 buffer start end nil nil 'text-prop) 128 buffer start end nil nil 'text-prop)
128 (gnus-add-text-properties start end props buffer))) 129 (gnus-add-text-properties start end props buffer)))
129 130
130 (defun gnus-xmas-highlight-selected-summary () 131 (defun gnus-xmas-highlight-selected-summary ()
131 ;; Highlight selected article in summary buffer 132 ;; Highlight selected article in summary buffer
132 (when gnus-summary-selected-face 133 (when gnus-summary-selected-face
133 (when gnus-newsgroup-selected-overlay 134 (if gnus-newsgroup-selected-overlay
134 (delete-extent gnus-newsgroup-selected-overlay)) 135 (delete-extent gnus-newsgroup-selected-overlay))
135 (setq gnus-newsgroup-selected-overlay 136 (setq gnus-newsgroup-selected-overlay
136 (make-extent (gnus-point-at-bol) (gnus-point-at-eol))) 137 (make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
137 (set-extent-face gnus-newsgroup-selected-overlay 138 (set-extent-face gnus-newsgroup-selected-overlay
138 gnus-summary-selected-face))) 139 gnus-summary-selected-face)))
139
140 (defvar gnus-xmas-force-redisplay nil
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'.")
143
144 (defun gnus-xmas-switch-horizontal-scrollbar-off ()
145 (when (featurep 'scrollbar)
146 (set-specifier scrollbar-height (cons (current-buffer) 0))))
147 140
148 (defun gnus-xmas-summary-recenter () 141 (defun gnus-xmas-summary-recenter ()
149 "\"Center\" point in the summary window. 142 "\"Center\" point in the summary window.
150 If `gnus-auto-center-summary' is nil, or the article buffer isn't 143 If `gnus-auto-center-summary' is nil, or the article buffer isn't
151 displayed, no centering will be performed." 144 displayed, no centering will be performed."
152 ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle). 145 ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle).
153 ;; Recenter only when requested. Suggested by popovich@park.cs.columbia.edu. 146 ;; Recenter only when requested. Suggested by popovich@park.cs.columbia.edu.
154 ;; Force redisplay to get properly computed window height.
155 (when gnus-xmas-force-redisplay
156 (sit-for 0))
157 (when gnus-auto-center-summary 147 (when gnus-auto-center-summary
158 (let* ((height (if (fboundp 'window-displayed-height) 148 (let* ((height (if (fboundp 'window-displayed-height)
159 (window-displayed-height) 149 (window-displayed-height)
160 (- (window-height) 2))) 150 (- (window-height) 2)))
161 (top (cond ((< height 4) 0) 151 (top (cond ((< height 4) 0)
169 ;; Only do recentering when the article buffer is displayed, 159 ;; Only do recentering when the article buffer is displayed,
170 ;; Set the window start to either `bottom', which is the biggest 160 ;; Set the window start to either `bottom', which is the biggest
171 ;; possible valid number, or the second line from the top, 161 ;; possible valid number, or the second line from the top,
172 ;; whichever is the least. 162 ;; whichever is the least.
173 (set-window-start 163 (set-window-start
174 window (min bottom (save-excursion (forward-line (- top)) (point))))) 164 window (min bottom (save-excursion
165 (forward-line (- top)) (point)))))
175 ;; Do horizontal recentering while we're at it. 166 ;; Do horizontal recentering while we're at it.
176 (when (and (get-buffer-window (current-buffer) t) 167 (when (and (get-buffer-window (current-buffer) t)
177 (not (eq gnus-auto-center-summary 'vertical))) 168 (not (eq gnus-auto-center-summary 'vertical)))
178 (let ((selected (selected-window))) 169 (let ((selected (selected-window)))
179 (select-window (get-buffer-window (current-buffer) t)) 170 (select-window (get-buffer-window (current-buffer) t))
180 (gnus-summary-position-point) 171 (gnus-summary-position-point)
181 (gnus-horizontal-recenter) 172 (gnus-horizontal-recenter)
182 (select-window selected)))))) 173 (select-window selected))))))
183 174
184 (defun gnus-xmas-summary-set-display-table ()
185 ;; Setup the display table -- like gnus-summary-setup-display-table,
186 ;; but done in an XEmacsish way.
187 (let ((table (make-display-table))
188 ;; Nix out all the control chars...
189 (i 32))
190 (while (>= (setq i (1- i)) 0)
191 (aset table i [??]))
192 ;; ... but not newline and cr, of course. (cr is necessary for the
193 ;; selective display).
194 (aset table ?\n nil)
195 (aset table ?\r nil)
196 ;; We nix out any glyphs over 126 that are not set already.
197 (let ((i 256))
198 (while (>= (setq i (1- i)) 127)
199 ;; Only modify if the entry is nil.
200 (or (aref table i)
201 (aset table i [??]))))
202 (add-spec-to-specifier current-display-table table (current-buffer) nil)))
203
204 (defun gnus-xmas-add-hook (hook function &optional append local) 175 (defun gnus-xmas-add-hook (hook function &optional append local)
205 (add-hook hook function)) 176 (add-hook hook function))
206 177
207 (defun gnus-xmas-add-text-properties (start end props &optional object) 178 (defun gnus-xmas-add-text-properties (start end props &optional object)
208 (add-text-properties start end props object) 179 (add-text-properties start end props object)
214 185
215 (defun gnus-xmas-extent-start-open (point) 186 (defun gnus-xmas-extent-start-open (point)
216 (map-extents (lambda (extent arg) 187 (map-extents (lambda (extent arg)
217 (set-extent-property extent 'start-open t)) 188 (set-extent-property extent 'start-open t))
218 nil point (min (1+ (point)) (point-max)))) 189 nil point (min (1+ (point)) (point-max))))
219 190
220 (defun gnus-xmas-article-push-button (event) 191 (defun gnus-xmas-article-push-button (event)
221 "Check text under the mouse pointer for a callback function. 192 "Check text under the mouse pointer for a callback function.
222 If the text under the mouse pointer has a `gnus-callback' property, 193 If the text under the mouse pointer has a `gnus-callback' property,
223 call it with the value of the `gnus-data' text property." 194 call it with the value of the `gnus-data' text property."
224 (interactive "e") 195 (interactive "e")
225 (set-buffer (window-buffer (event-window event))) 196 (set-buffer (window-buffer (event-window event)))
226 (let* ((pos (event-closest-point event)) 197 (let* ((pos (event-closest-point event))
227 (data (get-text-property pos 'gnus-data)) 198 (data (get-text-property pos 'gnus-data))
228 (fun (get-text-property pos 'gnus-callback))) 199 (fun (get-text-property pos 'gnus-callback)))
229 (when fun 200 (if fun (funcall fun data))))
230 (funcall fun data))))
231 201
232 (defun gnus-xmas-move-overlay (extent start end &optional buffer) 202 (defun gnus-xmas-move-overlay (extent start end &optional buffer)
233 (set-extent-endpoints extent start end)) 203 (set-extent-endpoints extent start end))
234 204
235 ;; Fixed by Christopher Davis <ckd@loiosh.kei.com>. 205 ;; Fixed by Christopher Davis <ckd@loiosh.kei.com>.
236 (defun gnus-xmas-article-add-button (from to fun &optional data) 206 (defun gnus-xmas-article-add-button (from to fun &optional data)
237 "Create a button between FROM and TO with callback FUN and data DATA." 207 "Create a button between FROM and TO with callback FUN and data DATA."
238 (when gnus-article-button-face 208 (and gnus-article-button-face
239 (gnus-overlay-put (gnus-make-overlay from to) 209 (gnus-overlay-put (gnus-make-overlay from to)
240 'face gnus-article-button-face)) 210 'face gnus-article-button-face))
241 (gnus-add-text-properties 211 (gnus-add-text-properties
242 from to 212 from to
243 (nconc 213 (nconc
244 (and gnus-article-mouse-face 214 (and gnus-article-mouse-face
245 (list 'mouse-face gnus-article-mouse-face)) 215 (list 'mouse-face gnus-article-mouse-face))
246 (list 'gnus-callback fun) 216 (list 'gnus-callback fun)
274 (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges)))))) 244 (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
275 (last-window (previous-window)) 245 (last-window (previous-window))
276 (window-search t)) 246 (window-search t))
277 (while window-search 247 (while window-search
278 (let* ((this-window (next-window)) 248 (let* ((this-window (next-window))
279 (next-bottom-edge (car (cdr (cdr (cdr 249 (next-bottom-edge (car (cdr (cdr (cdr
280 (window-pixel-edges 250 (window-pixel-edges
281 this-window))))))) 251 this-window)))))))
282 (when (< bottom-edge next-bottom-edge) 252 (if (< bottom-edge next-bottom-edge)
283 (setq bottom-edge next-bottom-edge) 253 (progn
284 (setq lowest-window this-window)) 254 (setq bottom-edge next-bottom-edge)
255 (setq lowest-window this-window)))
285 256
286 (select-window this-window) 257 (select-window this-window)
287 (when (eq last-window this-window) 258 (if (eq last-window this-window)
288 (select-window lowest-window) 259 (progn
289 (setq window-search nil)))))) 260 (select-window lowest-window)
261 (setq window-search nil)))))))
290 262
291 (defmacro gnus-xmas-menu-add (type &rest menus) 263 (defmacro gnus-xmas-menu-add (type &rest menus)
292 `(gnus-xmas-menu-add-1 ',type ',menus)) 264 `(gnus-xmas-menu-add-1 ',type ',menus))
293 (put 'gnus-xmas-menu-add 'lisp-indent-function 1) 265 (put 'gnus-xmas-menu-add 'lisp-indent-function 1)
266 (put 'gnus-xmas-menu-add 'lisp-indent-hook 1)
294 267
295 (defun gnus-xmas-menu-add-1 (type menus) 268 (defun gnus-xmas-menu-add-1 (type menus)
296 (when (and menu-bar-mode 269 (when (and menu-bar-mode
297 (gnus-visual-p (intern (format "%s-menu" type)) 'menu)) 270 (gnus-visual-p (intern (format "%s-menu" type)) 'menu))
298 (while menus 271 (while menus
318 291
319 (defun gnus-xmas-pick-menu-add () 292 (defun gnus-xmas-pick-menu-add ()
320 (gnus-xmas-menu-add pick 293 (gnus-xmas-menu-add pick
321 gnus-pick-menu)) 294 gnus-pick-menu))
322 295
323 (defun gnus-xmas-topic-menu-add ()
324 (gnus-xmas-menu-add topic
325 gnus-topic-menu))
326
327 (defun gnus-xmas-binary-menu-add () 296 (defun gnus-xmas-binary-menu-add ()
328 (gnus-xmas-menu-add binary 297 (gnus-xmas-menu-add binary
329 gnus-binary-menu)) 298 gnus-binary-menu))
330 299
331 (defun gnus-xmas-tree-menu-add () 300 (defun gnus-xmas-tree-menu-add ()
344 (gnus-xmas-menu-add grouplens 313 (gnus-xmas-menu-add grouplens
345 gnus-grouplens-menu)) 314 gnus-grouplens-menu))
346 315
347 (defun gnus-xmas-read-event-char () 316 (defun gnus-xmas-read-event-char ()
348 "Get the next event." 317 "Get the next event."
349 (let ((event (next-command-event))) 318 (let ((event (next-event)))
350 (sit-for 0)
351 ;; We junk all non-key events. Is this naughty? 319 ;; We junk all non-key events. Is this naughty?
352 (while (not (or (key-press-event-p event) 320 (while (not (key-press-event-p event))
353 (button-press-event-p event))) 321 (setq event (next-event)))
354 (dispatch-event event) 322 (cons (and (key-press-event-p event)
355 (setq event (next-command-event))) 323 ; (numberp (event-key event))
356 (cons (and (key-press-event-p event) 324 (event-to-character event))
357 (event-to-character event))
358 event))) 325 event)))
359 326
360 (defun gnus-xmas-group-remove-excess-properties () 327 (defun gnus-xmas-group-remove-excess-properties ()
361 (let ((end (point)) 328 (let ((end (point))
362 (beg (progn (forward-line -1) (point)))) 329 (beg (progn (forward-line -1) (point))))
363 (remove-text-properties (1+ beg) end '(gnus-group nil)) 330 (remove-text-properties (1+ beg) end '(gnus-group nil))
364 (remove-text-properties 331 (remove-text-properties
365 beg end 332 beg end
366 '(gnus-topic nil gnus-topic-level nil gnus-topic-visible nil)) 333 '(gnus-topic nil gnus-topic-level nil gnus-topic-visible nil))
367 (goto-char end) 334 (goto-char end)
368 (map-extents 335 (map-extents
369 (lambda (e ma) 336 (lambda (e ma)
370 (set-extent-property e 'start-closed t)) 337 (set-extent-property e 'start-closed t))
371 (current-buffer) beg end))) 338 (current-buffer) beg end)))
372 339
373 (defun gnus-xmas-topic-remove-excess-properties () 340 (defun gnus-xmas-topic-remove-excess-properties ()
374 (let ((end (point)) 341 (let ((end (point))
375 (beg (progn (forward-line -1) (point)))) 342 (beg (progn (forward-line -1) (point))))
376 (remove-text-properties beg end '(gnus-group nil gnus-unread nil)) 343 (remove-text-properties beg end '(gnus-group nil gnus-unread nil))
377 (remove-text-properties (1+ beg) end '(gnus-topic nil)) 344 (remove-text-properties (1+ beg) end '(gnus-topic nil))
384 (ttime (mapcar (lambda (ti) (and ti (string-to-int ti))) 351 (ttime (mapcar (lambda (ti) (and ti (string-to-int ti)))
385 (timezone-parse-time 352 (timezone-parse-time
386 (aref (timezone-parse-date date) 3)))) 353 (aref (timezone-parse-date date) 3))))
387 (edate (mapcar (lambda (ti) (and ti (string-to-int ti))) 354 (edate (mapcar (lambda (ti) (and ti (string-to-int ti)))
388 (timezone-parse-date "Jan 1 12:00:00 1970"))) 355 (timezone-parse-date "Jan 1 12:00:00 1970")))
389 (tday (- (timezone-absolute-from-gregorian 356 (tday (- (timezone-absolute-from-gregorian
390 (nth 1 tdate) (nth 2 tdate) (nth 0 tdate)) 357 (nth 1 tdate) (nth 2 tdate) (nth 0 tdate))
391 (timezone-absolute-from-gregorian 358 (timezone-absolute-from-gregorian
392 (nth 1 edate) (nth 2 edate) (nth 0 edate))))) 359 (nth 1 edate) (nth 2 edate) (nth 0 edate)))))
393 (+ (nth 2 ttime) 360 (+ (nth 2 ttime)
394 (* (nth 1 ttime) 60) 361 (* (nth 1 ttime) 60)
395 (* (float (nth 0 ttime)) 60 60) 362 (* (float (nth 0 ttime)) 60 60)
396 (* (float tday) 60 60 24)))) 363 (* (float tday) 60 60 24))))
397 364
398 (defun gnus-xmas-define () 365 (defun gnus-xmas-define ()
399 (setq gnus-mouse-2 [button2]) 366 (setq gnus-mouse-2 [button2])
400 367
401 (unless (memq 'underline (face-list)) 368 (or (memq 'underline (face-list))
402 (and (fboundp 'make-face) 369 (and (fboundp 'make-face)
403 (funcall (intern "make-face") 'underline))) 370 (funcall (intern "make-face") 'underline)))
404 ;; Must avoid calling set-face-underline-p directly, because it 371 ;; Must avoid calling set-face-underline-p directly, because it
405 ;; is a defsubst in emacs19, and will make the .elc files non 372 ;; is a defsubst in emacs19, and will make the .elc files non
406 ;; portable! 373 ;; portable!
407 (unless (face-differs-from-default-p 'underline) 374 (or (face-differs-from-default-p 'underline)
408 (funcall (intern "set-face-underline-p") 'underline t)) 375 (funcall (intern "set-face-underline-p") 'underline t))
409
410 (cond
411 ((fboundp 'char-or-char-int-p)
412 ;; Handle both types of marks for XEmacs-20.x.
413 (fset 'gnus-characterp 'char-or-char-int-p))
414 ;; V19 of XEmacs, probably.
415 (t
416 (fset 'gnus-characterp 'characterp)))
417 376
418 (fset 'gnus-make-overlay 'make-extent) 377 (fset 'gnus-make-overlay 'make-extent)
419 (fset 'gnus-overlay-put 'set-extent-property) 378 (fset 'gnus-overlay-put 'set-extent-property)
420 (fset 'gnus-move-overlay 'gnus-xmas-move-overlay) 379 (fset 'gnus-move-overlay 'gnus-xmas-move-overlay)
421 (fset 'gnus-overlay-end 'extent-end-position) 380 (fset 'gnus-overlay-end 'extent-end-position)
422 (fset 'gnus-extent-detached-p 'extent-detached-p) 381 (fset 'gnus-extent-detached-p 'extent-detached-p)
423 (fset 'gnus-add-text-properties 'gnus-xmas-add-text-properties) 382 (fset 'gnus-add-text-properties 'gnus-xmas-add-text-properties)
424 (fset 'gnus-put-text-property 'gnus-xmas-put-text-property) 383 (fset 'gnus-put-text-property 'gnus-xmas-put-text-property)
425 384
426 (require 'text-props) 385 (require 'text-props)
427 (if (and (<= emacs-major-version 19) 386 (if (< emacs-minor-version 14)
428 (< emacs-minor-version 14))
429 (fset 'gnus-set-text-properties 'gnus-xmas-set-text-properties)) 387 (fset 'gnus-set-text-properties 'gnus-xmas-set-text-properties))
430 388
431 (when (fboundp 'turn-off-scroll-in-place) 389 (or (boundp 'standard-display-table) (setq standard-display-table nil))
432 (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place))
433
434 (unless (boundp 'standard-display-table)
435 (setq standard-display-table nil))
436 390
437 (defvar gnus-mouse-face-prop 'highlight) 391 (defvar gnus-mouse-face-prop 'highlight)
438 392
439 (unless (fboundp 'encode-time) 393 (unless (fboundp 'encode-time)
440 (defun encode-time (sec minute hour day month year &optional zone) 394 (defun encode-time (sec minute hour day month year &optional zone)
441 (let ((seconds 395 (let ((seconds
442 (gnus-xmas-seconds-since-epoch 396 (gnus-xmas-seconds-since-epoch
443 (timezone-make-arpa-date 397 (timezone-make-arpa-date
444 year month day (timezone-make-time-string hour minute sec) 398 year month day (timezone-make-time-string hour minute sec)
445 zone)))) 399 zone))))
446 (list (floor (/ seconds (expt 2 16))) 400 (list (floor (/ seconds (expt 2 16)))
447 (round (mod seconds (expt 2 16))))))) 401 (round (mod seconds (expt 2 16)))))))
448 402
449 (defun gnus-byte-code (func) 403 (defun gnus-byte-code (func)
450 "Return a form that can be `eval'ed based on FUNC." 404 "Return a form that can be `eval'ed based on FUNC."
451 (let ((fval (symbol-function func))) 405 (let ((fval (symbol-function func)))
452 (if (compiled-function-p fval) 406 (if (compiled-function-p fval)
453 (list 'funcall fval) 407 (list 'funcall fval)
454 (cons 'progn (cdr (cdr fval)))))) 408 (cons 'progn (cdr (cdr fval))))))
455 409
456 (fset 'gnus-x-color-values 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
423 (fset 'gnus-x-color-values
457 (if (fboundp 'x-color-values) 424 (if (fboundp 'x-color-values)
458 'x-color-values 425 'x-color-values
459 (lambda (color) 426 (lambda (color)
460 (color-instance-rgb-components 427 (color-instance-rgb-components
461 (make-color-instance color)))))) 428 (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
462 461
463 (defun gnus-xmas-redefine () 462 (defun gnus-xmas-redefine ()
464 "Redefine lots of Gnus functions for XEmacs." 463 "Redefine lots of Gnus functions for XEmacs."
465 (fset 'gnus-summary-set-display-table 'gnus-xmas-summary-set-display-table) 464 (fset 'gnus-summary-make-display-table 'ignore)
466 (fset 'gnus-visual-turn-off-edit-menu 'identity) 465 (fset 'gnus-visual-turn-off-edit-menu 'identity)
467 (fset 'gnus-summary-recenter 'gnus-xmas-summary-recenter) 466 (fset 'gnus-summary-recenter 'gnus-xmas-summary-recenter)
468 (fset 'gnus-extent-start-open 'gnus-xmas-extent-start-open) 467 (fset 'gnus-extent-start-open 'gnus-xmas-extent-start-open)
469 (fset 'gnus-article-push-button 'gnus-xmas-article-push-button) 468 (fset 'gnus-article-push-button 'gnus-xmas-article-push-button)
470 (fset 'gnus-article-add-button 'gnus-xmas-article-add-button) 469 (fset 'gnus-article-add-button 'gnus-xmas-article-add-button)
471 (fset 'gnus-window-top-edge 'gnus-xmas-window-top-edge) 470 (fset 'gnus-window-top-edge 'gnus-xmas-window-top-edge)
472 (fset 'gnus-read-event-char 'gnus-xmas-read-event-char) 471 (fset 'gnus-read-event-char 'gnus-xmas-read-event-char)
473 (fset 'gnus-group-startup-message 'gnus-xmas-group-startup-message) 472 (fset 'gnus-group-startup-message 'gnus-xmas-group-startup-message)
474 (fset 'gnus-tree-minimize 'gnus-xmas-tree-minimize) 473 (fset 'gnus-tree-minimize 'gnus-xmas-tree-minimize)
475 (fset 'gnus-appt-select-lowest-window 474 (fset 'gnus-appt-select-lowest-window
476 'gnus-xmas-appt-select-lowest-window) 475 'gnus-xmas-appt-select-lowest-window)
477 (fset 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names) 476 (fset 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names)
477 (fset 'gnus-make-local-hook 'make-local-variable)
478 (fset 'gnus-add-hook 'gnus-xmas-add-hook) 478 (fset 'gnus-add-hook 'gnus-xmas-add-hook)
479 (fset 'gnus-character-to-event 'character-to-event) 479 (fset 'gnus-character-to-event 'character-to-event)
480 (fset 'gnus-article-show-hidden-text 'gnus-xmas-article-show-hidden-text)
480 (fset 'gnus-mode-line-buffer-identification 481 (fset 'gnus-mode-line-buffer-identification
481 'gnus-xmas-mode-line-buffer-identification) 482 'gnus-xmas-mode-line-buffer-identification)
482 (fset 'gnus-key-press-event-p 'key-press-event-p)
483 (fset 'gnus-region-active-p 'region-active-p)
484 483
485 (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add) 484 (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add)
486 (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add) 485 (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add)
487 (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add) 486 (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add)
488 (add-hook 'gnus-score-mode-hook 'gnus-xmas-score-menu-add) 487 (add-hook 'gnus-score-mode-hook 'gnus-xmas-score-menu-add)
489 488
490 (add-hook 'gnus-pick-mode-hook 'gnus-xmas-pick-menu-add) 489 (add-hook 'gnus-pick-mode-hook 'gnus-xmas-pick-menu-add)
491 (add-hook 'gnus-topic-mode-hook 'gnus-xmas-topic-menu-add)
492 (add-hook 'gnus-tree-mode-hook 'gnus-xmas-tree-menu-add) 490 (add-hook 'gnus-tree-mode-hook 'gnus-xmas-tree-menu-add)
493 (add-hook 'gnus-binary-mode-hook 'gnus-xmas-binary-menu-add) 491 (add-hook 'gnus-binary-mode-hook 'gnus-xmas-binary-menu-add)
494 (add-hook 'gnus-grouplens-mode-hook 'gnus-xmas-grouplens-menu-add) 492 (add-hook 'gnus-grouplens-mode-hook 'gnus-xmas-grouplens-menu-add)
495 (add-hook 'gnus-server-mode-hook 'gnus-xmas-server-menu-add) 493 (add-hook 'gnus-server-mode-hook 'gnus-xmas-server-menu-add)
496 (add-hook 'gnus-browse-mode-hook 'gnus-xmas-browse-menu-add) 494 (add-hook 'gnus-browse-mode-hook 'gnus-xmas-browse-menu-add)
497 495
498 (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar) 496 (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar)
499 (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar) 497 (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar)
500 498
501 (add-hook 'gnus-summary-mode-hook 'gnus-xmas-switch-horizontal-scrollbar-off)
502
503 (when (and (<= emacs-major-version 19) 499 (when (and (<= emacs-major-version 19)
504 (<= emacs-minor-version 13)) 500 (<= emacs-minor-version 13))
505 (setq gnus-article-x-face-too-ugly (when (eq (device-type) 'tty) 501 (setq gnus-article-x-face-too-ugly (if (eq (device-type) 'tty) "."))
506 "."))
507 (fset 'gnus-highlight-selected-summary 502 (fset 'gnus-highlight-selected-summary
508 'gnus-xmas-highlight-selected-summary) 503 'gnus-xmas-highlight-selected-summary)
509 (fset 'gnus-group-remove-excess-properties 504 (fset 'gnus-group-remove-excess-properties
510 'gnus-xmas-group-remove-excess-properties) 505 'gnus-xmas-group-remove-excess-properties)
511 (fset 'gnus-topic-remove-excess-properties 506 (fset 'gnus-topic-remove-excess-properties
512 'gnus-xmas-topic-remove-excess-properties) 507 'gnus-xmas-topic-remove-excess-properties)
513 (fset 'gnus-mode-line-buffer-identification 'identity) 508 (fset 'gnus-mode-line-buffer-identification 'identity)
514 (unless (boundp 'shell-command-switch) 509 (unless (boundp 'shell-command-switch)
515 (setq shell-command-switch "-c")))) 510 (setq shell-command-switch "-c"))
511 ))
516 512
517 513
518 ;;; XEmacs logo and toolbar. 514 ;;; XEmacs logo and toolbar.
519 515
520 (defun gnus-xmas-group-startup-message (&optional x y) 516 (defun gnus-xmas-group-startup-message (&optional x y)
521 "Insert startup message in current buffer." 517 "Insert startup message in current buffer."
522 ;; Insert the message. 518 ;; Insert the message.
523 (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus")) 519 (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
524 (erase-buffer) 520 (erase-buffer)
525 (let ((logo (and gnus-xmas-glyph-directory 521 (let ((logo (and gnus-xmas-glyph-directory
526 (concat 522 (concat
527 (file-name-as-directory gnus-xmas-glyph-directory) 523 (file-name-as-directory gnus-xmas-glyph-directory)
528 "gnus." 524 "gnus."
529 (if (featurep 'xpm) "xpm" "xbm")))) 525 (if (featurep 'xpm) "xpm" "xbm"))))
530 (xpm-color-symbols 526 (xpm-color-symbols
531 (and (featurep 'xpm) 527 (and (featurep 'xpm)
532 (append `(("thing" ,(car gnus-xmas-logo-colors)) 528 (append `(("thing" ,(car gnus-xmas-logo-colors))
533 ("shadow" ,(cadr gnus-xmas-logo-colors))) 529 ("shadow" ,(cadr gnus-xmas-logo-colors)))
534 xpm-color-symbols)))) 530 xpm-color-symbols))))
535 (if (and (featurep 'xpm) 531 (if (and (featurep 'xpm)
551 (rest (- wheight pheight))) 547 (rest (- wheight pheight)))
552 (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))) 548 (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
553 549
554 (insert 550 (insert
555 (format " %s 551 (format " %s
556 _ ___ _ _ 552 _ ___ _ _
557 _ ___ __ ___ __ _ ___ 553 _ ___ __ ___ __ _ ___
558 __ _ ___ __ ___ 554 __ _ ___ __ ___
559 _ ___ _ 555 _ ___ _
560 _ _ __ _ 556 _ _ __ _
561 ___ __ _ 557 ___ __ _
562 __ _ 558 __ _
563 _ _ _ 559 _ _ _
564 _ _ _ 560 _ _ _
565 _ _ _ 561 _ _ _
566 __ ___ 562 __ ___
567 _ _ _ _ 563 _ _ _ _
568 _ _ 564 _ _
569 _ _ 565 _ _
570 _ _ 566 _ _
571 _ 567 _
572 __ 568 __
573 569
574 " 570 "
575 "")) 571 ""))
576 ;; And then hack it. 572 ;; And then hack it.
577 (gnus-indent-rigidly (point-min) (point-max) 573 (gnus-indent-rigidly (point-min) (point-max)
578 (/ (max (- (window-width) (or x 46)) 0) 2)) 574 (/ (max (- (window-width) (or x 46)) 0) 2))
579 (goto-char (point-min)) 575 (goto-char (point-min))
580 (forward-line 1) 576 (forward-line 1)
581 (let* ((pheight (count-lines (point-min) (point-max))) 577 (let* ((pheight (count-lines (point-min) (point-max)))
582 (wheight (window-height)) 578 (wheight (window-height))
583 (rest (- wheight pheight))) 579 (rest (- wheight pheight)))
584 (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))) 580 (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
585 ;; Fontify some. 581 ;; Fontify some.
586 (goto-char (point-min)) 582 (goto-char (point-min))
587 (put-text-property (point-min) (point-max) 'face 'gnus-splash-face) 583 (and (search-forward "Praxis" nil t)
584 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
588 (goto-char (point-min)) 585 (goto-char (point-min))
589 (setq modeline-buffer-identification 586 (let* ((mode-string (gnus-group-set-mode-line)))
590 (list (concat gnus-version ": *Group*"))) 587 (setq modeline-buffer-identification
591 (set-buffer-modified-p t))) 588 (list (concat gnus-version ": *Group*")))
589 (set-buffer-modified-p t))))
592 590
593 591
594 ;;; The toolbar. 592 ;;; The toolbar.
595 593
596 (defvar gnus-use-toolbar (if (featurep 'toolbar) 594 (defvar gnus-use-toolbar (if (featurep 'toolbar)
599 "*If nil, do not use a toolbar. 597 "*If nil, do not use a toolbar.
600 If it is non-nil, it must be a toolbar. The five legal values are 598 If it is non-nil, it must be a toolbar. The five legal values are
601 `default-toolbar', `top-toolbar', `bottom-toolbar', 599 `default-toolbar', `top-toolbar', `bottom-toolbar',
602 `right-toolbar', and `left-toolbar'.") 600 `right-toolbar', and `left-toolbar'.")
603 601
604 (defvar gnus-group-toolbar 602 (defvar gnus-group-toolbar
605 '([gnus-group-get-new-news gnus-group-get-new-news t "Get new news"] 603 '(
606 [gnus-group-get-new-news-this-group 604 [gnus-group-get-new-news gnus-group-get-new-news t "Get new news"]
605 [gnus-group-get-new-news-this-group
607 gnus-group-get-new-news-this-group t "Get new news in this group"] 606 gnus-group-get-new-news-this-group t "Get new news in this group"]
608 [gnus-group-catchup-current 607 [gnus-group-catchup-current
609 gnus-group-catchup-current t "Catchup group"] 608 gnus-group-catchup-current t "Catchup group"]
610 [gnus-group-describe-group 609 [gnus-group-describe-group
611 gnus-group-describe-group t "Describe group"] 610 gnus-group-describe-group t "Describe group"]
612 [gnus-group-unsubscribe gnus-group-unsubscribe t "Unsubscribe group"]
613 [gnus-group-subscribe gnus-group-subscribe t "Subscribe group"]
614 [gnus-group-kill-group gnus-group-kill-group t "Kill group"] 611 [gnus-group-kill-group gnus-group-kill-group t "Kill group"]
615 [gnus-group-exit gnus-group-exit t "Exit Gnus"] 612 [gnus-group-exit gnus-group-exit t "Exit Gnus"]
616 ) 613 )
617 "The group buffer toolbar.") 614 "The group buffer toolbar.")
618 615
619 (defvar gnus-summary-toolbar 616 (defvar gnus-summary-toolbar
620 '([gnus-summary-prev-unread 617 '(
621 gnus-summary-prev-page-or-article t "Page up"] 618 [gnus-summary-prev-unread
622 [gnus-summary-next-unread 619 gnus-summary-prev-unread-article t "Prev unread article"]
623 gnus-summary-next-page t "Page down"] 620 [gnus-summary-next-unread
624 [gnus-summary-post-news 621 gnus-summary-next-unread-article t "Next unread article"]
622 [gnus-summary-post-news
625 gnus-summary-post-news t "Post an article"] 623 gnus-summary-post-news t "Post an article"]
626 [gnus-summary-followup-with-original 624 [gnus-summary-followup-with-original
627 gnus-summary-followup-with-original t 625 gnus-summary-followup-with-original t
628 "Post a followup and yank the original"] 626 "Post a followup and yank the original"]
629 [gnus-summary-followup 627 [gnus-summary-followup
630 gnus-summary-followup t "Post a followup"] 628 gnus-summary-followup t "Post a followup"]
631 [gnus-summary-reply-with-original 629 [gnus-summary-reply-with-original
632 gnus-summary-reply-with-original t "Mail a reply and yank the original"] 630 gnus-summary-reply-with-original t "Mail a reply and yank the original"]
633 [gnus-summary-reply 631 [gnus-summary-reply
634 gnus-summary-reply t "Mail a reply"] 632 gnus-summary-reply t "Mail a reply"]
635 [gnus-summary-caesar-message 633 [gnus-summary-caesar-message
636 gnus-summary-caesar-message t "Rot 13"] 634 gnus-summary-caesar-message t "Rot 13"]
637 [gnus-uu-decode-uu 635 [gnus-uu-decode-uu
638 gnus-uu-decode-uu t "Decode uuencoded articles"] 636 gnus-uu-decode-uu t "Decode uuencoded articles"]
639 [gnus-summary-save-article-file 637 [gnus-summary-save-article-file
640 gnus-summary-save-article-file t "Save article in file"] 638 gnus-summary-save-article-file t "Save article in file"]
641 [gnus-summary-save-article 639 [gnus-summary-save-article
642 gnus-summary-save-article t "Save article"] 640 gnus-summary-save-article t "Save article"]
643 [gnus-uu-post-news 641 [gnus-uu-post-news
644 gnus-uu-post-news t "Post an uuencoded article"] 642 gnus-uu-post-news t "Post an uuencoded article"]
645 [gnus-summary-cancel-article 643 [gnus-summary-cancel-article
646 gnus-summary-cancel-article t "Cancel article"] 644 gnus-summary-cancel-article t "Cancel article"]
647 [gnus-summary-catchup
648 gnus-summary-catchup t "Catchup"]
649 [gnus-summary-catchup-and-exit 645 [gnus-summary-catchup-and-exit
650 gnus-summary-catchup-and-exit t "Catchup and exit"] 646 gnus-summary-catchup-and-exit t "Catchup and exit"]
651 [gnus-summary-exit gnus-summary-exit t "Exit this summary"] 647 [gnus-summary-exit gnus-summary-exit t "Exit this summary"]
652 ) 648 )
653 "The summary buffer toolbar.") 649 "The summary buffer toolbar.")
654 650
655 (defvar gnus-summary-mail-toolbar 651 (defvar gnus-summary-mail-toolbar
656 '( 652 '(
657 [gnus-summary-prev-unread 653 [gnus-summary-prev-unread
658 gnus-summary-prev-unread-article t "Prev unread article"] 654 gnus-summary-prev-unread-article t "Prev unread article"]
659 [gnus-summary-next-unread 655 [gnus-summary-next-unread
660 gnus-summary-next-unread-article t "Next unread article"] 656 gnus-summary-next-unread-article t "Next unread article"]
661 [gnus-summary-mail-reply gnus-summary-reply t "Reply"] 657 [gnus-summary-mail-reply gnus-summary-reply t "Reply"]
662 ; [gnus-summary-mail-get gnus-mail-get t "Message get"] 658 [gnus-summary-mail-get gnus-mail-get t "Message get"]
663 [gnus-summary-mail-originate gnus-summary-post-news t "Originate"] 659 [gnus-summary-mail-originate gnus-summary-post-news t "Originate"]
664 [gnus-summary-mail-save gnus-summary-save-article t "Save"] 660 [gnus-summary-mail-save gnus-summary-save-article t "Save"]
665 [gnus-summary-mail-copy gnus-summary-copy-article t "Copy message"] 661 [gnus-summary-mail-copy gnus-summary-copy-article t "Copy message"]
666 ; [gnus-summary-mail-delete gnus-summary-delete-article t "Delete message"] 662 ; [gnus-summary-mail-delete gnus-summary-delete-article t "Delete message"]
667 [gnus-summary-mail-forward gnus-summary-mail-forward t "Forward message"] 663 [gnus-summary-mail-forward gnus-summary-mail-forward t "Forward message"]
673 gnus-uu-decode-uu t "Decode uuencoded articles"] 669 gnus-uu-decode-uu t "Decode uuencoded articles"]
674 [gnus-summary-save-article-file 670 [gnus-summary-save-article-file
675 gnus-summary-save-article-file t "Save article in file"] 671 gnus-summary-save-article-file t "Save article in file"]
676 [gnus-summary-save-article 672 [gnus-summary-save-article
677 gnus-summary-save-article t "Save article"] 673 gnus-summary-save-article t "Save article"]
678 [gnus-summary-catchup
679 gnus-summary-catchup t "Catchup"]
680 [gnus-summary-catchup-and-exit 674 [gnus-summary-catchup-and-exit
681 gnus-summary-catchup-and-exit t "Catchup and exit"] 675 gnus-summary-catchup-and-exit t "Catchup and exit"]
682 [gnus-summary-exit gnus-summary-exit t "Exit this summary"] 676 [gnus-summary-exit gnus-summary-exit t "Exit this summary"]
683 ) 677 )
684 "The summary buffer mail toolbar.") 678 "The summary buffer mail toolbar.")
718 "Display any XFace headers in the current article." 712 "Display any XFace headers in the current article."
719 (save-excursion 713 (save-excursion
720 (let (xface-glyph) 714 (let (xface-glyph)
721 (if (featurep 'xface) 715 (if (featurep 'xface)
722 (setq xface-glyph 716 (setq xface-glyph
723 (make-glyph (vector 'xface :data 717 (make-glyph (vector 'xface :data
724 (concat "X-Face: " 718 (concat "X-Face: "
725 (buffer-substring beg end))))) 719 (buffer-substring beg end)))))
726 (let ((cur (current-buffer))) 720 (let ((cur (current-buffer)))
727 (save-excursion 721 (save-excursion
728 (gnus-set-work-buffer) 722 (gnus-set-work-buffer)
736 (make-glyph 730 (make-glyph
737 (vector 'xpm :data (buffer-string ))))))) 731 (vector 'xpm :data (buffer-string )))))))
738 (set-glyph-face xface-glyph 'gnus-x-face) 732 (set-glyph-face xface-glyph 'gnus-x-face)
739 (goto-char (point-min)) 733 (goto-char (point-min))
740 (re-search-forward "^From:" nil t) 734 (re-search-forward "^From:" nil t)
741 (set-extent-begin-glyph 735 (set-extent-begin-glyph
742 (make-extent (point) (1+ (point))) xface-glyph)))) 736 (make-extent (point) (1+ (point))) xface-glyph))))
743 737
744 (defvar gnus-xmas-pointer-glyph 738 (defun gnus-xmas-article-show-hidden-text (type &optional hide)
745 (progn 739 "Show all hidden text of type TYPE.
746 (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus")) 740 If HIDE, hide the text instead."
747 (make-pointer-glyph (concat gnus-xmas-glyph-directory "gnus-pointer." 741 (save-excursion
748 (if (featurep 'xpm) "xpm" "xbm"))))) 742 (set-buffer gnus-article-buffer)
749 743 (let ((buffer-read-only nil)
750 (defvar gnus-xmas-modeline-left-extent 744 (inhibit-point-motion-hooks t)
751 (let ((ext (copy-extent modeline-buffer-id-left-extent))) 745 (beg (point-min)))
752 ;(set-extent-property ext 'pointer gnus-xmas-pointer-glyph) 746 (while (gnus-goto-char (text-property-any
753 ext)) 747 beg (point-max) 'gnus-type type))
754 748 (setq beg (point))
755 (defvar gnus-xmas-modeline-right-extent 749 (forward-char)
756 (let ((ext (copy-extent modeline-buffer-id-right-extent))) 750 (if hide
757 ;(set-extent-property ext 'pointer gnus-xmas-pointer-glyph) 751 (gnus-hide-text beg (point) gnus-hidden-properties)
758 ext)) 752 (gnus-unhide-text beg (point)))
759 753 (setq beg (point)))
760 (defvar gnus-xmas-modeline-glyph 754 (save-window-excursion
761 (progn 755 (select-window (get-buffer-window (current-buffer)))
762 (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus")) 756 (recenter))
763 (let* ((file (concat gnus-xmas-glyph-directory "gnus-pointer." 757 t)))
764 (if (featurep 'xpm) "xpm" "xbm")))
765 (glyph (make-glyph file)))
766 (when (and (featurep 'x)
767 (file-exists-p file))
768 (set-glyph-face glyph 'modeline-buffer-id)
769 (set-glyph-property glyph 'image (cons 'tty "Gnus:"))
770 glyph))))
771 758
772 (defun gnus-xmas-mode-line-buffer-identification (line) 759 (defun gnus-xmas-mode-line-buffer-identification (line)
773 (let ((line (car line)) 760 (let ((line (car line))
774 chop) 761 chop)
775 (cond 762 (if (not (stringp line))
776 ;; This is some weird type of id. 763 (list line)
777 ((not (stringp line)) 764 (unless (setq chop (string-match ":" line))
778 (list line)) 765 (setq chop (/ (length line) 2)))
779 ;; This is non-standard, so we just pass it through. 766 (list (cons modeline-buffer-id-left-extent (substring line 0 chop))
780 ((not (string-match "^Gnus:" line)) 767 (cons modeline-buffer-id-right-extent (substring line chop))))))
781 (list line))
782 ;; We have a standard line, so we colorize and glyphize it a bit.
783 (t
784 (setq chop (match-end 0))
785 (list
786 (if gnus-xmas-modeline-glyph
787 (cons gnus-xmas-modeline-left-extent gnus-xmas-modeline-glyph)
788 (cons gnus-xmas-modeline-left-extent (substring line 0 chop)))
789 (cons gnus-xmas-modeline-right-extent (substring line chop)))))))
790
791 (defun gnus-xmas-splash ()
792 (when (eq (device-type) 'x)
793 (gnus-splash)))
794 768
795 (provide 'gnus-xmas) 769 (provide 'gnus-xmas)
796 770
797 ;;; gnus-xmas.el ends here 771 ;;; gnus-xmas.el ends here