2bcde76d39108404255cb1c4d534033db62ea932
[elisp/gnus.git-] / lisp / gnus-xmas.el
1 ;;; gnus-xmas.el --- Gnus functions for XEmacs
2
3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
4 ;;        Free Software Foundation, Inc.
5
6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7 ;;      Katsumi Yamaoka <yamaoka@jpl.org>
8 ;; Keywords: news
9
10 ;; This file is part of GNU Emacs.
11
12 ;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; any later version.
16
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
20 ;; GNU General Public License for more details.
21
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
26
27 ;;; Commentary:
28
29 ;;; Code:
30
31 (require 'text-props)
32 (defvar menu-bar-mode (featurep 'menubar))
33 (require 'messagexmas)
34 (require 'wid-edit)
35
36 (defgroup gnus-xmas nil
37   "XEmacsoid support for Gnus"
38   :group 'gnus)
39
40 (defcustom gnus-xmas-glyph-directory nil
41   "Directory where Gnus logos and icons are located.
42 If this variable is nil, Gnus will try to locate the directory
43 automatically."
44   :type '(choice (const :tag "autodetect" nil)
45                  directory)
46   :group 'gnus-xmas)
47
48 (unless gnus-xmas-glyph-directory
49   (unless (setq gnus-xmas-glyph-directory
50                 (message-xmas-find-glyph-directory "gnus"))
51     (error "Can't find glyph directory. \
52 Possibly the `etc' directory has not been installed.")))
53
54 ;;(format "%02x%02x%02x" 114 66 20) "724214"
55
56 (defvar gnus-xmas-logo-color-alist
57   '((flame "#cc3300" "#ff2200")
58     (pine "#c0cc93" "#f8ffb8")
59     (moss "#a1cc93" "#d2ffb8")
60     (irish "#04cc90" "#05ff97")
61     (sky "#049acc" "#05deff")
62     (tin "#6886cc" "#82b6ff")
63     (velvet "#7c68cc" "#8c82ff")
64     (grape "#b264cc" "#cf7df")
65     (labia "#cc64c2" "#fd7dff")
66     (berry "#cc6485" "#ff7db5")
67     (dino "#724214" "#1e3f03")
68     (neutral "#b4b4b4" "#878787")
69     (september "#bf9900" "#ffcc00"))
70   "Color alist used for the Gnus logo.")
71
72 (defcustom gnus-xmas-logo-color-style 'dino
73   "*Color styles used for the Gnus logo."
74   :type '(choice (const flame) (const pine) (const moss)
75                  (const irish) (const sky) (const tin)
76                  (const velvet) (const grape) (const labia)
77                  (const berry) (const neutral) (const september)
78                  (const dino))
79   :group 'gnus-xmas)
80
81 (defvar gnus-xmas-logo-colors
82   (cdr (assq gnus-xmas-logo-color-style gnus-xmas-logo-color-alist))
83   "Colors used for the Gnus logo.")
84
85 (defcustom gnus-article-x-face-command
86   (if (or (featurep 'xface)
87           (featurep 'xpm))
88       'gnus-xmas-article-display-xface
89     "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -")
90   "*String or function to be executed to display an X-Face header.
91 If it is a string, the command will be executed in a sub-shell
92 asynchronously.  The compressed face will be piped to this command."
93   :type '(choice string function))
94
95 ;;; Internal variables.
96
97 ;; Don't warn about these undefined variables.
98
99 ;;defined in gnus.el
100 (defvar gnus-active-hashtb)
101 (defvar gnus-article-buffer)
102 (defvar gnus-auto-center-summary)
103 (defvar gnus-current-headers)
104 (defvar gnus-level-killed)
105 (defvar gnus-level-zombie)
106 (defvar gnus-newsgroup-bookmarks)
107 (defvar gnus-newsgroup-dependencies)
108 (defvar gnus-newsgroup-selected-overlay)
109 (defvar gnus-newsrc-hashtb)
110 (defvar gnus-read-mark)
111 (defvar gnus-refer-article-method)
112 (defvar gnus-reffed-article-number)
113 (defvar gnus-unread-mark)
114 (defvar gnus-version)
115 (defvar gnus-view-pseudos)
116 (defvar gnus-view-pseudos-separately)
117 (defvar gnus-visual)
118 (defvar gnus-zombie-list)
119 ;;defined in gnus-msg.el
120 (defvar gnus-article-copy)
121 (defvar gnus-check-before-posting)
122 ;;defined in gnus-vis.el
123 (defvar gnus-article-button-face)
124 (defvar gnus-article-mouse-face)
125 (defvar gnus-summary-selected-face)
126 (defvar gnus-group-reading-menu)
127 (defvar gnus-group-group-menu)
128 (defvar gnus-group-misc-menu)
129 (defvar gnus-summary-article-menu)
130 (defvar gnus-summary-thread-menu)
131 (defvar gnus-summary-misc-menu)
132 (defvar gnus-summary-post-menu)
133 (defvar gnus-summary-kill-menu)
134 (defvar gnus-article-article-menu)
135 (defvar gnus-article-treatment-menu)
136 (defvar gnus-mouse-2)
137 (defvar standard-display-table)
138 (defvar gnus-tree-minimize-window)
139
140 (defun gnus-xmas-set-text-properties (start end props &optional buffer)
141   "You should NEVER use this function.  It is ideologically blasphemous.
142 It is provided only to ease porting of broken FSF Emacs programs."
143   (if (stringp buffer)
144       nil
145     (map-extents (lambda (extent ignored)
146                    (remove-text-properties
147                     start end
148                     (list (extent-property extent 'text-prop) nil)
149                     buffer)
150                    nil)
151                  buffer start end nil nil 'text-prop)
152     (gnus-add-text-properties start end props buffer)))
153
154 (defun gnus-xmas-highlight-selected-summary ()
155   ;; Highlight selected article in summary buffer
156   (when gnus-summary-selected-face
157     (when gnus-newsgroup-selected-overlay
158       (delete-extent gnus-newsgroup-selected-overlay))
159     (setq gnus-newsgroup-selected-overlay
160           (make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
161     (set-extent-face gnus-newsgroup-selected-overlay
162                      gnus-summary-selected-face)))
163
164 (defcustom gnus-xmas-force-redisplay nil
165   "*If non-nil, force a redisplay before recentering the summary buffer.
166 This is ugly, but it works around a bug in `window-displayed-height'."
167   :type 'boolean
168   :group 'gnus-xmas)
169
170 (defun gnus-xmas-switch-horizontal-scrollbar-off ()
171   (when (featurep 'scrollbar)
172     (set-specifier scrollbar-height (cons (current-buffer) 0))))
173
174 (defun gnus-xmas-summary-recenter ()
175   "\"Center\" point in the summary window.
176 If `gnus-auto-center-summary' is nil, or the article buffer isn't
177 displayed, no centering will be performed."
178   ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle).
179   ;; Recenter only when requested.  Suggested by popovich@park.cs.columbia.edu.
180   ;; Force redisplay to get properly computed window height.
181   (when gnus-xmas-force-redisplay
182     (sit-for 0))
183   (when gnus-auto-center-summary
184     (let* ((height (if (fboundp 'window-displayed-height)
185                        (window-displayed-height)
186                      (- (window-height) 2)))
187            (top (cond ((< height 4) 0)
188                       ((< height 7) 1)
189                       (t (if (numberp gnus-auto-center-summary)
190                              gnus-auto-center-summary
191                            2))))
192            (bottom (save-excursion (goto-char (point-max))
193                                    (forward-line (- height))
194                                    (point)))
195            (window (get-buffer-window (current-buffer))))
196       (when (get-buffer-window gnus-article-buffer)
197         ;; Only do recentering when the article buffer is displayed,
198         ;; Set the window start to either `bottom', which is the biggest
199         ;; possible valid number, or the second line from the top,
200         ;; whichever is the least.
201         ;; NOFORCE parameter suggested by Daniel Pittman <daniel@danann.net>.
202         (set-window-start
203          window (min bottom (save-excursion (forward-line (- top)) (point)))
204          t))
205       ;; Do horizontal recentering while we're at it.
206       (when (and (get-buffer-window (current-buffer) t)
207                  (not (eq gnus-auto-center-summary 'vertical)))
208         (let ((selected (selected-window)))
209           (select-window (get-buffer-window (current-buffer) t))
210           (gnus-summary-position-point)
211           (gnus-horizontal-recenter)
212           (select-window selected))))))
213
214 (defun gnus-xmas-summary-set-display-table ()
215   ;; Setup the display table -- like `gnus-summary-setup-display-table',
216   ;; but done in an XEmacsish way.
217   (let ((table (make-display-table))
218         (i 32))
219     ;; Nix out all the control chars...
220     (while (>= (setq i (1- i)) 0)
221       (aset table i [??]))
222     ;; ... but not newline and cr, of course.  (cr is necessary for the
223     ;; selective display).
224     (aset table ?\n nil)
225     (aset table ?\r nil)
226     ;; We keep TAB as well.
227     (aset table ?\t nil)
228     ;; We nix out any glyphs over 126 below ctl-arrow.
229     (let ((i (if (integerp ctl-arrow) ctl-arrow 160)))
230       (while (>= (setq i (1- i)) 127)
231         (unless (aref table i)
232           (aset table i [??]))))
233     ;; Can't use `set-specifier' because of a bug in 19.14 and earlier
234     (add-spec-to-specifier current-display-table table (current-buffer) nil)))
235
236 (defun gnus-xmas-add-text-properties (start end props &optional object)
237   (add-text-properties start end props object)
238   (put-text-property start end 'start-closed nil object))
239
240 (defun gnus-xmas-put-text-property (start end prop value &optional object)
241   (put-text-property start end prop value object)
242   (put-text-property start end 'start-closed nil object))
243
244 (defun gnus-xmas-extent-start-open (point)
245   (map-extents (lambda (extent arg)
246                  (set-extent-property extent 'start-open t))
247                nil point (min (1+ (point)) (point-max))))
248
249 (defun gnus-xmas-article-push-button (event)
250   "Check text under the mouse pointer for a callback function.
251 If the text under the mouse pointer has a `gnus-callback' property,
252 call it with the value of the `gnus-data' text property."
253   (interactive "e")
254   (set-buffer (window-buffer (event-window event)))
255   (let* ((pos (event-closest-point event))
256          (data (get-text-property pos 'gnus-data))
257          (fun (get-text-property pos 'gnus-callback)))
258     (goto-char pos)
259     (when fun
260       (funcall fun data))))
261
262 (defun gnus-xmas-move-overlay (extent start end &optional buffer)
263   (set-extent-endpoints extent start end buffer))
264
265 (defun gnus-xmas-kill-all-overlays ()
266   "Delete all extents in the current buffer."
267   (map-extents (lambda (extent ignore)
268                  (delete-extent extent)
269                  nil)))
270
271 (defun gnus-xmas-window-top-edge (&optional window)
272   (nth 1 (window-pixel-edges window)))
273
274 (defun gnus-xmas-tree-minimize ()
275   (when (and gnus-tree-minimize-window
276              (not (one-window-p)))
277     (let* ((window-min-height 2)
278            (height (1+ (count-lines (point-min) (point-max))))
279            (min (max (1- window-min-height) height))
280            (tot (if (numberp gnus-tree-minimize-window)
281                     (min gnus-tree-minimize-window min)
282                   min))
283            (win (get-buffer-window (current-buffer)))
284            (wh (and win (1- (window-height win)))))
285       (when (and win
286                  (not (eq tot wh)))
287         (let ((selected (selected-window)))
288           (select-window win)
289           (enlarge-window (- tot wh))
290           (select-window selected))))))
291
292 ;; Select the lowest window on the frame.
293 (defun gnus-xmas-appt-select-lowest-window ()
294   (let* ((lowest-window (selected-window))
295          (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
296          (last-window (previous-window))
297          (window-search t))
298     (while window-search
299       (let* ((this-window (next-window))
300              (next-bottom-edge (car (cdr (cdr (cdr
301                                                (window-pixel-edges
302                                                 this-window)))))))
303         (when (< bottom-edge next-bottom-edge)
304           (setq bottom-edge next-bottom-edge)
305           (setq lowest-window this-window))
306
307         (select-window this-window)
308         (when (eq last-window this-window)
309           (select-window lowest-window)
310           (setq window-search nil))))))
311
312 (defmacro gnus-xmas-menu-add (type &rest menus)
313   `(gnus-xmas-menu-add-1 ',type ',menus))
314 (put 'gnus-xmas-menu-add 'lisp-indent-function 1)
315
316 (defun gnus-xmas-menu-add-1 (type menus)
317   (when (and menu-bar-mode
318              (gnus-visual-p (intern (format "%s-menu" type)) 'menu))
319     (while menus
320       (easy-menu-add (symbol-value (pop menus))))))
321
322 (defun gnus-xmas-group-menu-add ()
323   (gnus-xmas-menu-add group
324     gnus-group-reading-menu gnus-group-group-menu gnus-group-misc-menu))
325
326 (defun gnus-xmas-summary-menu-add ()
327   (gnus-xmas-menu-add summary
328     gnus-summary-misc-menu gnus-summary-kill-menu
329     gnus-summary-article-menu gnus-summary-thread-menu
330     gnus-summary-post-menu ))
331
332 (defun gnus-xmas-article-menu-add ()
333   (gnus-xmas-menu-add article
334     gnus-article-article-menu gnus-article-treatment-menu
335     gnus-article-post-menu))
336
337 (defun gnus-xmas-score-menu-add ()
338   (gnus-xmas-menu-add score
339     gnus-score-menu))
340
341 (defun gnus-xmas-pick-menu-add ()
342   (gnus-xmas-menu-add pick
343     gnus-pick-menu))
344
345 (defun gnus-xmas-topic-menu-add ()
346   (gnus-xmas-menu-add topic
347     gnus-topic-menu))
348
349 (defun gnus-xmas-binary-menu-add ()
350   (gnus-xmas-menu-add binary
351     gnus-binary-menu))
352
353 (defun gnus-xmas-agent-summary-menu-add ()
354   (gnus-xmas-menu-add agent-summary
355     gnus-agent-summary-menu))
356
357 (defun gnus-xmas-agent-group-menu-add ()
358   (gnus-xmas-menu-add agent-group
359     gnus-agent-group-menu))
360
361 (defun gnus-xmas-agent-server-menu-add ()
362   (gnus-xmas-menu-add agent-server
363     gnus-agent-server-menu))
364
365 (defun gnus-xmas-tree-menu-add ()
366   (gnus-xmas-menu-add tree
367     gnus-tree-menu))
368
369 (defun gnus-xmas-draft-menu-add ()
370   (gnus-xmas-menu-add draft
371     gnus-draft-menu))
372
373 (defun gnus-xmas-server-menu-add ()
374   (gnus-xmas-menu-add menu
375     gnus-server-server-menu gnus-server-connections-menu))
376
377 (defun gnus-xmas-browse-menu-add ()
378   (gnus-xmas-menu-add browse
379     gnus-browse-menu))
380
381 (defun gnus-xmas-grouplens-menu-add ()
382   (gnus-xmas-menu-add grouplens
383     gnus-grouplens-menu))
384
385 (defun gnus-xmas-read-event-char ()
386   "Get the next event."
387   (let ((event (next-command-event)))
388     (sit-for 0)
389     ;; We junk all non-key events.  Is this naughty?
390     (while (not (or (key-press-event-p event)
391                     (button-press-event-p event)))
392       (dispatch-event event)
393       (setq event (next-command-event)))
394     (cons (and (key-press-event-p event)
395                (event-to-character event))
396           event)))
397
398 (defun gnus-xmas-define ()
399   (setq gnus-mouse-2 [button2])
400   (setq gnus-mouse-3 [button3])
401   (setq gnus-widget-button-keymap widget-button-keymap)
402
403   (unless (memq 'underline (face-list))
404     (and (fboundp 'make-face)
405          (funcall (intern "make-face") 'underline)))
406   ;; Must avoid calling set-face-underline-p directly, because it
407   ;; is a defsubst in emacs19, and will make the .elc files non
408   ;; portable!
409   (unless (face-differs-from-default-p 'underline)
410     (funcall (intern "set-face-underline-p") 'underline t))
411
412   (cond
413    ((fboundp 'char-or-char-int-p)
414     ;; Handle both types of marks for XEmacs-20.x.
415     (defalias 'gnus-characterp 'char-or-char-int-p))
416    ;; V19 of XEmacs, probably.
417    (t
418     (defalias 'gnus-characterp 'characterp)))
419
420   (defalias 'gnus-make-overlay 'make-extent)
421   (defalias 'gnus-delete-overlay 'delete-extent)
422   (defalias 'gnus-overlay-put 'set-extent-property)
423   (defalias 'gnus-move-overlay 'gnus-xmas-move-overlay)
424   (defalias 'gnus-overlay-buffer 'extent-object)
425   (defalias 'gnus-overlay-start 'extent-start-position)
426   (defalias 'gnus-overlay-end 'extent-end-position)
427   (defalias 'gnus-kill-all-overlays 'gnus-xmas-kill-all-overlays)
428   (defalias 'gnus-extent-detached-p 'extent-detached-p)
429   (defalias 'gnus-add-text-properties 'gnus-xmas-add-text-properties)
430   (defalias 'gnus-put-text-property 'gnus-xmas-put-text-property)
431   (defalias 'gnus-deactivate-mark 'ignore)
432   (defalias 'gnus-window-edges 'window-pixel-edges)
433
434   (if (and (<= emacs-major-version 19)
435            (< emacs-minor-version 14))
436       (defalias 'gnus-set-text-properties 'gnus-xmas-set-text-properties))
437
438   (unless (boundp 'standard-display-table)
439     (setq standard-display-table nil))
440
441   (defvar gnus-mouse-face-prop 'highlight)
442
443   (defun gnus-byte-code (func)
444     "Return a form that can be `eval'ed based on FUNC."
445     (let ((fval (indirect-function func)))
446       (if (compiled-function-p fval)
447           (list 'funcall fval)
448         (cons 'progn (cdr (cdr fval))))))
449
450   (defalias 'gnus-x-color-values
451     (if (fboundp 'x-color-values)
452         'x-color-values
453       (lambda (color)
454         (color-instance-rgb-components
455          (make-color-instance color))))))
456
457 (defun gnus-xmas-redefine ()
458   "Redefine lots of Gnus functions for XEmacs."
459   (defalias 'gnus-summary-set-display-table 'gnus-xmas-summary-set-display-table)
460   (defalias 'gnus-visual-turn-off-edit-menu 'identity)
461   (defalias 'gnus-summary-recenter 'gnus-xmas-summary-recenter)
462   (defalias 'gnus-extent-start-open 'gnus-xmas-extent-start-open)
463   (defalias 'gnus-article-push-button 'gnus-xmas-article-push-button)
464   (defalias 'gnus-window-top-edge 'gnus-xmas-window-top-edge)
465   (defalias 'gnus-read-event-char 'gnus-xmas-read-event-char)
466   (defalias 'gnus-group-startup-message 'gnus-xmas-group-startup-message)
467   (defalias 'gnus-tree-minimize 'gnus-xmas-tree-minimize)
468   (defalias 'gnus-appt-select-lowest-window
469         'gnus-xmas-appt-select-lowest-window)
470   (defalias 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names)
471   (defalias 'gnus-character-to-event 'character-to-event)
472   (defalias 'gnus-mode-line-buffer-identification
473         'gnus-xmas-mode-line-buffer-identification)
474   (defalias 'gnus-key-press-event-p 'key-press-event-p)
475   (defalias 'gnus-region-active-p 'region-active-p)
476   (defalias 'gnus-annotation-in-region-p 'gnus-xmas-annotation-in-region-p)
477   (defalias 'gnus-mime-button-menu 'gnus-xmas-mime-button-menu)
478
479   ;; These ones are not defcutom'ed, sometimes not even defvar'ed. They
480   ;; probably should. If that is done, the code below should then be moved
481   ;; where each variable is defined, in order not to mess with user settings.
482   ;; -- didier
483   (add-hook 'gnus-score-mode-hook 'gnus-xmas-score-menu-add)
484   (add-hook 'gnus-binary-mode-hook 'gnus-xmas-binary-menu-add)
485   (add-hook 'gnus-grouplens-mode-hook 'gnus-xmas-grouplens-menu-add)
486   (add-hook 'gnus-server-mode-hook 'gnus-xmas-server-menu-add)
487   (add-hook 'gnus-browse-mode-hook 'gnus-xmas-browse-menu-add)
488   (add-hook 'gnus-draft-mode-hook 'gnus-xmas-draft-menu-add)
489   (add-hook 'gnus-mailing-list-mode-hook 'gnus-xmas-mailing-list-menu-add)
490
491   (when (featurep 'mule)
492     (defun gnus-truncate-string (str end-column &optional start-column padding)
493       "Truncate string STR to end at column END-COLUMN.
494 The optional 2nd arg START-COLUMN, if non-nil, specifies
495 the starting column; that means to return the characters occupying
496 columns START-COLUMN ... END-COLUMN of STR.
497
498 The optional 3rd arg PADDING, if non-nil, specifies a padding character
499 to add at the end of the result if STR doesn't reach column END-COLUMN,
500 or if END-COLUMN comes in the middle of a character in STR.
501 PADDING is also added at the beginning of the result
502 if column START-COLUMN appears in the middle of a character in STR.
503
504 If PADDING is nil, no padding is added in these cases, so
505 the resulting string may be narrower than END-COLUMN.
506 \[Emacs 20.3 emulating function]"
507       (or start-column
508           (setq start-column 0))
509       (let ((len (length str))
510             (idx 0)
511             (column 0)
512             (head-padding "") (tail-padding "")
513             ch last-column last-idx from-idx)
514         (condition-case nil
515             (while (< column start-column)
516               (setq ch (aref str idx)
517                     column (+ column (char-width ch))
518                     idx (1+ idx)))
519           (args-out-of-range (setq idx len)))
520         (if (< column start-column)
521             (if padding (make-string end-column padding) "")
522           (if (and padding (> column start-column))
523               (setq head-padding
524                     (make-string (- column start-column) padding)))
525           (setq from-idx idx)
526           (if (< end-column column)
527               (setq idx from-idx)
528             (condition-case nil
529                 (while (< column end-column)
530                   (setq last-column column
531                         last-idx idx
532                         ch (aref str idx)
533                         column (+ column (char-width ch))
534                         idx (1+ idx)))
535               (args-out-of-range (setq idx len)))
536             (if (> column end-column)
537                 (setq column last-column idx last-idx))
538             (if (and padding (< column end-column))
539                 (setq tail-padding
540                       (make-string (- end-column column) padding))))
541           (setq str (substring str from-idx idx))
542           (if padding
543               (concat head-padding str tail-padding)
544             str))))
545
546     (defun gnus-tilde-pad-form (el pad-width)
547       "Return a form that pads EL to PAD-WIDTH."
548       (let ((pad (abs pad-width)))
549         (if (symbolp el)
550             (if (< pad-width 0)
551                 `(let ((val (format "%s" ,el)))
552                    (concat val (make-string
553                                 (max 0 (- ,pad (string-width val))) ?\ )))
554               `(let ((val (format "%s" ,el)))
555                  (concat (make-string
556                           (max 0 (- ,pad (string-width val))) ?\ )
557                          val)))
558           (if (< pad-width 0)
559               `(let ((val (eval ,el)))
560                  (concat val (make-string
561                               (max 0 (- ,pad (string-width val))) ?\ )))
562             `(let ((val (eval ,el)))
563                (concat (make-string
564                         (max 0 (- ,pad (string-width val))) ?\ )
565                        val))))))
566     ))
567
568 ;;; XEmacs logo and toolbar.
569
570 (defun gnus-xmas-group-startup-message (&optional x y)
571   "Insert startup message in current buffer."
572   ;; Insert the message.
573   (erase-buffer)
574   (cond
575    ((and (console-on-window-system-p)
576          (or (featurep 'xpm)
577              (featurep 'xbm)))
578     (let* ((logo-xpm (expand-file-name "gnus.xpm" gnus-xmas-glyph-directory))
579            (logo-xbm (expand-file-name "gnus.xbm" gnus-xmas-glyph-directory))
580            (glyph (make-glyph
581                    (cond ((featurep 'xpm)
582                           `[xpm
583                             :file ,logo-xpm
584                             :color-symbols
585                             (("thing" . ,(car gnus-xmas-logo-colors))
586                              ("shadow" . ,(cadr gnus-xmas-logo-colors))
587                              ("background" . ,(face-background 'default)))])
588                          ((featurep 'xbm)
589                           `[xbm :file ,logo-xbm])
590                          (t [nothing]))))
591            (wpheight (window-pixel-height))
592            (rest (max 0 (1- (/ (* (- wpheight (glyph-height glyph))
593                                   (window-height))
594                                wpheight 2)))))
595       (insert " ")
596       (set-extent-begin-glyph (make-extent (point) (point)) glyph)
597       (goto-char (point-min))
598       (while (not (eobp))
599         (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
600                              ?\ ))
601         (forward-line 1))
602       (setq gnus-simple-splash nil)
603       (goto-char (point-min))
604       (insert gnus-product-name " " gnus-version-number
605               (if (zerop (string-to-number gnus-revision-number))
606                   ""
607                 (concat " (r" gnus-revision-number ")"))
608               " based on " gnus-original-product-name " v"
609               gnus-original-version-number "\n")
610       (end-of-line 0)
611       (put-text-property (point-min) (point) 'face 'gnus-splash-face)
612       (insert-char ?\  (prog1
613                            (max 0 (/ (- (window-width) (point)) 2))
614                          (goto-char (point-min))))
615       (forward-line 1)
616       (insert-char ?\n rest)
617       (set-window-start (selected-window) (point-min))))
618    (t
619     (insert "
620           _    ___ _             _
621           _ ___ __ ___  __    _ ___
622           __   _     ___    __  ___
623               _           ___     _
624              _  _ __             _
625              ___   __            _
626                    __           _
627                     _      _   _
628                    _      _    _
629                       _  _    _
630                   __  ___
631                  _   _ _     _
632                 _   _
633               _    _
634              _    _
635             _
636           __
637
638 "
639             )
640     (goto-char (point-min))
641     (insert gnus-product-name " " gnus-version-number
642             (if (zerop (string-to-number gnus-revision-number))
643                 ""
644               (concat " (r" gnus-revision-number ")"))
645             " based on " gnus-original-product-name " v"
646             gnus-original-version-number)
647     (insert-char ?\  (prog1
648                          (max 0 (/ (- (window-width) (point)) 2))
649                        (goto-char (point-min))))
650     (forward-line 1)
651     ;; And then hack it.
652     (gnus-indent-rigidly (point) (point-max)
653                          (/ (max (- (window-width) (or x 46)) 0) 2))
654     (goto-char (point-min))
655     (forward-line 1)
656     (let* ((pheight (count-lines (point-min) (point-max)))
657            (wheight (window-height))
658            (rest (- wheight pheight)))
659       (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))
660     ;; Paint it.
661     (put-text-property (point-min) (point-max) 'face 'gnus-splash-face)))
662   (setq modeline-buffer-identification
663         (list (concat gnus-version ": *Group*")))
664   (set-buffer-modified-p t))
665
666
667 ;;; The toolbar.
668
669 (defcustom gnus-use-toolbar (if (featurep 'toolbar)
670                                 'default-toolbar
671                               nil)
672   "*If nil, do not use a toolbar.
673 If it is non-nil, it must be a toolbar.  The five valid values are
674 `default-toolbar', `top-toolbar', `bottom-toolbar',
675 `right-toolbar', and `left-toolbar'."
676   :type '(choice (const default-toolbar)
677                  (const top-toolbar) (const bottom-toolbar)
678                  (const left-toolbar) (const right-toolbar)
679                  (const :tag "no toolbar" nil))
680   :group 'gnus-xmas)
681
682 (defvar gnus-group-toolbar
683   '([gnus-group-get-new-news gnus-group-get-new-news t "Get new news"]
684     [gnus-group-get-new-news-this-group
685      gnus-group-get-new-news-this-group t "Get new news in this group"]
686     [gnus-group-catchup-current
687      gnus-group-catchup-current t "Catchup group"]
688     [gnus-group-describe-group
689      gnus-group-describe-group t "Describe group"]
690     [gnus-group-unsubscribe gnus-group-unsubscribe t "Unsubscribe group"]
691     [gnus-group-subscribe gnus-group-subscribe t "Subscribe group"]
692     [gnus-group-kill-group gnus-group-kill-group t "Kill group"]
693     [gnus-group-exit gnus-group-exit t "Exit Gnus"])
694   "The group buffer toolbar.")
695
696 (defvar gnus-summary-toolbar
697   '([gnus-summary-prev-unread
698      gnus-summary-prev-page-or-article t "Page up"]
699     [gnus-summary-next-unread
700      gnus-summary-next-page t "Page down"]
701     [gnus-summary-post-news
702      gnus-summary-post-news t "Post an article"]
703     [gnus-summary-followup-with-original
704      gnus-summary-followup-with-original t
705      "Post a followup and yank the original"]
706     [gnus-summary-followup
707      gnus-summary-followup t "Post a followup"]
708     [gnus-summary-reply-with-original
709      gnus-summary-reply-with-original t "Mail a reply and yank the original"]
710     [gnus-summary-reply
711      gnus-summary-reply t "Mail a reply"]
712     [gnus-summary-caesar-message
713      gnus-summary-caesar-message t "Rot 13"]
714     [gnus-uu-decode-uu
715      gnus-uu-decode-uu t "Decode uuencoded articles"]
716     [gnus-summary-save-article-file
717      gnus-summary-save-article-file t "Save article in file"]
718     [gnus-summary-save-article
719      gnus-summary-save-article t "Save article"]
720     [gnus-uu-post-news
721      gnus-uu-post-news t "Post a uuencoded article"]
722     [gnus-summary-cancel-article
723      gnus-summary-cancel-article t "Cancel article"]
724     [gnus-summary-catchup
725      gnus-summary-catchup t "Catchup"]
726     [gnus-summary-catchup-and-exit
727      gnus-summary-catchup-and-exit t "Catchup and exit"]
728     [gnus-summary-exit gnus-summary-exit t "Exit this summary"])
729   "The summary buffer toolbar.")
730
731 (defvar gnus-summary-mail-toolbar
732   '(
733     [gnus-summary-prev-unread
734      gnus-summary-prev-unread-article t "Prev unread article"]
735     [gnus-summary-next-unread
736      gnus-summary-next-unread-article t "Next unread article"]
737     [gnus-summary-mail-reply gnus-summary-reply t "Reply"]
738     [gnus-summary-mail-originate gnus-summary-post-news t "Originate"]
739     [gnus-summary-mail-save gnus-summary-save-article t "Save"]
740     [gnus-summary-mail-copy gnus-summary-copy-article t "Copy message"]
741     [gnus-summary-mail-forward gnus-summary-mail-forward t "Forward message"]
742     [gnus-summary-caesar-message
743      gnus-summary-caesar-message t "Rot 13"]
744     [gnus-uu-decode-uu
745      gnus-uu-decode-uu t "Decode uuencoded articles"]
746     [gnus-summary-save-article-file
747      gnus-summary-save-article-file t "Save article in file"]
748     [gnus-summary-save-article
749      gnus-summary-save-article t "Save article"]
750     [gnus-summary-catchup
751      gnus-summary-catchup t "Catchup"]
752     [gnus-summary-catchup-and-exit
753      gnus-summary-catchup-and-exit t "Catchup and exit"]
754     [gnus-summary-exit gnus-summary-exit t "Exit this summary"])
755   "The summary buffer mail toolbar.")
756
757 (defun gnus-xmas-setup-group-toolbar ()
758   (and gnus-use-toolbar
759        (message-xmas-setup-toolbar gnus-group-toolbar nil "gnus")
760        (set-specifier (symbol-value gnus-use-toolbar)
761                       (cons (current-buffer) gnus-group-toolbar))))
762
763 (defun gnus-xmas-setup-summary-toolbar ()
764   (let ((bar (if (gnus-news-group-p gnus-newsgroup-name)
765                  gnus-summary-toolbar gnus-summary-mail-toolbar)))
766     (and gnus-use-toolbar
767          (message-xmas-setup-toolbar bar nil "gnus")
768          (set-specifier (symbol-value gnus-use-toolbar)
769                         (cons (current-buffer) bar)))))
770
771 (defun gnus-xmas-mail-strip-quoted-names (address)
772   "Protect mail-strip-quoted-names from NIL input.
773 XEmacs compatibility workaround."
774   (if (null address)
775       nil
776     (mail-strip-quoted-names address)))
777
778 (defun gnus-xmas-call-region (command &rest args)
779   (apply
780    'call-process-region (point-min) (point-max) command t '(t nil) nil
781    args))
782
783 (defface gnus-x-face '((t (:foreground "black" :background "white")))
784   "Face to show X face"
785   :group 'gnus-xmas)
786
787 (defun gnus-xmas-article-display-xface (beg end &optional buffer)
788   "Display any XFace headers in BUFFER."
789   (save-excursion
790     (let ((xface-glyph
791            (cond
792             ((featurep 'xface)
793              (make-glyph (vector 'xface :data
794                                  (concat "X-Face: "
795                                          (if buffer
796                                              (with-current-buffer buffer
797                                                (buffer-substring beg end))
798                                            (buffer-substring beg end))))))
799             ((featurep 'xpm)
800              (let ((cur (or buffer (current-buffer))))
801                (save-excursion
802                  (gnus-set-work-buffer)
803                  (insert-buffer-substring cur beg end)
804                  (gnus-xmas-call-region "uncompface")
805                  (goto-char (point-min))
806                  (insert "/* Width=48, Height=48 */\n")
807                  (gnus-xmas-call-region "icontopbm")
808                  (gnus-xmas-call-region "ppmtoxpm")
809                  (make-glyph
810                   (vector 'xpm :data (buffer-string))))))
811             (t
812              (make-glyph [nothing]))))
813           (ext (make-extent (progn
814                               (goto-char (point-min))
815                               (re-search-forward "^From:" nil t)
816                               (point))
817                             (1+ (point)))))
818       (set-glyph-face xface-glyph 'gnus-x-face)
819       (set-extent-begin-glyph ext xface-glyph)
820       (set-extent-property ext 'duplicable t))))
821
822 (defvar gnus-xmas-modeline-left-extent
823   (let ((ext (copy-extent modeline-buffer-id-left-extent)))
824     ext))
825
826 (defvar gnus-xmas-modeline-right-extent
827   (let ((ext (copy-extent modeline-buffer-id-right-extent)))
828     ext))
829
830 (defvar gnus-xmas-modeline-glyph
831   (progn
832     (let* ((file-xpm (expand-file-name "gnus-pointer.xpm"
833                                        gnus-xmas-glyph-directory))
834            (file-xbm (expand-file-name "gnus-pointer.xbm"
835                                        gnus-xmas-glyph-directory))
836            (glyph (make-glyph
837                    ;; Gag gag gag.
838                    (cond ((featurep 'xpm)
839                           ;; Let's try a nifty XPM
840                           `[xpm :file ,file-xpm])
841                          ((featurep 'xbm)
842                           ;; Then a not-so-nifty XBM
843                           `[xbm :file ,file-xbm])
844                          ;; Then the simple string
845                          (t [string :data "Gnus:"])))))
846       (set-glyph-face glyph 'modeline-buffer-id)
847       glyph)))
848
849 (defun gnus-xmas-mode-line-buffer-identification (line)
850   (let ((line (car line))
851         chop)
852     (cond
853      ;; This is some weird type of id.
854      ((not (stringp line))
855       (list line))
856      ;; This is non-standard, so we just pass it through.
857      ((not (string-match "^Gnus:" line))
858       (list line))
859      ;; We have a standard line, so we colorize and glyphize it a bit.
860      (t
861       (setq chop (match-end 0))
862       (list
863        (if gnus-xmas-modeline-glyph
864            (cons gnus-xmas-modeline-left-extent gnus-xmas-modeline-glyph)
865          (cons gnus-xmas-modeline-left-extent (substring line 0 chop)))
866        (cons gnus-xmas-modeline-right-extent (substring line chop)))))))
867
868 (defun gnus-xmas-splash ()
869   (when (eq (device-type) 'x)
870     (gnus-splash)))
871
872 (defun gnus-xmas-annotation-in-region-p (b e)
873   (or (map-extents (lambda (e u) t) nil b e nil nil 'mm t)
874       (if (= b e)
875           (eq (cadr (memq 'gnus-undeletable (text-properties-at b))) t)
876         (text-property-any b e 'gnus-undeletable t))))
877
878 (defun gnus-xmas-mime-button-menu (event)
879   "Construct a context-sensitive menu of MIME commands."
880   (interactive "e")
881   (let ((response (get-popup-menu-response
882                    `("MIME Part"
883                      ,@(mapcar (lambda (c) `[,(caddr c) ,(car c) t])
884                                gnus-mime-button-commands)))))
885     (set-buffer (event-buffer event))
886     (goto-char (event-point event))
887     (funcall (event-function response) (event-object response))))
888
889 (defun gnus-group-add-icon ()
890   "Add an icon to the current line according to `gnus-group-icon-list'."
891   (let* ((p (point))
892          (end (progn (end-of-line) (point)))
893          ;; now find out where the line starts and leave point there.
894          (beg (progn (beginning-of-line) (point))))
895     (save-restriction
896       (narrow-to-region beg end)
897       (goto-char beg)
898       (when (search-forward "==&&==" nil t)
899         (let* ((group (gnus-group-group-name))
900                (entry (gnus-group-entry group))
901                (unread (if (numberp (car entry)) (car entry) 0))
902                (active (gnus-active group))
903                (total (if active (1+ (- (cdr active) (car active))) 0))
904                (info (nth 2 entry))
905                (method (gnus-server-get-method group (gnus-info-method info)))
906                (marked (gnus-info-marks info))
907                (mailp (memq 'mail (assoc (symbol-name
908                                           (car (or method gnus-select-method)))
909                                          gnus-valid-select-methods)))
910                (level (or (gnus-info-level info) gnus-level-killed))
911                (score (or (gnus-info-score info) 0))
912                (ticked (gnus-range-length (cdr (assq 'tick marked))))
913                (group-age (gnus-group-timestamp-delta group))
914                (inhibit-read-only t)
915                (list gnus-group-icon-list)
916                (mystart (match-beginning 0))
917                (myend (match-end 0)))
918           (goto-char (point-min))
919           (while (and list
920                       (not (eval (caar list))))
921             (setq list (cdr list)))
922           (if list
923               (let* ((file (cdar list))
924                      (glyph (gnus-group-icon-create-glyph
925                              (buffer-substring mystart myend)
926                              file)))
927                 (if glyph
928                     (progn
929                       (mapcar 'delete-annotation (annotations-at myend))
930                       (let ((ext (make-extent mystart myend))
931                             (ant (make-annotation glyph myend 'text)))
932                         ;; set text extent params
933                         (set-extent-property ext 'end-open t)
934                         (set-extent-property ext 'start-open t)
935                         (set-extent-property ext 'invisible t)))
936                   (delete-region mystart myend)))
937             (delete-region mystart myend))))
938       (widen))
939     (goto-char p)))
940
941 (defun gnus-group-icon-create-glyph (substring pixmap)
942   "Create a glyph for insertion into a group line."
943   (or
944    (cdr-safe (assoc pixmap gnus-group-icon-cache))
945    (let* ((glyph (make-glyph
946                   (list
947                    (cons 'x
948                          (expand-file-name pixmap gnus-xmas-glyph-directory))
949                    (cons 'mswindows
950                          (expand-file-name pixmap gnus-xmas-glyph-directory))
951                    (cons 'tty substring)))))
952      (setq gnus-group-icon-cache
953            (cons (cons pixmap glyph) gnus-group-icon-cache))
954      (set-glyph-face glyph 'default)
955      glyph)))
956
957 (defun gnus-xmas-mailing-list-menu-add ()
958   (gnus-xmas-menu-add mailing-list
959                       gnus-mailing-list-menu))
960
961 (provide 'gnus-xmas)
962
963 ;;; gnus-xmas.el ends here