cgit.sxemacs.org Git - gnus/blob - lisp/gnus-xmas.el

   1 ;;; gnus-xmas.el --- Gnus functions for XEmacs
   2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   5 ;; Keywords: news
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (require 'gnus-load)
  29 (require 'text-props)
  30 (defvar menu-bar-mode (featurep 'menubar))
  31 (require 'messagexmas)
  32
  33 (defvar gnus-xmas-glyph-directory nil
  34   "*Directory where Gnus logos and icons are located.
  35 If this variable is nil, Gnus will try to locate the directory
  36 automatically.")
  37
  38 (defvar gnus-xmas-logo-color-alist
  39   '((flame "#cc3300" "#ff2200")
  40     (pine "#c0cc93" "#f8ffb8")
  41     (moss "#a1cc93" "#d2ffb8")
  42     (irish "#04cc90" "#05ff97")
  43     (sky "#049acc" "#05deff")
  44     (tin "#6886cc" "#82b6ff")
  45     (velvet "#7c68cc" "#8c82ff")
  46     (grape "#b264cc" "#cf7df")
  47     (labia "#cc64c2" "#fd7dff")
  48     (berry "#cc6485" "#ff7db5")
  49     (neutral "#b4b4b4" "#878787")
  50     (september "#bf9900" "#ffcc00"))
  51   "Color alist used for the Gnus logo.")
  52
  53 (defvar gnus-xmas-logo-color-style 'flame
  54   "Color styles used for the Gnus logo.")
  55
  56 (defvar gnus-xmas-logo-colors
  57   (cdr (assq gnus-xmas-logo-color-style gnus-xmas-logo-color-alist))
  58   "Colors used for the Gnus logo.")
  59
  60 (defvar gnus-article-x-face-command
  61   (if (featurep 'xface)
  62       'gnus-xmas-article-display-xface
  63     "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -")
  64   "String or function to be executed to display an X-Face header.
  65 If it is a string, the command will be executed in a sub-shell
  66 asynchronously.  The compressed face will be piped to this command.")
  67
  68 ;;; Internal variables.
  69
  70 ;; Don't warn about these undefined variables.
  71
  72 (defvar gnus-group-mode-hook)
  73 (defvar gnus-summary-mode-hook)
  74 (defvar gnus-article-mode-hook)
  75
  76 ;;defined in gnus.el
  77 (defvar gnus-active-hashtb)
  78 (defvar gnus-article-buffer)
  79 (defvar gnus-auto-center-summary)
  80 (defvar gnus-buffer-list)
  81 (defvar gnus-current-headers)
  82 (defvar gnus-level-killed)
  83 (defvar gnus-level-zombie)
  84 (defvar gnus-newsgroup-bookmarks)
  85 (defvar gnus-newsgroup-dependencies)
  86 (defvar gnus-newsgroup-selected-overlay)
  87 (defvar gnus-newsrc-hashtb)
  88 (defvar gnus-read-mark)
  89 (defvar gnus-refer-article-method)
  90 (defvar gnus-reffed-article-number)
  91 (defvar gnus-unread-mark)
  92 (defvar gnus-version)
  93 (defvar gnus-view-pseudos)
  94 (defvar gnus-view-pseudos-separately)
  95 (defvar gnus-visual)
  96 (defvar gnus-zombie-list)
  97 ;;defined in gnus-msg.el
  98 (defvar gnus-article-copy)
  99 (defvar gnus-check-before-posting)
 100 ;;defined in gnus-vis.el
 101 (defvar gnus-article-button-face)
 102 (defvar gnus-article-mouse-face)
 103 (defvar gnus-summary-selected-face)
 104 (defvar gnus-group-reading-menu)
 105 (defvar gnus-group-group-menu)
 106 (defvar gnus-group-misc-menu)
 107 (defvar gnus-summary-article-menu)
 108 (defvar gnus-summary-thread-menu)
 109 (defvar gnus-summary-misc-menu)
 110 (defvar gnus-summary-post-menu)
 111 (defvar gnus-summary-kill-menu)
 112 (defvar gnus-article-article-menu)
 113 (defvar gnus-article-treatment-menu)
 114 (defvar gnus-mouse-2)
 115 (defvar standard-display-table)
 116 (defvar gnus-tree-minimize-window)
 117
 118 (defun gnus-xmas-set-text-properties (start end props &optional buffer)
 119   "You should NEVER use this function.  It is ideologically blasphemous.
 120 It is provided only to ease porting of broken FSF Emacs programs."
 121   (if (stringp buffer)
 122       nil
 123     (map-extents (lambda (extent ignored)
 124                    (remove-text-properties
 125                     start end
 126                     (list (extent-property extent 'text-prop) nil)
 127                     buffer))
 128                  buffer start end nil nil 'text-prop)
 129     (gnus-add-text-properties start end props buffer)))
 130
 131 (defun gnus-xmas-highlight-selected-summary ()
 132   ;; Highlight selected article in summary buffer
 133   (when gnus-summary-selected-face
 134     (if gnus-newsgroup-selected-overlay
 135         (delete-extent gnus-newsgroup-selected-overlay))
 136     (setq gnus-newsgroup-selected-overlay
 137           (make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
 138     (set-extent-face gnus-newsgroup-selected-overlay
 139                      gnus-summary-selected-face)))
 140
 141 (defun gnus-xmas-summary-recenter ()
 142   "\"Center\" point in the summary window.
 143 If `gnus-auto-center-summary' is nil, or the article buffer isn't
 144 displayed, no centering will be performed."
 145   ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle).
 146   ;; Recenter only when requested.  Suggested by popovich@park.cs.columbia.edu.
 147   (when gnus-auto-center-summary
 148     (let* ((height (if (fboundp 'window-displayed-height)
 149                        (window-displayed-height)
 150                      (- (window-height) 2)))
 151            (top (cond ((< height 4) 0)
 152                       ((< height 7) 1)
 153                       (t 2)))
 154            (bottom (save-excursion (goto-char (point-max))
 155                                    (forward-line (- height))
 156                                    (point)))
 157            (window (get-buffer-window (current-buffer))))
 158       (when (get-buffer-window gnus-article-buffer)
 159         ;; Only do recentering when the article buffer is displayed,
 160         ;; Set the window start to either `bottom', which is the biggest
 161         ;; possible valid number, or the second line from the top,
 162         ;; whichever is the least.
 163         (set-window-start
 164          window (min bottom (save-excursion
 165                               (forward-line (- top)) (point)))))
 166       ;; Do horizontal recentering while we're at it.
 167       (when (and (get-buffer-window (current-buffer) t)
 168                  (not (eq gnus-auto-center-summary 'vertical)))
 169         (let ((selected (selected-window)))
 170           (select-window (get-buffer-window (current-buffer) t))
 171           (gnus-summary-position-point)
 172           (gnus-horizontal-recenter)
 173           (select-window selected))))))
 174
 175 (defun gnus-xmas-add-hook (hook function &optional append local)
 176   (add-hook hook function))
 177
 178 (defun gnus-xmas-add-text-properties (start end props &optional object)
 179   (add-text-properties start end props object)
 180   (put-text-property start end 'start-closed nil object))
 181
 182 (defun gnus-xmas-put-text-property (start end prop value &optional object)
 183   (put-text-property start end prop value object)
 184   (put-text-property start end 'start-closed nil object))
 185
 186 (defun gnus-xmas-extent-start-open (point)
 187   (map-extents (lambda (extent arg)
 188                  (set-extent-property extent 'start-open t))
 189                nil point (min (1+ (point)) (point-max))))
 190
 191 (defun gnus-xmas-article-push-button (event)
 192   "Check text under the mouse pointer for a callback function.
 193 If the text under the mouse pointer has a `gnus-callback' property,
 194 call it with the value of the `gnus-data' text property."
 195   (interactive "e")
 196   (set-buffer (window-buffer (event-window event)))
 197   (let* ((pos (event-closest-point event))
 198          (data (get-text-property pos 'gnus-data))
 199          (fun (get-text-property pos 'gnus-callback)))
 200     (if fun (funcall fun data))))
 201
 202 (defun gnus-xmas-move-overlay (extent start end &optional buffer)
 203   (set-extent-endpoints extent start end))
 204
 205 ;; Fixed by Christopher Davis <ckd@loiosh.kei.com>.
 206 (defun gnus-xmas-article-add-button (from to fun &optional data)
 207   "Create a button between FROM and TO with callback FUN and data DATA."
 208   (and gnus-article-button-face
 209        (gnus-overlay-put (gnus-make-overlay from to)
 210                          'face gnus-article-button-face))
 211   (gnus-add-text-properties
 212    from to
 213    (nconc
 214     (and gnus-article-mouse-face
 215          (list 'mouse-face gnus-article-mouse-face))
 216     (list 'gnus-callback fun)
 217     (and data (list 'gnus-data data))
 218     (list 'highlight t))))
 219
 220 (defun gnus-xmas-window-top-edge (&optional window)
 221   (nth 1 (window-pixel-edges window)))
 222
 223 (defun gnus-xmas-tree-minimize ()
 224   (when (and gnus-tree-minimize-window
 225              (not (one-window-p)))
 226     (let* ((window-min-height 2)
 227            (height (1+ (count-lines (point-min) (point-max))))
 228            (min (max (1- window-min-height) height))
 229            (tot (if (numberp gnus-tree-minimize-window)
 230                     (min gnus-tree-minimize-window min)
 231                   min))
 232            (win (get-buffer-window (current-buffer)))
 233            (wh (and win (1- (window-height win)))))
 234       (when (and win
 235                  (not (eq tot wh)))
 236         (let ((selected (selected-window)))
 237           (select-window win)
 238           (enlarge-window (- tot wh))
 239           (select-window selected))))))
 240
 241 ;; Select the lowest window on the frame.
 242 (defun gnus-xmas-appt-select-lowest-window ()
 243   (let* ((lowest-window (selected-window))
 244          (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
 245          (last-window (previous-window))
 246          (window-search t))
 247     (while window-search
 248       (let* ((this-window (next-window))
 249              (next-bottom-edge (car (cdr (cdr (cdr
 250                                                (window-pixel-edges
 251                                                 this-window)))))))
 252         (if (< bottom-edge next-bottom-edge)
 253             (progn
 254               (setq bottom-edge next-bottom-edge)
 255               (setq lowest-window this-window)))
 256
 257         (select-window this-window)
 258         (if (eq last-window this-window)
 259             (progn
 260               (select-window lowest-window)
 261               (setq window-search nil)))))))
 262
 263 (defmacro gnus-xmas-menu-add (type &rest menus)
 264   `(gnus-xmas-menu-add-1 ',type ',menus))
 265 (put 'gnus-xmas-menu-add 'lisp-indent-function 1)
 266 (put 'gnus-xmas-menu-add 'lisp-indent-hook 1)
 267
 268 (defun gnus-xmas-menu-add-1 (type menus)
 269   (when (and menu-bar-mode
 270              (gnus-visual-p (intern (format "%s-menu" type)) 'menu))
 271     (while menus
 272       (easy-menu-add (symbol-value (pop menus))))))
 273
 274 (defun gnus-xmas-group-menu-add ()
 275   (gnus-xmas-menu-add group
 276                       gnus-group-reading-menu gnus-group-group-menu gnus-group-misc-menu))
 277
 278 (defun gnus-xmas-summary-menu-add ()
 279   (gnus-xmas-menu-add summary
 280                       gnus-summary-misc-menu gnus-summary-kill-menu
 281                       gnus-summary-article-menu gnus-summary-thread-menu
 282                       gnus-summary-post-menu ))
 283
 284 (defun gnus-xmas-article-menu-add ()
 285   (gnus-xmas-menu-add article
 286                       gnus-article-article-menu gnus-article-treatment-menu))
 287
 288 (defun gnus-xmas-score-menu-add ()
 289   (gnus-xmas-menu-add score
 290                       gnus-score-menu))
 291
 292 (defun gnus-xmas-pick-menu-add ()
 293   (gnus-xmas-menu-add pick
 294                       gnus-pick-menu))
 295
 296 (defun gnus-xmas-binary-menu-add ()
 297   (gnus-xmas-menu-add binary
 298                       gnus-binary-menu))
 299
 300 (defun gnus-xmas-tree-menu-add ()
 301   (gnus-xmas-menu-add tree
 302                       gnus-tree-menu))
 303
 304 (defun gnus-xmas-server-menu-add ()
 305   (gnus-xmas-menu-add menu
 306                       gnus-server-server-menu gnus-server-connections-menu))
 307
 308 (defun gnus-xmas-browse-menu-add ()
 309   (gnus-xmas-menu-add browse
 310                       gnus-browse-menu))
 311
 312 (defun gnus-xmas-grouplens-menu-add ()
 313   (gnus-xmas-menu-add grouplens
 314                       gnus-grouplens-menu))
 315
 316 (defun gnus-xmas-read-event-char ()
 317   "Get the next event."
 318   (let ((event (next-event)))
 319     ;; We junk all non-key events.  Is this naughty?
 320     (while (not (key-press-event-p event))
 321       (setq event (next-event)))
 322     (cons (and (key-press-event-p event)
 323                                         ; (numberp (event-key event))
 324                (event-to-character event))
 325           event)))
 326
 327 (defun gnus-xmas-group-remove-excess-properties ()
 328   (let ((end (point))
 329         (beg (progn (forward-line -1) (point))))
 330     (remove-text-properties (1+ beg) end '(gnus-group nil))
 331     (remove-text-properties
 332      beg end
 333      '(gnus-topic nil gnus-topic-level nil gnus-topic-visible nil))
 334     (goto-char end)
 335     (map-extents
 336      (lambda (e ma)
 337        (set-extent-property e 'start-closed t))
 338      (current-buffer) beg end)))
 339
 340 (defun gnus-xmas-topic-remove-excess-properties ()
 341   (let ((end (point))
 342         (beg (progn (forward-line -1) (point))))
 343     (remove-text-properties beg end '(gnus-group nil gnus-unread nil))
 344     (remove-text-properties (1+ beg) end '(gnus-topic nil))
 345     (goto-char end)))
 346
 347 (defun gnus-xmas-seconds-since-epoch (date)
 348   "Return a floating point number that says how many seconds have lapsed between Jan 1 12:00:00 1970 and DATE."
 349   (let* ((tdate (mapcar (lambda (ti) (and ti (string-to-int ti)))
 350                         (timezone-parse-date date)))
 351          (ttime (mapcar (lambda (ti) (and ti (string-to-int ti)))
 352                         (timezone-parse-time
 353                          (aref (timezone-parse-date date) 3))))
 354          (edate (mapcar (lambda (ti) (and ti (string-to-int ti)))
 355                         (timezone-parse-date "Jan 1 12:00:00 1970")))
 356          (tday (- (timezone-absolute-from-gregorian
 357                    (nth 1 tdate) (nth 2 tdate) (nth 0 tdate))
 358                   (timezone-absolute-from-gregorian
 359                    (nth 1 edate) (nth 2 edate) (nth 0 edate)))))
 360     (+ (nth 2 ttime)
 361        (* (nth 1 ttime) 60)
 362        (* (float (nth 0 ttime)) 60 60)
 363        (* (float tday) 60 60 24))))
 364
 365 (defun gnus-xmas-define ()
 366   (setq gnus-mouse-2 [button2])
 367
 368   (or (memq 'underline (face-list))
 369       (and (fboundp 'make-face)
 370            (funcall (intern "make-face") 'underline)))
 371   ;; Must avoid calling set-face-underline-p directly, because it
 372   ;; is a defsubst in emacs19, and will make the .elc files non
 373   ;; portable!
 374   (or (face-differs-from-default-p 'underline)
 375       (funcall (intern "set-face-underline-p") 'underline t))
 376
 377   (fset 'gnus-make-overlay 'make-extent)
 378   (fset 'gnus-overlay-put 'set-extent-property)
 379   (fset 'gnus-move-overlay 'gnus-xmas-move-overlay)
 380   (fset 'gnus-overlay-end 'extent-end-position)
 381   (fset 'gnus-extent-detached-p 'extent-detached-p)
 382   (fset 'gnus-add-text-properties 'gnus-xmas-add-text-properties)
 383   (fset 'gnus-put-text-property 'gnus-xmas-put-text-property)
 384
 385   (require 'text-props)
 386   (if (< emacs-minor-version 14)
 387       (fset 'gnus-set-text-properties 'gnus-xmas-set-text-properties))
 388
 389   (or (boundp 'standard-display-table) (setq standard-display-table nil))
 390
 391   (defvar gnus-mouse-face-prop 'highlight)
 392
 393   (unless (fboundp 'encode-time)
 394     (defun encode-time (sec minute hour day month year &optional zone)
 395       (let ((seconds
 396              (gnus-xmas-seconds-since-epoch
 397               (timezone-make-arpa-date
 398                year month day (timezone-make-time-string hour minute sec)
 399                zone))))
 400         (list (floor (/ seconds (expt 2 16)))
 401               (round (mod seconds (expt 2 16)))))))
 402
 403   (defun gnus-byte-code (func)
 404     "Return a form that can be `eval'ed based on FUNC."
 405     (let ((fval (symbol-function func)))
 406       (if (compiled-function-p fval)
 407           (list 'funcall fval)
 408         (cons 'progn (cdr (cdr fval))))))
 409
 410   ;; Fix by "jeff (j.d.) sparkes" <jsparkes@bnr.ca>.
 411   (defvar gnus-display-type (device-class)
 412     "A symbol indicating the display Emacs is running under.
 413 The symbol should be one of `color', `grayscale' or `mono'.  If Emacs
 414 guesses this display attribute wrongly, either set this variable in
 415 your `~/.emacs' or set the resource `Emacs.displayType' in your
 416 `~/.Xdefaults'.  See also `gnus-background-mode'.
 417
 418 This is a meta-variable that will affect what default values other
 419 variables get.  You would normally not change this variable, but
 420 pounce directly on the real variables themselves.")
 421
 422
 423   (fset 'gnus-x-color-values
 424         (if (fboundp 'x-color-values)
 425             'x-color-values
 426           (lambda (color)
 427             (color-instance-rgb-components
 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
 461
 462 (defun gnus-xmas-redefine ()
 463   "Redefine lots of Gnus functions for XEmacs."
 464   (fset 'gnus-summary-make-display-table 'ignore)
 465   (fset 'gnus-visual-turn-off-edit-menu 'identity)
 466   (fset 'gnus-summary-recenter 'gnus-xmas-summary-recenter)
 467   (fset 'gnus-extent-start-open 'gnus-xmas-extent-start-open)
 468   (fset 'gnus-article-push-button 'gnus-xmas-article-push-button)
 469   (fset 'gnus-article-add-button 'gnus-xmas-article-add-button)
 470   (fset 'gnus-window-top-edge 'gnus-xmas-window-top-edge)
 471   (fset 'gnus-read-event-char 'gnus-xmas-read-event-char)
 472   (fset 'gnus-group-startup-message 'gnus-xmas-group-startup-message)
 473   (fset 'gnus-tree-minimize 'gnus-xmas-tree-minimize)
 474   (fset 'gnus-appt-select-lowest-window
 475         'gnus-xmas-appt-select-lowest-window)
 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)
 479   (fset 'gnus-character-to-event 'character-to-event)
 480   (fset 'gnus-article-show-hidden-text 'gnus-xmas-article-show-hidden-text)
 481   (fset 'gnus-mode-line-buffer-identification
 482         'gnus-xmas-mode-line-buffer-identification)
 483
 484   (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add)
 485   (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add)
 486   (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add)
 487   (add-hook 'gnus-score-mode-hook 'gnus-xmas-score-menu-add)
 488
 489   (add-hook 'gnus-pick-mode-hook 'gnus-xmas-pick-menu-add)
 490   (add-hook 'gnus-tree-mode-hook 'gnus-xmas-tree-menu-add)
 491   (add-hook 'gnus-binary-mode-hook 'gnus-xmas-binary-menu-add)
 492   (add-hook 'gnus-grouplens-mode-hook 'gnus-xmas-grouplens-menu-add)
 493   (add-hook 'gnus-server-mode-hook 'gnus-xmas-server-menu-add)
 494   (add-hook 'gnus-browse-mode-hook 'gnus-xmas-browse-menu-add)
 495
 496   (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar)
 497   (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar)
 498
 499   (when (and (<= emacs-major-version 19)
 500              (<= emacs-minor-version 13))
 501     (setq gnus-article-x-face-too-ugly (if (eq (device-type) 'tty) "."))
 502     (fset 'gnus-highlight-selected-summary
 503           'gnus-xmas-highlight-selected-summary)
 504     (fset 'gnus-group-remove-excess-properties
 505           'gnus-xmas-group-remove-excess-properties)
 506     (fset 'gnus-topic-remove-excess-properties
 507           'gnus-xmas-topic-remove-excess-properties)
 508     (fset 'gnus-mode-line-buffer-identification 'identity)
 509     (unless (boundp 'shell-command-switch)
 510       (setq shell-command-switch "-c"))
 511     ))
 512
 513
 514 ;;; XEmacs logo and toolbar.
 515
 516 (defun gnus-xmas-group-startup-message (&optional x y)
 517   "Insert startup message in current buffer."
 518   ;; Insert the message.
 519   (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
 520   (erase-buffer)
 521   (let ((logo (and gnus-xmas-glyph-directory
 522                    (concat
 523                     (file-name-as-directory gnus-xmas-glyph-directory)
 524                     "gnus."
 525                     (if (featurep 'xpm) "xpm" "xbm"))))
 526         (xpm-color-symbols
 527          (and (featurep 'xpm)
 528               (append `(("thing" ,(car gnus-xmas-logo-colors))
 529                         ("shadow" ,(cadr gnus-xmas-logo-colors)))
 530                       xpm-color-symbols))))
 531     (if (and (featurep 'xpm)
 532              (not (equal (device-type) 'tty))
 533              logo
 534              (file-exists-p logo))
 535         (progn
 536           (setq logo (make-glyph logo))
 537           (insert " ")
 538           (set-extent-begin-glyph (make-extent (point) (point)) logo)
 539           (goto-char (point-min))
 540           (while (not (eobp))
 541             (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
 542                                  ? ))
 543             (forward-line 1))
 544           (goto-char (point-min))
 545           (let* ((pheight (+ 20 (count-lines (point-min) (point-max))))
 546                  (wheight (window-height))
 547                  (rest (- wheight pheight)))
 548             (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
 549
 550       (insert
 551        (format "              %s
 552           _    ___ _             _
 553           _ ___ __ ___  __    _ ___
 554           __   _     ___    __  ___
 555               _           ___     _
 556              _  _ __             _
 557              ___   __            _
 558                    __           _
 559                     _      _   _
 560                    _      _    _
 561                       _  _    _
 562                   __  ___
 563                  _   _ _     _
 564                 _   _
 565               _    _
 566              _    _
 567             _
 568           __
 569
 570 "
 571                ""))
 572       ;; And then hack it.
 573       (gnus-indent-rigidly (point-min) (point-max)
 574                            (/ (max (- (window-width) (or x 46)) 0) 2))
 575       (goto-char (point-min))
 576       (forward-line 1)
 577       (let* ((pheight (count-lines (point-min) (point-max)))
 578              (wheight (window-height))
 579              (rest (- wheight pheight)))
 580         (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
 581     ;; Fontify some.
 582     (goto-char (point-min))
 583     (and (search-forward "Praxis" nil t)
 584          (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
 585     (goto-char (point-min))
 586     (setq modeline-buffer-identification
 587           (list (concat gnus-version ": *Group*")))
 588     (set-buffer-modified-p t)))
 589
 590
 591 ;;; The toolbar.
 592
 593 (defvar gnus-use-toolbar (if (featurep 'toolbar)
 594                              'default-toolbar
 595                            nil)
 596   "*If nil, do not use a toolbar.
 597 If it is non-nil, it must be a toolbar.  The five legal values are
 598 `default-toolbar', `top-toolbar', `bottom-toolbar',
 599 `right-toolbar', and `left-toolbar'.")
 600
 601 (defvar gnus-group-toolbar
 602   '(
 603     [gnus-group-get-new-news gnus-group-get-new-news t "Get new news"]
 604     [gnus-group-get-new-news-this-group
 605      gnus-group-get-new-news-this-group t "Get new news in this group"]
 606     [gnus-group-catchup-current
 607      gnus-group-catchup-current t "Catchup group"]
 608     [gnus-group-describe-group
 609      gnus-group-describe-group t "Describe group"]
 610     [gnus-group-kill-group gnus-group-kill-group t "Kill group"]
 611     [gnus-group-exit gnus-group-exit t "Exit Gnus"]
 612     )
 613   "The group buffer toolbar.")
 614
 615 (defvar gnus-summary-toolbar
 616   '(
 617     [gnus-summary-prev-unread
 618      gnus-summary-prev-unread-article t "Prev unread article"]
 619     [gnus-summary-next-unread
 620      gnus-summary-next-unread-article t "Next unread article"]
 621     [gnus-summary-post-news
 622      gnus-summary-post-news t "Post an article"]
 623     [gnus-summary-followup-with-original
 624      gnus-summary-followup-with-original t
 625      "Post a followup and yank the original"]
 626     [gnus-summary-followup
 627      gnus-summary-followup t "Post a followup"]
 628     [gnus-summary-reply-with-original
 629      gnus-summary-reply-with-original t "Mail a reply and yank the original"]
 630     [gnus-summary-reply
 631      gnus-summary-reply t "Mail a reply"]
 632     [gnus-summary-caesar-message
 633      gnus-summary-caesar-message t "Rot 13"]
 634     [gnus-uu-decode-uu
 635      gnus-uu-decode-uu t "Decode uuencoded articles"]
 636     [gnus-summary-save-article-file
 637      gnus-summary-save-article-file t "Save article in file"]
 638     [gnus-summary-save-article
 639      gnus-summary-save-article t "Save article"]
 640     [gnus-uu-post-news
 641      gnus-uu-post-news t "Post an uuencoded article"]
 642     [gnus-summary-cancel-article
 643      gnus-summary-cancel-article t "Cancel article"]
 644     [gnus-summary-catchup-and-exit
 645      gnus-summary-catchup-and-exit t "Catchup and exit"]
 646     [gnus-summary-exit gnus-summary-exit t "Exit this summary"]
 647     )
 648   "The summary buffer toolbar.")
 649
 650 (defvar gnus-summary-mail-toolbar
 651   '(
 652     [gnus-summary-prev-unread
 653      gnus-summary-prev-unread-article t "Prev unread article"]
 654     [gnus-summary-next-unread
 655      gnus-summary-next-unread-article t "Next unread article"]
 656     [gnus-summary-mail-reply gnus-summary-reply t "Reply"]
 657 ;    [gnus-summary-mail-get gnus-mail-get t "Message get"]
 658     [gnus-summary-mail-originate gnus-summary-post-news t "Originate"]
 659     [gnus-summary-mail-save gnus-summary-save-article t "Save"]
 660     [gnus-summary-mail-copy gnus-summary-copy-article t "Copy message"]
 661 ;    [gnus-summary-mail-delete gnus-summary-delete-article t "Delete message"]
 662     [gnus-summary-mail-forward gnus-summary-mail-forward t "Forward message"]
 663 ;    [gnus-summary-mail-spell gnus-mail-spell t "Spell"]
 664 ;    [gnus-summary-mail-help gnus-mail-help  t "Message help"]
 665     [gnus-summary-caesar-message
 666      gnus-summary-caesar-message t "Rot 13"]
 667     [gnus-uu-decode-uu
 668      gnus-uu-decode-uu t "Decode uuencoded articles"]
 669     [gnus-summary-save-article-file
 670      gnus-summary-save-article-file t "Save article in file"]
 671     [gnus-summary-save-article
 672      gnus-summary-save-article t "Save article"]
 673     [gnus-summary-catchup-and-exit
 674      gnus-summary-catchup-and-exit t "Catchup and exit"]
 675     [gnus-summary-exit gnus-summary-exit t "Exit this summary"]
 676     )
 677   "The summary buffer mail toolbar.")
 678
 679 (defun gnus-xmas-setup-group-toolbar ()
 680   (and gnus-use-toolbar
 681        (message-xmas-setup-toolbar gnus-group-toolbar nil "gnus")
 682        (set-specifier (symbol-value gnus-use-toolbar)
 683                       (cons (current-buffer) gnus-group-toolbar))))
 684
 685 (defun gnus-xmas-setup-summary-toolbar ()
 686   (let ((bar (if (gnus-news-group-p gnus-newsgroup-name)
 687                  gnus-summary-toolbar gnus-summary-mail-toolbar)))
 688     (and gnus-use-toolbar
 689          (message-xmas-setup-toolbar bar nil "gnus")
 690          (set-specifier (symbol-value gnus-use-toolbar)
 691                         (cons (current-buffer) bar)))))
 692
 693 (defun gnus-xmas-mail-strip-quoted-names (address)
 694   "Protect mail-strip-quoted-names from NIL input.
 695 XEmacs compatibility workaround."
 696   (if (null address)
 697       nil
 698     (mail-strip-quoted-names address)))
 699
 700 (defun gnus-xmas-call-region (command &rest args)
 701   (apply
 702    'call-process-region (point-min) (point-max) command t '(t nil) nil
 703    args))
 704
 705 (unless (find-face 'gnus-x-face)
 706   (copy-face 'default 'gnus-x-face)
 707   (set-face-foreground 'gnus-x-face "black")
 708   (set-face-background 'gnus-x-face "white"))
 709
 710 (defun gnus-xmas-article-display-xface (beg end)
 711   "Display any XFace headers in the current article."
 712   (save-excursion
 713     (let (xface-glyph)
 714       (if (featurep 'xface)
 715           (setq xface-glyph
 716                 (make-glyph (vector 'xface :data
 717                                     (concat "X-Face: "
 718                                             (buffer-substring beg end)))))
 719         (let ((cur (current-buffer)))
 720           (save-excursion
 721             (gnus-set-work-buffer)
 722             (insert (format "%s" (buffer-substring beg end cur)))
 723             (gnus-xmas-call-region "uncompface")
 724             (goto-char (point-min))
 725             (insert "/* Width=48, Height=48 */\n")
 726             (gnus-xmas-call-region "icontopbm")
 727             (gnus-xmas-call-region "ppmtoxpm")
 728             (setq xface-glyph
 729                   (make-glyph
 730                    (vector 'xpm :data (buffer-string )))))))
 731       (set-glyph-face xface-glyph 'gnus-x-face)
 732       (goto-char (point-min))
 733       (re-search-forward "^From:" nil t)
 734       (set-extent-begin-glyph
 735        (make-extent (point) (1+ (point))) xface-glyph))))
 736
 737 (defun gnus-xmas-article-show-hidden-text (type &optional hide)
 738   "Show all hidden text of type TYPE.
 739 If HIDE, hide the text instead."
 740   (save-excursion
 741     (set-buffer gnus-article-buffer)
 742     (let ((buffer-read-only nil)
 743           (inhibit-point-motion-hooks t)
 744           (beg (point-min)))
 745       (while (gnus-goto-char (text-property-any
 746                               beg (point-max) 'gnus-type type))
 747         (setq beg (point))
 748         (forward-char)
 749         (if hide
 750             (article-hide-text beg (point) gnus-hidden-properties)
 751           (article-unhide-text beg (point)))
 752         (setq beg (point)))
 753       (save-window-excursion
 754         (select-window (get-buffer-window (current-buffer)))
 755         (recenter))
 756       t)))
 757
 758 (defvar gnus-xmas-pointer-glyph
 759   (progn
 760     (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
 761     (make-pointer-glyph (concat gnus-xmas-glyph-directory "gnus-pointer."
 762                                 (if (featurep 'xpm) "xpm" "xbm")))))
 763
 764 (defvar gnus-xmas-modeline-left-extent
 765   (let ((ext (copy-extent modeline-buffer-id-left-extent)))
 766     ;(set-extent-property ext 'pointer gnus-xmas-pointer-glyph)
 767     ext))
 768
 769 (defvar gnus-xmas-modeline-right-extent
 770   (let ((ext (copy-extent modeline-buffer-id-right-extent)))
 771     ;(set-extent-property ext 'pointer gnus-xmas-pointer-glyph)
 772     ext))
 773
 774 (defvar gnus-xmas-modeline-glyph
 775   (progn
 776     (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
 777     (let* ((file (concat gnus-xmas-glyph-directory "gnus-pointer."
 778                          (if (featurep 'xpm) "xpm" "xbm")))
 779            (glyph (make-glyph file)))
 780       (when (and (featurep 'x)
 781                  (file-exists-p file))
 782         (set-glyph-face glyph 'modeline-buffer-id))
 783       (set-glyph-property glyph 'image (cons 'tty "Gnus:"))
 784       glyph)))
 785
 786 (defun gnus-xmas-mode-line-buffer-identification (line)
 787   (let ((line (car line))
 788         chop)
 789     (if (not (stringp line))
 790         (list line)
 791       (when (string-match "^Gnus:" line)
 792         (setq chop (match-end 0))
 793         (list
 794          (if gnus-xmas-modeline-glyph
 795              (cons gnus-xmas-modeline-left-extent gnus-xmas-modeline-glyph)
 796            (cons gnus-xmas-modeline-left-extent (substring line 0 chop)))
 797          (cons gnus-xmas-modeline-right-extent (substring line chop)))))))
 798
 799 (provide 'gnus-xmas)
 800
 801 ;;; gnus-xmas.el ends here