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