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 'text-props)
  29 (eval-when-compile (require 'cl))
  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 'september
  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-copy-article-buffer (&optional article-buffer)
 192   (setq gnus-article-copy (get-buffer-create " *gnus article copy*"))
 193   (buffer-disable-undo gnus-article-copy)
 194   (or (memq gnus-article-copy gnus-buffer-list)
 195       (setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list)))
 196   (let ((article-buffer (or article-buffer gnus-article-buffer))
 197         buf)
 198     (if (and (get-buffer article-buffer)
 199              (buffer-name (get-buffer article-buffer)))
 200         (save-excursion
 201           (set-buffer article-buffer)
 202           (widen)
 203           (setq buf (buffer-substring (point-min) (point-max)))
 204           (set-buffer gnus-article-copy)
 205           (erase-buffer)
 206           (insert (format "%s" buf))))
 207     gnus-article-copy))
 208
 209 (defun gnus-xmas-article-push-button (event)
 210   "Check text under the mouse pointer for a callback function.
 211 If the text under the mouse pointer has a `gnus-callback' property,
 212 call it with the value of the `gnus-data' text property."
 213   (interactive "e")
 214   (set-buffer (window-buffer (event-window event)))
 215   (let* ((pos (event-closest-point event))
 216          (data (get-text-property pos 'gnus-data))
 217          (fun (get-text-property pos 'gnus-callback)))
 218     (if fun (funcall fun data))))
 219
 220 (defun gnus-xmas-move-overlay (extent start end &optional buffer)
 221   (set-extent-endpoints extent start end))
 222
 223 ;; Fixed by Christopher Davis <ckd@loiosh.kei.com>.
 224 (defun gnus-xmas-article-add-button (from to fun &optional data)
 225   "Create a button between FROM and TO with callback FUN and data DATA."
 226   (and gnus-article-button-face
 227        (gnus-overlay-put (gnus-make-overlay from to)
 228                          'face gnus-article-button-face))
 229   (gnus-add-text-properties
 230    from to
 231    (nconc
 232     (and gnus-article-mouse-face
 233          (list 'mouse-face gnus-article-mouse-face))
 234     (list 'gnus-callback fun)
 235     (and data (list 'gnus-data data))
 236     (list 'highlight t))))
 237
 238 (defun gnus-xmas-window-top-edge (&optional window)
 239   (nth 1 (window-pixel-edges window)))
 240
 241 (defun gnus-xmas-tree-minimize ()
 242   (when (and gnus-tree-minimize-window
 243              (not (one-window-p)))
 244     (let* ((window-min-height 2)
 245            (height (1+ (count-lines (point-min) (point-max))))
 246            (min (max (1- window-min-height) height))
 247            (tot (if (numberp gnus-tree-minimize-window)
 248                     (min gnus-tree-minimize-window min)
 249                   min))
 250            (win (get-buffer-window (current-buffer)))
 251            (wh (and win (1- (window-height win)))))
 252       (when (and win
 253                  (not (eq tot wh)))
 254         (let ((selected (selected-window)))
 255           (select-window win)
 256           (enlarge-window (- tot wh))
 257           (select-window selected))))))
 258
 259 ;; Select the lowest window on the frame.
 260 (defun gnus-xmas-appt-select-lowest-window ()
 261   (let* ((lowest-window (selected-window))
 262          (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
 263          (last-window (previous-window))
 264          (window-search t))
 265     (while window-search
 266       (let* ((this-window (next-window))
 267              (next-bottom-edge (car (cdr (cdr (cdr
 268                                                (window-pixel-edges
 269                                                 this-window)))))))
 270         (if (< bottom-edge next-bottom-edge)
 271             (progn
 272               (setq bottom-edge next-bottom-edge)
 273               (setq lowest-window this-window)))
 274
 275         (select-window this-window)
 276         (if (eq last-window this-window)
 277             (progn
 278               (select-window lowest-window)
 279               (setq window-search nil)))))))
 280
 281 (defmacro gnus-xmas-menu-add (type &rest menus)
 282   `(gnus-xmas-menu-add-1 ',type ',menus))
 283 (put 'gnus-xmas-menu-add 'lisp-indent-function 1)
 284 (put 'gnus-xmas-menu-add 'lisp-indent-hook 1)
 285
 286 (defun gnus-xmas-menu-add-1 (type menus)
 287   (when (and menu-bar-mode
 288              (gnus-visual-p (intern (format "%s-menu" type)) 'menu))
 289     (while menus
 290       (easy-menu-add (symbol-value (pop menus))))))
 291
 292 (defun gnus-xmas-group-menu-add ()
 293   (gnus-xmas-menu-add group
 294     gnus-group-reading-menu gnus-group-group-menu gnus-group-misc-menu))
 295
 296 (defun gnus-xmas-summary-menu-add ()
 297   (gnus-xmas-menu-add summary
 298     gnus-summary-misc-menu gnus-summary-kill-menu
 299     gnus-summary-article-menu gnus-summary-thread-menu
 300     gnus-summary-post-menu ))
 301
 302 (defun gnus-xmas-article-menu-add ()
 303   (gnus-xmas-menu-add article
 304     gnus-article-article-menu gnus-article-treatment-menu))
 305
 306 (defun gnus-xmas-score-menu-add ()
 307   (gnus-xmas-menu-add score
 308     gnus-score-menu))
 309
 310 (defun gnus-xmas-pick-menu-add ()
 311   (gnus-xmas-menu-add pick
 312     gnus-pick-menu))
 313
 314 (defun gnus-xmas-binary-menu-add ()
 315   (gnus-xmas-menu-add binary
 316     gnus-binary-menu))
 317
 318 (defun gnus-xmas-tree-menu-add ()
 319   (gnus-xmas-menu-add tree
 320     gnus-tree-menu))
 321
 322 (defun gnus-xmas-server-menu-add ()
 323   (gnus-xmas-menu-add menu
 324     gnus-server-server-menu gnus-server-connections-menu))
 325
 326 (defun gnus-xmas-browse-menu-add ()
 327   (gnus-xmas-menu-add browse
 328     gnus-browse-menu))
 329
 330 (defun gnus-xmas-grouplens-menu-add ()
 331   (gnus-xmas-menu-add grouplens
 332     gnus-grouplens-menu))
 333
 334 (defun gnus-xmas-read-event-char ()
 335   "Get the next event."
 336   (let ((event (next-event)))
 337     ;; We junk all non-key events.  Is this naughty?
 338     (while (not (key-press-event-p event))
 339       (setq event (next-event)))
 340     (cons (and (key-press-event-p event)
 341               ; (numberp (event-key event))
 342                (event-to-character event))
 343           event)))
 344
 345 (defun gnus-xmas-group-remove-excess-properties ()
 346   (let ((end (point))
 347         (beg (progn (forward-line -1) (point))))
 348     (remove-text-properties (1+ beg) end '(gnus-group nil))
 349     (remove-text-properties
 350      beg end
 351      '(gnus-topic nil gnus-topic-level nil gnus-topic-visible nil))
 352     (goto-char end)
 353     (map-extents
 354      (lambda (e ma)
 355        (set-extent-property e 'start-closed t))
 356      (current-buffer) beg end)))
 357
 358 (defun gnus-xmas-topic-remove-excess-properties ()
 359   (let ((end (point))
 360         (beg (progn (forward-line -1) (point))))
 361     (remove-text-properties beg end '(gnus-group nil gnus-unread nil))
 362     (remove-text-properties (1+ beg) end '(gnus-topic nil))
 363     (goto-char end)))
 364
 365 (defun gnus-xmas-seconds-since-epoch (date)
 366   "Return a floating point number that says how many seconds have lapsed between Jan 1 12:00:00 1970 and DATE."
 367   (let* ((tdate (mapcar (lambda (ti) (and ti (string-to-int ti)))
 368                         (timezone-parse-date date)))
 369          (ttime (mapcar (lambda (ti) (and ti (string-to-int ti)))
 370                         (timezone-parse-time
 371                          (aref (timezone-parse-date date) 3))))
 372          (edate (mapcar (lambda (ti) (and ti (string-to-int ti)))
 373                         (timezone-parse-date "Jan 1 12:00:00 1970")))
 374          (tday (- (timezone-absolute-from-gregorian
 375                    (nth 1 tdate) (nth 2 tdate) (nth 0 tdate))
 376                   (timezone-absolute-from-gregorian
 377                    (nth 1 edate) (nth 2 edate) (nth 0 edate)))))
 378     (+ (nth 2 ttime)
 379        (* (nth 1 ttime) 60)
 380        (* (float (nth 0 ttime)) 60 60)
 381        (* (float tday) 60 60 24))))
 382
 383 (defun gnus-xmas-define ()
 384   (setq gnus-mouse-2 [button2])
 385
 386   (or (memq 'underline (face-list))
 387       (and (fboundp 'make-face)
 388            (funcall (intern "make-face") 'underline)))
 389   ;; Must avoid calling set-face-underline-p directly, because it
 390   ;; is a defsubst in emacs19, and will make the .elc files non
 391   ;; portable!
 392   (or (face-differs-from-default-p 'underline)
 393       (funcall (intern "set-face-underline-p") 'underline t))
 394
 395   (fset 'gnus-make-overlay 'make-extent)
 396   (fset 'gnus-overlay-put 'set-extent-property)
 397   (fset 'gnus-move-overlay 'gnus-xmas-move-overlay)
 398   (fset 'gnus-overlay-end 'extent-end-position)
 399   (fset 'gnus-extent-detached-p 'extent-detached-p)
 400   (fset 'gnus-add-text-properties 'gnus-xmas-add-text-properties)
 401   (fset 'gnus-put-text-property 'gnus-xmas-put-text-property)
 402
 403   (require 'text-props)
 404   (if (< emacs-minor-version 14)
 405       (fset 'gnus-set-text-properties 'gnus-xmas-set-text-properties))
 406
 407   (or (boundp 'standard-display-table) (setq standard-display-table nil))
 408
 409   (defvar gnus-mouse-face-prop 'highlight)
 410
 411   (unless (fboundp 'encode-time)
 412     (defun encode-time (sec minute hour day month year &optional zone)
 413       (let ((seconds
 414              (gnus-xmas-seconds-since-epoch
 415               (timezone-make-arpa-date
 416                year month day (timezone-make-time-string hour minute sec)
 417                zone))))
 418         (list (floor (/ seconds (expt 2 16)))
 419               (round (mod seconds (expt 2 16)))))))
 420
 421   (defun gnus-byte-code (func)
 422     "Return a form that can be `eval'ed based on FUNC."
 423     (let ((fval (symbol-function func)))
 424       (if (compiled-function-p fval)
 425           (list 'funcall fval)
 426         (cons 'progn (cdr (cdr fval))))))
 427
 428   ;; Fix by "jeff (j.d.) sparkes" <jsparkes@bnr.ca>.
 429   (defvar gnus-display-type (device-class)
 430     "A symbol indicating the display Emacs is running under.
 431 The symbol should be one of `color', `grayscale' or `mono'. If Emacs
 432 guesses this display attribute wrongly, either set this variable in
 433 your `~/.emacs' or set the resource `Emacs.displayType' in your
 434 `~/.Xdefaults'. See also `gnus-background-mode'.
 435
 436 This is a meta-variable that will affect what default values other
 437 variables get.  You would normally not change this variable, but
 438 pounce directly on the real variables themselves.")
 439
 440
 441   (fset 'gnus-x-color-values
 442         (if (fboundp 'x-color-values)
 443             'x-color-values
 444           (lambda (color)
 445             (color-instance-rgb-components
 446              (make-color-instance color)))))
 447
 448   (defvar gnus-background-mode
 449     (let* ((bg-resource
 450             (condition-case ()
 451                 (x-get-resource ".backgroundMode" "BackgroundMode" 'string)
 452               (error nil)))
 453            (params (frame-parameters))
 454            (color (condition-case ()
 455                       (or (assq 'background-color params)
 456                           (color-instance-name
 457                            (specifier-instance
 458                             (face-background 'default))))
 459                     (error nil))))
 460       (cond (bg-resource (intern (downcase bg-resource)))
 461             ((and color
 462                   (< (apply '+ (gnus-x-color-values color))
 463                      (/ (apply '+ (gnus-x-color-values "white")) 3)))
 464              'dark)
 465             (t 'light)))
 466     "A symbol indicating the Emacs background brightness.
 467 The symbol should be one of `light' or `dark'.
 468 If Emacs guesses this frame attribute wrongly, either set this variable in
 469 your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
 470 `~/.Xdefaults'.
 471 See also `gnus-display-type'.
 472
 473 This is a meta-variable that will affect what default values other
 474 variables get.  You would normally not change this variable, but
 475 pounce directly on the real variables themselves.")
 476   )
 477
 478
 479
 480 (defun gnus-xmas-redefine ()
 481   "Redefine lots of Gnus functions for XEmacs."
 482   (fset 'gnus-summary-make-display-table 'ignore)
 483   (fset 'gnus-visual-turn-off-edit-menu 'identity)
 484   (fset 'gnus-summary-recenter 'gnus-xmas-summary-recenter)
 485   (fset 'gnus-extent-start-open 'gnus-xmas-extent-start-open)
 486   (fset 'gnus-copy-article-buffer 'gnus-xmas-copy-article-buffer)
 487   (fset 'gnus-article-push-button 'gnus-xmas-article-push-button)
 488   (fset 'gnus-article-add-button 'gnus-xmas-article-add-button)
 489   (fset 'gnus-window-top-edge 'gnus-xmas-window-top-edge)
 490   (fset 'gnus-read-event-char 'gnus-xmas-read-event-char)
 491   (fset 'gnus-group-startup-message 'gnus-xmas-group-startup-message)
 492   (fset 'gnus-tree-minimize 'gnus-xmas-tree-minimize)
 493   (fset 'gnus-appt-select-lowest-window
 494         'gnus-xmas-appt-select-lowest-window)
 495   (fset 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names)
 496   (fset 'gnus-make-local-hook 'make-local-variable)
 497   (fset 'gnus-add-hook 'gnus-xmas-add-hook)
 498   (fset 'gnus-character-to-event 'character-to-event)
 499   (fset 'gnus-article-show-hidden-text 'gnus-xmas-article-show-hidden-text)
 500   (fset 'gnus-mode-line-buffer-identification
 501         'gnus-xmas-mode-line-buffer-identification)
 502
 503   (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add)
 504   (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add)
 505   (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add)
 506   (add-hook 'gnus-score-mode-hook 'gnus-xmas-score-menu-add)
 507
 508   (add-hook 'gnus-pick-mode-hook 'gnus-xmas-pick-menu-add)
 509   (add-hook 'gnus-tree-mode-hook 'gnus-xmas-tree-menu-add)
 510   (add-hook 'gnus-binary-mode-hook 'gnus-xmas-binary-menu-add)
 511   (add-hook 'gnus-grouplens-mode-hook 'gnus-xmas-grouplens-menu-add)
 512   (add-hook 'gnus-server-mode-hook 'gnus-xmas-server-menu-add)
 513   (add-hook 'gnus-browse-mode-hook 'gnus-xmas-browse-menu-add)
 514
 515   (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar)
 516   (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar)
 517
 518   (when (and (<= emacs-major-version 19)
 519              (<= emacs-minor-version 13))
 520     (fset 'gnus-highlight-selected-summary
 521           'gnus-xmas-highlight-selected-summary)
 522     (fset 'gnus-group-remove-excess-properties
 523           'gnus-xmas-group-remove-excess-properties)
 524     (fset 'gnus-topic-remove-excess-properties
 525           'gnus-xmas-topic-remove-excess-properties)
 526     (fset 'gnus-mode-line-buffer-identification 'identity)
 527     (unless (boundp 'shell-command-switch)
 528       (setq shell-command-switch "-c"))
 529     ))
 530
 531
 532 ;;; XEmacs logo and toolbar.
 533
 534 (defun gnus-xmas-group-startup-message (&optional x y)
 535   "Insert startup message in current buffer."
 536   ;; Insert the message.
 537   (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
 538   (erase-buffer)
 539   (let ((logo (and gnus-xmas-glyph-directory
 540                    (concat
 541                     (file-name-as-directory gnus-xmas-glyph-directory)
 542                     "gnus."
 543                     (if (featurep 'xpm) "xpm" "xbm"))))
 544         (xpm-color-symbols
 545          (and (featurep 'xpm)
 546               (append `(("thing" ,(car gnus-xmas-logo-colors))
 547                         ("shadow" ,(cadr gnus-xmas-logo-colors)))
 548                       xpm-color-symbols))))
 549     (if (and (featurep 'xpm)
 550              (not (equal (device-type) 'tty))
 551              logo
 552              (file-exists-p logo))
 553         (progn
 554           (setq logo (make-glyph logo))
 555           (insert " ")
 556           (set-extent-begin-glyph (make-extent (point) (point)) logo)
 557           (goto-char (point-min))
 558           (while (not (eobp))
 559             (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
 560                                  ? ))
 561             (forward-line 1))
 562           (goto-char (point-min))
 563           (let* ((pheight (+ 20 (count-lines (point-min) (point-max))))
 564                  (wheight (window-height))
 565                  (rest (- wheight pheight)))
 566             (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
 567
 568       (insert
 569        (format "              %s
 570           _    ___ _             _
 571           _ ___ __ ___  __    _ ___
 572           __   _     ___    __  ___
 573               _           ___     _
 574              _  _ __             _
 575              ___   __            _
 576                    __           _
 577                     _      _   _
 578                    _      _    _
 579                       _  _    _
 580                   __  ___
 581                  _   _ _     _
 582                 _   _
 583               _    _
 584              _    _
 585             _
 586           __
 587
 588 "
 589                ""))
 590       ;; And then hack it.
 591       (gnus-indent-rigidly (point-min) (point-max)
 592                            (/ (max (- (window-width) (or x 46)) 0) 2))
 593       (goto-char (point-min))
 594       (forward-line 1)
 595       (let* ((pheight (count-lines (point-min) (point-max)))
 596              (wheight (window-height))
 597              (rest (- wheight pheight)))
 598         (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
 599     ;; Fontify some.
 600     (goto-char (point-min))
 601     (and (search-forward "Praxis" nil t)
 602          (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
 603     (goto-char (point-min))
 604     (let* ((mode-string (gnus-group-set-mode-line)))
 605       (setq modeline-buffer-identification
 606             (list (concat gnus-version ": *Group*")))
 607       (set-buffer-modified-p t))))
 608
 609
 610 ;;; The toolbar.
 611
 612 (defvar gnus-use-toolbar (if (featurep 'toolbar)
 613                              'default-toolbar
 614                            nil)
 615   "*If nil, do not use a toolbar.
 616 If it is non-nil, it must be a toolbar.  The five legal values are
 617 `default-toolbar', `top-toolbar', `bottom-toolbar',
 618 `right-toolbar', and `left-toolbar'.")
 619
 620 (defvar gnus-group-toolbar
 621   '(
 622     [gnus-group-get-new-news gnus-group-get-new-news t "Get new news"]
 623     [gnus-group-get-new-news-this-group
 624      gnus-group-get-new-news-this-group t "Get new news in this group"]
 625     [gnus-group-catchup-current
 626      gnus-group-catchup-current t "Catchup group"]
 627     [gnus-group-describe-group
 628      gnus-group-describe-group t "Describe group"]
 629     [gnus-group-kill-group gnus-group-kill-group t "Kill group"]
 630     [gnus-group-exit gnus-group-exit t "Exit Gnus"]
 631     )
 632   "The group buffer toolbar.")
 633
 634 (defvar gnus-summary-toolbar
 635   '(
 636     [gnus-summary-prev-unread
 637      gnus-summary-prev-unread-article t "Prev unread article"]
 638     [gnus-summary-next-unread
 639      gnus-summary-next-unread-article t "Next unread article"]
 640     [gnus-summary-post-news
 641      gnus-summary-post-news t "Post an article"]
 642     [gnus-summary-followup-with-original
 643      gnus-summary-followup-with-original t
 644      "Post a followup and yank the original"]
 645     [gnus-summary-followup
 646      gnus-summary-followup t "Post a followup"]
 647     [gnus-summary-reply-with-original
 648      gnus-summary-reply-with-original t "Mail a reply and yank the original"]
 649     [gnus-summary-reply
 650      gnus-summary-reply t "Mail a reply"]
 651     [gnus-summary-caesar-message
 652      gnus-summary-caesar-message t "Rot 13"]
 653     [gnus-uu-decode-uu
 654      gnus-uu-decode-uu t "Decode uuencoded articles"]
 655     [gnus-summary-save-article-file
 656      gnus-summary-save-article-file t "Save article in file"]
 657     [gnus-summary-save-article
 658      gnus-summary-save-article t "Save article"]
 659     [gnus-uu-post-news
 660      gnus-uu-post-news t "Post an uuencoded article"]
 661     [gnus-summary-cancel-article
 662      gnus-summary-cancel-article t "Cancel article"]
 663     [gnus-summary-catchup-and-exit
 664      gnus-summary-catchup-and-exit t "Catchup and exit"]
 665     [gnus-summary-exit gnus-summary-exit t "Exit this summary"]
 666     )
 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-get gnus-mail-get t "Message get"]
 677     [gnus-summary-mail-originate gnus-summary-post-news t "Originate"]
 678     [gnus-summary-mail-save gnus-summary-save-article t "Save"]
 679     [gnus-summary-mail-copy gnus-summary-copy-article t "Copy message"]
 680 ;    [gnus-summary-mail-delete gnus-summary-delete-article t "Delete message"]
 681     [gnus-summary-mail-forward gnus-summary-mail-forward t "Forward message"]
 682 ;    [gnus-summary-mail-spell gnus-mail-spell t "Spell"]
 683 ;    [gnus-summary-mail-help gnus-mail-help  t "Message help"]
 684     [gnus-summary-caesar-message
 685      gnus-summary-caesar-message t "Rot 13"]
 686     [gnus-uu-decode-uu
 687      gnus-uu-decode-uu t "Decode uuencoded articles"]
 688     [gnus-summary-save-article-file
 689      gnus-summary-save-article-file t "Save article in file"]
 690     [gnus-summary-save-article
 691      gnus-summary-save-article t "Save article"]
 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     )
 696   "The summary buffer mail toolbar.")
 697
 698 (defun gnus-xmas-setup-group-toolbar ()
 699   (and gnus-use-toolbar
 700        (message-xmas-setup-toolbar gnus-group-toolbar nil "gnus")
 701        (set-specifier (symbol-value gnus-use-toolbar)
 702                       (cons (current-buffer) gnus-group-toolbar))))
 703
 704 (defun gnus-xmas-setup-summary-toolbar ()
 705   (let ((bar (if (gnus-news-group-p gnus-newsgroup-name)
 706                  gnus-summary-toolbar gnus-summary-mail-toolbar)))
 707     (and gnus-use-toolbar
 708          (message-xmas-setup-toolbar bar nil "gnus")
 709          (set-specifier (symbol-value gnus-use-toolbar)
 710                         (cons (current-buffer) bar)))))
 711
 712 (defun gnus-xmas-mail-strip-quoted-names (address)
 713   "Protect mail-strip-quoted-names from NIL input.
 714 XEmacs compatibility workaround."
 715   (if (null address)
 716       nil
 717     (mail-strip-quoted-names address)))
 718
 719 (defun gnus-xmas-call-region (command &rest args)
 720   (apply
 721    'call-process-region (point-min) (point-max) command t '(t nil) nil
 722    args))
 723
 724 (unless (find-face 'gnus-x-face)
 725   (copy-face 'default 'gnus-x-face))
 726
 727 (defun gnus-xmas-article-display-xface (beg end)
 728   "Display any XFace headers in the current article."
 729   (save-excursion
 730     (let (xface-glyph)
 731       (if (featurep 'xface)
 732           (setq xface-glyph
 733                 (make-glyph (vector 'xface :data
 734                                     (concat "X-Face: "
 735                                             (buffer-substring beg end)))))
 736         (let ((cur (current-buffer)))
 737           (save-excursion
 738             (gnus-set-work-buffer)
 739             (insert (format "%s" (buffer-substring beg end cur)))
 740             (gnus-xmas-call-region "uncompface")
 741             (goto-char (point-min))
 742             (insert "/* Width=48, Height=48 */\n")
 743             (gnus-xmas-call-region "icontopbm")
 744             (gnus-xmas-call-region "ppmtoxpm")
 745             (setq xface-glyph
 746                   (make-glyph
 747                    (vector 'xpm :data (buffer-string )))))))
 748       (set-glyph-face xface-glyph 'gnus-x-face)
 749       (goto-char (point-min))
 750       (re-search-forward "^From:" nil t)
 751       (set-extent-begin-glyph
 752        (make-extent (point) (1+ (point))) xface-glyph))))
 753
 754 (defun gnus-xmas-article-show-hidden-text (type &optional hide)
 755   "Show all hidden text of type TYPE.
 756 If HIDE, hide the text instead."
 757   (save-excursion
 758     (set-buffer gnus-article-buffer)
 759     (let ((buffer-read-only nil)
 760           (inhibit-point-motion-hooks t)
 761           (beg (point-min)))
 762       (while (gnus-goto-char (text-property-any
 763                               beg (point-max) 'gnus-type type))
 764         (setq beg (point))
 765         (forward-char)
 766         (if hide
 767             (gnus-hide-text beg (point) gnus-hidden-properties)
 768           (gnus-unhide-text beg (point)))
 769         (setq beg (point)))
 770       (save-window-excursion
 771         (select-window (get-buffer-window (current-buffer)))
 772         (recenter))
 773       t)))
 774
 775 (defun gnus-xmas-mode-line-buffer-identification (line)
 776   (let ((line (car line))
 777         chop)
 778     (if (not (stringp line))
 779         (list line)
 780       (unless (setq chop (string-match ":" line))
 781         (setq chop (/ (length line) 2)))
 782       (list (cons modeline-buffer-id-left-extent (substring line 0 chop))
 783             (cons modeline-buffer-id-right-extent (substring line chop))))))
 784
 785 (provide 'gnus-xmas)
 786
 787 ;;; gnus-xmas.el ends here