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 t)
  31 (require 'message-xmas)
  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 ;;; Internal variables.
  39
  40 (defvar gnus-xmas-logo (make-glyph (make-specifier 'image)))
  41
  42 ;; Don't warn about these undefined variables.
  43
  44 (defvar gnus-group-mode-hook)
  45 (defvar gnus-summary-mode-hook)
  46 (defvar gnus-article-mode-hook)
  47
  48 ;;defined in gnus.el
  49 (defvar gnus-active-hashtb)
  50 (defvar gnus-article-buffer)
  51 (defvar gnus-auto-center-summary)
  52 (defvar gnus-buffer-list)
  53 (defvar gnus-current-headers)
  54 (defvar gnus-level-killed)
  55 (defvar gnus-level-zombie)
  56 (defvar gnus-newsgroup-bookmarks)
  57 (defvar gnus-newsgroup-dependencies)
  58 (defvar gnus-newsgroup-selected-overlay)
  59 (defvar gnus-newsrc-hashtb)
  60 (defvar gnus-read-mark)
  61 (defvar gnus-refer-article-method)
  62 (defvar gnus-reffed-article-number)
  63 (defvar gnus-unread-mark)
  64 (defvar gnus-version)
  65 (defvar gnus-view-pseudos)
  66 (defvar gnus-view-pseudos-separately)
  67 (defvar gnus-visual)
  68 (defvar gnus-zombie-list)
  69 ;;defined in gnus-msg.el
  70 (defvar gnus-article-copy)
  71 (defvar gnus-check-before-posting)
  72 ;;defined in gnus-vis.el
  73 (defvar gnus-article-button-face)
  74 (defvar gnus-article-mouse-face)
  75 (defvar gnus-summary-selected-face)
  76 (defvar gnus-group-reading-menu)
  77 (defvar gnus-group-group-menu)
  78 (defvar gnus-group-misc-menu)
  79 (defvar gnus-summary-article-menu)
  80 (defvar gnus-summary-thread-menu)
  81 (defvar gnus-summary-misc-menu)
  82 (defvar gnus-summary-post-menu)
  83 (defvar gnus-summary-kill-menu)
  84 (defvar gnus-article-article-menu)
  85 (defvar gnus-article-treatment-menu)
  86 (defvar gnus-mouse-2)
  87 (defvar standard-display-table)
  88
  89 (defun gnus-xmas-set-text-properties (start end props &optional buffer)
  90   "You should NEVER use this function.  It is ideologically blasphemous.
  91 It is provided only to ease porting of broken FSF Emacs programs."
  92   (if (stringp buffer)
  93       nil
  94     (map-extents (lambda (extent ignored)
  95                    (remove-text-properties
  96                     start end
  97                     (list (extent-property extent 'text-prop) nil)
  98                     buffer))
  99                  buffer start end nil nil 'text-prop)
 100     (add-text-properties start end props buffer)))
 101
 102 (defun gnus-xmas-highlight-selected-summary ()
 103   ;; Highlight selected article in summary buffer
 104   (if gnus-summary-selected-face
 105       (progn
 106         (if gnus-newsgroup-selected-overlay
 107             (delete-extent gnus-newsgroup-selected-overlay))
 108         (setq gnus-newsgroup-selected-overlay
 109               (make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
 110         (set-extent-face gnus-newsgroup-selected-overlay
 111                          gnus-summary-selected-face))))
 112
 113 (defun gnus-xmas-summary-recenter ()
 114   "\"Center\" point in the summary window.
 115 If `gnus-auto-center-summary' is nil, or the article buffer isn't
 116 displayed, no centering will be performed."
 117   ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle).
 118   ;; Recenter only when requested.  Suggested by popovich@park.cs.columbia.edu.
 119   (when gnus-auto-center-summary
 120     (let* ((height (if (fboundp 'window-displayed-height)
 121                        (window-displayed-height)
 122                      (- (window-height) 2)))
 123            (top (cond ((< height 4) 0)
 124                       ((< height 7) 1)
 125                       (t 2)))
 126            (bottom (save-excursion (goto-char (point-max))
 127                                    (forward-line (- height))
 128                                    (point)))
 129            (window (get-buffer-window (current-buffer))))
 130       (when (get-buffer-window gnus-article-buffer)
 131         ;; Only do recentering when the article buffer is displayed,
 132         ;; Set the window start to either `bottom', which is the biggest
 133         ;; possible valid number, or the second line from the top,
 134         ;; whichever is the least.
 135         (set-window-start
 136          window (min bottom (save-excursion
 137                               (forward-line (- top)) (point)))))
 138       ;; Do horizontal recentering while we're at it.
 139       (when (and (get-buffer-window (current-buffer) t)
 140                  (not (eq gnus-auto-center-summary 'vertical)))
 141         (let ((selected (selected-window)))
 142           (select-window (get-buffer-window (current-buffer) t))
 143           (gnus-summary-position-point)
 144           (gnus-horizontal-recenter)
 145           (select-window selected))))))
 146
 147 (defun gnus-xmas-group-remove-excess-properties ()
 148   (let ((end (point))
 149         (beg (progn (forward-line -1) (point))))
 150     (remove-text-properties (1+ beg) end '(gnus-group nil))
 151     (remove-text-properties
 152      beg end
 153      '(gnus-topic nil gnus-topic-level nil gnus-topic-visible nil))
 154     (goto-char end)
 155     (map-extents
 156      (lambda (e ma)
 157        (set-extent-property e 'start-closed t))
 158      (current-buffer) beg end)))
 159
 160 (defun gnus-xmas-topic-remove-excess-properties ()
 161   (let ((end (point))
 162         (beg (progn (forward-line -1) (point))))
 163     (remove-text-properties beg end '(gnus-group nil gnus-unread nil))
 164     (remove-text-properties (1+ beg) end '(gnus-topic nil))
 165     (goto-char end)))
 166
 167 (defun gnus-xmas-extent-start-open (point)
 168   (map-extents (lambda (extent arg)
 169                  (set-extent-property extent 'start-open t))
 170                nil point (min (1+ (point)) (point-max))))
 171
 172 (defun gnus-xmas-copy-article-buffer (&optional article-buffer)
 173   (setq gnus-article-copy (get-buffer-create " *gnus article copy*"))
 174   (buffer-disable-undo gnus-article-copy)
 175   (or (memq gnus-article-copy gnus-buffer-list)
 176       (setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list)))
 177   (let ((article-buffer (or article-buffer gnus-article-buffer))
 178         buf)
 179     (if (and (get-buffer article-buffer)
 180              (buffer-name (get-buffer article-buffer)))
 181         (save-excursion
 182           (set-buffer article-buffer)
 183           (widen)
 184           (setq buf (buffer-substring (point-min) (point-max)))
 185           (set-buffer gnus-article-copy)
 186           (erase-buffer)
 187           (insert (format "%s" buf))))
 188     gnus-article-copy))
 189
 190 (defun gnus-xmas-article-push-button (event)
 191   "Check text under the mouse pointer for a callback function.
 192 If the text under the mouse pointer has a `gnus-callback' property,
 193 call it with the value of the `gnus-data' text property."
 194   (interactive "e")
 195   (set-buffer (window-buffer (event-window event)))
 196   (let* ((pos (event-closest-point event))
 197          (data (get-text-property pos 'gnus-data))
 198          (fun (get-text-property pos 'gnus-callback)))
 199     (if fun (funcall fun data))))
 200
 201 (defun gnus-xmas-move-overlay (extent start end &optional buffer)
 202   (set-extent-endpoints extent start end))
 203
 204 ;; Fixed by Christopher Davis <ckd@loiosh.kei.com>.
 205 (defun gnus-xmas-article-add-button (from to fun &optional data)
 206   "Create a button between FROM and TO with callback FUN and data DATA."
 207   (and gnus-article-button-face
 208        (gnus-overlay-put (gnus-make-overlay from to)
 209                          'face gnus-article-button-face))
 210   (add-text-properties
 211    from to
 212    (nconc
 213     (and gnus-article-mouse-face
 214          (list 'mouse-face gnus-article-mouse-face))
 215     (list 'gnus-callback fun)
 216     (and data (list 'gnus-data data))
 217     (list 'highlight t))))
 218
 219 (defun gnus-xmas-window-top-edge (&optional window)
 220   (nth 1 (window-pixel-edges window)))
 221
 222 (defun gnus-xmas-tree-minimize ()
 223   (when (and gnus-tree-minimize-window
 224              (not (one-window-p)))
 225     (let* ((window-min-height 2)
 226            (height (1+ (count-lines (point-min) (point-max))))
 227            (min (max (1- window-min-height) height))
 228            (tot (if (numberp gnus-tree-minimize-window)
 229                     (min gnus-tree-minimize-window min)
 230                   min))
 231            (win (get-buffer-window (current-buffer)))
 232            (wh (and win (1- (window-height win)))))
 233       (when (and win
 234                  (not (eq tot wh)))
 235         (let ((selected (selected-window)))
 236           (select-window win)
 237           (enlarge-window (- tot wh))
 238           (select-window selected))))))
 239
 240 ;; Select the lowest window on the frame.
 241 (defun gnus-xmas-appt-select-lowest-window ()
 242   (let* ((lowest-window (selected-window))
 243          (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
 244          (last-window (previous-window))
 245          (window-search t))
 246     (while window-search
 247       (let* ((this-window (next-window))
 248              (next-bottom-edge (car (cdr (cdr (cdr
 249                                                (window-pixel-edges
 250                                                 this-window)))))))
 251         (if (< bottom-edge next-bottom-edge)
 252             (progn
 253               (setq bottom-edge next-bottom-edge)
 254               (setq lowest-window this-window)))
 255
 256         (select-window this-window)
 257         (if (eq last-window this-window)
 258             (progn
 259               (select-window lowest-window)
 260               (setq window-search nil)))))))
 261
 262 (defmacro gnus-xmas-menu-add (type &rest menus)
 263   `(gnus-xmas-menu-add-1 ',type ',menus))
 264 (put 'gnus-xmas-menu-add 'lisp-indent-function 1)
 265 (put 'gnus-xmas-menu-add 'lisp-indent-hook 1)
 266
 267 (defun gnus-xmas-menu-add-1 (type menus)
 268   (when (and menu-bar-mode
 269              (gnus-visual-p (intern (format "%s-menu" type)) 'menu))
 270     (while menus
 271       (easy-menu-add (symbol-value (pop menus))))))
 272
 273 (defun gnus-xmas-group-menu-add ()
 274   (gnus-xmas-menu-add group
 275     gnus-group-reading-menu gnus-group-group-menu gnus-group-misc-menu))
 276
 277 (defun gnus-xmas-summary-menu-add ()
 278   (gnus-xmas-menu-add summary
 279     gnus-summary-article-menu gnus-summary-thread-menu
 280     gnus-summary-misc-menu gnus-summary-post-menu gnus-summary-kill-menu))
 281
 282 (defun gnus-xmas-article-menu-add ()
 283   (gnus-xmas-menu-add article
 284     gnus-article-article-menu gnus-article-treatment-menu))
 285
 286 (defun gnus-xmas-pick-menu-add ()
 287   (gnus-xmas-menu-add pick
 288     gnus-pick-menu))
 289
 290 (defun gnus-xmas-binary-menu-add ()
 291   (gnus-xmas-menu-add binary
 292     gnus-binary-menu))
 293
 294 (defun gnus-xmas-tree-menu-add ()
 295   (gnus-xmas-menu-add tree
 296     gnus-tree-menu))
 297
 298 (defun gnus-xmas-grouplens-menu-add ()
 299   (gnus-xmas-menu-add grouplens
 300     gnus-grouplens-menu))
 301
 302 (defun gnus-xmas-read-event-char ()
 303   "Get the next event."
 304   (let ((event (next-event)))
 305     ;; We junk all non-key events.  Is this naughty?
 306     (while (not (key-press-event-p event))
 307       (setq event (next-event)))
 308     (cons (and (key-press-event-p event)
 309               ; (numberp (event-key event))
 310                (event-to-character event))
 311           event)))
 312
 313 (defun gnus-xmas-seconds-since-epoch (date)
 314   "Return a floating point number that says how many seconds have lapsed between Jan 1 12:00:00 1970 and DATE."
 315   (let* ((tdate (mapcar (lambda (ti) (and ti (string-to-int ti)))
 316                         (timezone-parse-date date)))
 317          (ttime (mapcar (lambda (ti) (and ti (string-to-int ti)))
 318                         (timezone-parse-time
 319                          (aref (timezone-parse-date date) 3))))
 320          (edate (mapcar (lambda (ti) (and ti (string-to-int ti)))
 321                         (timezone-parse-date "Jan 1 12:00:00 1970")))
 322          (tday (- (timezone-absolute-from-gregorian
 323                    (nth 1 tdate) (nth 2 tdate) (nth 0 tdate))
 324                   (timezone-absolute-from-gregorian
 325                    (nth 1 edate) (nth 2 edate) (nth 0 edate)))))
 326     (+ (nth 2 ttime)
 327        (* (nth 1 ttime) 60)
 328        (* (float (nth 0 ttime)) 60 60)
 329        (* (float tday) 60 60 24))))
 330
 331 (defun gnus-xmas-define ()
 332   (setq gnus-mouse-2 [button2])
 333
 334   (or (memq 'underline (list-faces))
 335       (and (fboundp 'make-face)
 336            (funcall (intern "make-face") 'underline)))
 337   ;; Must avoid calling set-face-underline-p directly, because it
 338   ;; is a defsubst in emacs19, and will make the .elc files non
 339   ;; portable!
 340   (or (face-differs-from-default-p 'underline)
 341       (funcall (intern "set-face-underline-p") 'underline t))
 342
 343   (fset 'gnus-make-overlay 'make-extent)
 344   (fset 'gnus-overlay-put 'set-extent-property)
 345   (fset 'gnus-move-overlay 'gnus-xmas-move-overlay)
 346   (fset 'gnus-overlay-end 'extent-end-position)
 347   (fset 'gnus-extent-detached-p 'extent-detached-p)
 348
 349   (require 'text-props)
 350   (if (< emacs-minor-version 14)
 351       (fset 'gnus-set-text-properties 'gnus-xmas-set-text-properties))
 352
 353   (fset 'nnheader-find-file-noselect 'gnus-xmas-find-file-noselect)
 354
 355   (or (boundp 'standard-display-table) (setq standard-display-table nil))
 356
 357   (defvar gnus-mouse-face-prop 'highlight)
 358
 359   (unless (fboundp 'encode-time)
 360     (defun encode-time (sec minute hour day month year &optional zone)
 361       (let ((seconds
 362              (gnus-xmas-seconds-since-epoch
 363               (timezone-make-arpa-date
 364                year month day (timezone-make-time-string hour minute sec)
 365                zone))))
 366         (list (floor (/ seconds (expt 2 16)))
 367               (round (mod seconds (expt 2 16)))))))
 368
 369   (defun gnus-byte-code (func)
 370     "Return a form that can be `eval'ed based on FUNC."
 371     (let ((fval (symbol-function func)))
 372       (if (byte-code-function-p fval)
 373           (list 'funcall fval)
 374         (cons 'progn (cdr (cdr fval))))))
 375
 376   ;; Fix by "jeff (j.d.) sparkes" <jsparkes@bnr.ca>.
 377   (defvar gnus-display-type (device-class)
 378     "A symbol indicating the display Emacs is running under.
 379 The symbol should be one of `color', `grayscale' or `mono'. If Emacs
 380 guesses this display attribute wrongly, either set this variable in
 381 your `~/.emacs' or set the resource `Emacs.displayType' in your
 382 `~/.Xdefaults'. See also `gnus-background-mode'.
 383
 384 This is a meta-variable that will affect what default values other
 385 variables get.  You would normally not change this variable, but
 386 pounce directly on the real variables themselves.")
 387
 388
 389   (fset 'gnus-x-color-values
 390         (if (fboundp 'x-color-values)
 391             'x-color-values
 392           (lambda (color)
 393             (color-instance-rgb-components
 394              (make-color-instance color)))))
 395
 396   (defvar gnus-background-mode
 397     (let* ((bg-resource
 398             (condition-case ()
 399                 (x-get-resource ".backgroundMode" "BackgroundMode" 'string)
 400               (error nil)))
 401            (params (frame-parameters))
 402            (color (condition-case ()
 403                       (or (assq 'background-color params)
 404                           (color-instance-name
 405                            (specifier-instance
 406                             (face-background 'default))))
 407                     (error nil))))
 408       (cond (bg-resource (intern (downcase bg-resource)))
 409             ((and color
 410                   (< (apply '+ (gnus-x-color-values color))
 411                      (/ (apply '+ (gnus-x-color-values "white")) 3)))
 412              'dark)
 413             (t 'light)))
 414     "A symbol indicating the Emacs background brightness.
 415 The symbol should be one of `light' or `dark'.
 416 If Emacs guesses this frame attribute wrongly, either set this variable in
 417 your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
 418 `~/.Xdefaults'.
 419 See also `gnus-display-type'.
 420
 421 This is a meta-variable that will affect what default values other
 422 variables get.  You would normally not change this variable, but
 423 pounce directly on the real variables themselves.")
 424   )
 425
 426
 427
 428 (defun gnus-xmas-redefine ()
 429   "Redefine lots of Gnus functions for XEmacs."
 430   (fset 'gnus-summary-make-display-table 'ignore)
 431   (fset 'gnus-visual-turn-off-edit-menu 'identity)
 432   (fset 'gnus-highlight-selected-summary
 433         'gnus-xmas-highlight-selected-summary)
 434   (fset 'gnus-summary-recenter 'gnus-xmas-summary-recenter)
 435   (fset 'gnus-group-remove-excess-properties
 436         'gnus-xmas-group-remove-excess-properties)
 437   (fset 'gnus-topic-remove-excess-properties
 438         'gnus-xmas-topic-remove-excess-properties)
 439   (fset 'gnus-extent-start-open 'gnus-xmas-extent-start-open)
 440   (fset 'gnus-copy-article-buffer 'gnus-xmas-copy-article-buffer)
 441   (fset 'gnus-article-push-button 'gnus-xmas-article-push-button)
 442   (fset 'gnus-article-add-button 'gnus-xmas-article-add-button)
 443   (fset 'gnus-window-top-edge 'gnus-xmas-window-top-edge)
 444   (fset 'gnus-read-event-char 'gnus-xmas-read-event-char)
 445   (fset 'gnus-group-startup-message 'gnus-xmas-group-startup-message)
 446   (fset 'gnus-tree-minimize 'gnus-xmas-tree-minimize)
 447   (fset 'gnus-appt-select-lowest-window
 448         'gnus-xmas-appt-select-lowest-window)
 449   (fset 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names)
 450   (fset 'gnus-make-local-hook 'make-local-variable)
 451   (fset 'gnus-character-to-event 'character-to-event)
 452
 453   (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add)
 454   (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add)
 455   (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add)
 456
 457   (add-hook 'gnus-pick-mode-hook 'gnus-xmas-pick-menu-add)
 458   (add-hook 'gnus-tree-mode-hook 'gnus-xmas-tree-menu-add)
 459   (add-hook 'gnus-binary-mode-hook 'gnus-xmas-binary-menu-add)
 460   (add-hook 'gnus-grouplens-mode-hook 'gnus-xmas-grouplens-menu-add)
 461
 462   (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar)
 463   (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar))
 464
 465
 466 ;;; XEmacs logo and toolbar.
 467
 468 (defun gnus-xmas-group-startup-message (&optional x y)
 469   "Insert startup message in current buffer."
 470   ;; Insert the message.
 471   (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
 472   (erase-buffer)
 473   (let ((file (and gnus-xmas-glyph-directory
 474                    (concat
 475                     (file-name-as-directory gnus-xmas-glyph-directory)
 476                     "gnus.xpm"))))
 477     (if (and (featurep 'xpm)
 478              (not (equal (device-type) 'tty))
 479              file (file-exists-p file))
 480         (progn
 481           (set-glyph-property gnus-xmas-logo 'image file)
 482           (set-glyph-image gnus-xmas-logo file 'global 'x)
 483
 484           (insert " ")
 485           (set-extent-begin-glyph (make-extent (point) (point)) gnus-xmas-logo)
 486           (goto-char (point-min))
 487           (while (not (eobp))
 488             (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
 489                                  ? ))
 490             (forward-line 1))
 491           (goto-char (point-min))
 492           (let* ((pheight (+ 20 (count-lines (point-min) (point-max))))
 493                  (wheight (window-height))
 494                  (rest (- wheight pheight)))
 495             (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
 496
 497       (insert
 498        (format "              %s
 499           _    ___ _             _
 500           _ ___ __ ___  __    _ ___
 501           __   _     ___    __  ___
 502               _           ___     _
 503              _  _ __             _
 504              ___   __            _
 505                    __           _
 506                     _      _   _
 507                    _      _    _
 508                       _  _    _
 509                   __  ___
 510                  _   _ _     _
 511                 _   _
 512               _    _
 513              _    _
 514             _
 515           __
 516
 517 "
 518                ""))
 519       ;; And then hack it.
 520       (gnus-indent-rigidly (point-min) (point-max)
 521                            (/ (max (- (window-width) (or x 46)) 0) 2))
 522       (goto-char (point-min))
 523       (forward-line 1)
 524       (let* ((pheight (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     ;; Fontify some.
 529     (goto-char (point-min))
 530     (and (search-forward "Praxis" nil t)
 531          (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
 532     (goto-char (point-min))
 533     (let* ((mode-string (gnus-group-set-mode-line)))
 534       (setq mode-line-buffer-identification
 535             (list (concat gnus-version (substring (car mode-string) 4))))
 536       (set-buffer-modified-p t))))
 537
 538
 539 ;;; The toolbar.
 540
 541 (defvar gnus-use-toolbar 'default-toolbar
 542   "*If nil, do not use a toolbar.
 543 If it is non-nil, it must be a toolbar.  The five legal values are
 544 `default-toolbar', `top-toolbar', `bottom-toolbar',
 545 `right-toolbar', and `left-toolbar'.")
 546
 547 (defvar gnus-group-toolbar
 548   '([gnus-group-exit-icon gnus-group-exit t "Exit Gnus"]
 549     [gnus-group-kill-group-icon gnus-group-kill-group t "Kill group"]
 550     [gnus-group-get-new-news-icon gnus-group-get-new-news t "Get new news"]
 551     [gnus-group-get-new-news-this-group-icon
 552      gnus-group-get-new-news-this-group t "Get new news in this group"]
 553     [gnus-group-catchup-current-icon
 554      gnus-group-catchup-current t "Catchup group"]
 555     [gnus-group-describe-group-icon
 556      gnus-group-describe-group t "Describe group"])
 557   "The group buffer toolbar.")
 558
 559 (defvar gnus-summary-toolbar
 560   '([gnus-summary-post-news-icon
 561      gnus-summary-post-news t "Post an article"]
 562     [gnus-summary-save-article-file-icon
 563      gnus-summary-save-article-file t "Save article in file"]
 564     [gnus-summary-save-article-icon
 565      gnus-summary-save-article t "Save article"]
 566     [gnus-summary-reply-icon
 567      gnus-summary-reply t "Mail a reply"]
 568     [gnus-summary-reply-with-original-icon
 569      gnus-summary-reply-with-original t "Mail a reply and yank the original"]
 570     [gnus-summary-followup-icon
 571      gnus-summary-followup t "Post a followup"]
 572     [gnus-summary-followup-with-original-icon
 573      gnus-summary-followup-with-original t
 574      "Post a followup and yank the original"]
 575     [gnus-uu-decode-uu-icon
 576      gnus-uu-decode-uu t "Decode uuencoded articles"]
 577     [gnus-uu-post-news-icon
 578      gnus-uu-post-news t "Post an uuencoded article"]
 579     [gnus-summary-caesar-message-icon
 580      gnus-summary-caesar-message t "Rot 13"]
 581     [gnus-summary-cancel-article-icon
 582      gnus-summary-cancel-article t "Cancel article"])
 583   "The summary buffer toolbar.")
 584
 585 (defun gnus-xmas-setup-group-toolbar ()
 586   (let (dir)
 587     (and gnus-use-toolbar
 588          (setq dir (message-xmas-setup-toolbar gnus-group-toolbar nil "gnus"))
 589          (file-exists-p (concat dir "gnus-group-catchup-current-icon-up.xpm"))
 590          (set-specifier (symbol-value gnus-use-toolbar)
 591                         (cons (current-buffer) gnus-group-toolbar)))))
 592
 593 (defun gnus-xmas-setup-summary-toolbar ()
 594   (let (dir)
 595     (and gnus-use-toolbar
 596          (setq dir (message-xmas-setup-toolbar gnus-summary-toolbar
 597                                                nil "gnus"))
 598          (file-exists-p (concat dir "gnus-group-catchup-current-icon-up.xpm"))
 599          (set-specifier (symbol-value gnus-use-toolbar)
 600                         (cons (current-buffer) gnus-summary-toolbar)))))
 601
 602 ;; Written by Erik Naggum <erik@naggum.no>.
 603 ;; Saved by Steve Baur <steve@miranova.com>.
 604 (or (fboundp 'insert-file-contents-literally)
 605 (defun insert-file-contents-literally (filename &optional visit beg end replace)
 606   "Like `insert-file-contents', q.v., but only reads in the file.
 607 A buffer may be modified in several ways after reading into the buffer due
 608 to advanced Emacs features, such as file-name-handlers, format decoding,
 609 find-file-hooks, etc.
 610   This function ensures that none of these modifications will take place."
 611   (let (                                ; (file-name-handler-alist nil)
 612         (format-alist nil)
 613         (after-insert-file-functions nil)
 614         (find-buffer-file-type-function
 615          (if (fboundp 'find-buffer-file-type)
 616              (symbol-function 'find-buffer-file-type)
 617            nil)))
 618     (unwind-protect
 619         (progn
 620           (fset 'find-buffer-file-type (lambda (filename) t))
 621           (insert-file-contents filename visit beg end replace))
 622       (if find-buffer-file-type-function
 623           (fset 'find-buffer-file-type find-buffer-file-type-function)
 624         (fmakunbound 'find-buffer-file-type))))))
 625
 626 (defun gnus-xmas-find-file-noselect (filename &optional nowarn rawfile)
 627   "Read file FILENAME into a buffer and return the buffer.
 628 If a buffer exists visiting FILENAME, return that one, but
 629 verify that the file has not changed since visited or saved.
 630 The buffer is not selected, just returned to the caller."
 631   (setq filename
 632         (abbreviate-file-name
 633          (expand-file-name filename)))
 634   (if (file-directory-p filename)
 635       (if find-file-run-dired
 636           (dired-noselect filename)
 637         (error "%s is a directory." filename))
 638     (let* ((buf (get-file-buffer filename))
 639            (truename (abbreviate-file-name (file-truename filename)))
 640            (number (nthcdr 10 (file-attributes truename)))
 641            ;; Find any buffer for a file which has same truename.
 642            (other (and (not buf)
 643                        (if (fboundp 'find-buffer-visiting)
 644                            (find-buffer-visiting filename)
 645                          (get-file-buffer filename))))
 646            error)
 647       ;; Let user know if there is a buffer with the same truename.
 648       (if other
 649           (progn
 650             (or nowarn
 651                 (string-equal filename (buffer-file-name other))
 652                 (message "%s and %s are the same file"
 653                          filename (buffer-file-name other)))
 654             ;; Optionally also find that buffer.
 655             (if (or (and (boundp 'find-file-existing-other-name)
 656                          find-file-existing-other-name)
 657                     find-file-visit-truename)
 658                 (setq buf other))))
 659       (if buf
 660           (or nowarn
 661               (verify-visited-file-modtime buf)
 662               (cond ((not (file-exists-p filename))
 663                      (error "File %s no longer exists!" filename))
 664                     ((yes-or-no-p
 665                       (if (string= (file-name-nondirectory filename)
 666                                    (buffer-name buf))
 667                           (format
 668                            (if (buffer-modified-p buf)
 669                                "File %s changed on disk.  Discard your edits? "
 670                              "File %s changed on disk.  Reread from disk? ")
 671                            (file-name-nondirectory filename))
 672                         (format
 673                          (if (buffer-modified-p buf)
 674                              "File %s changed on disk.  Discard your edits in %s? "
 675                            "File %s changed on disk.  Reread from disk into %s? ")
 676                          (file-name-nondirectory filename)
 677                          (buffer-name buf))))
 678                      (save-excursion
 679                        (set-buffer buf)
 680                        (revert-buffer t t)))))
 681         (save-excursion
 682 ;;; The truename stuff makes this obsolete.
 683 ;;;       (let* ((link-name (car (file-attributes filename)))
 684 ;;;              (linked-buf (and (stringp link-name)
 685 ;;;                               (get-file-buffer link-name))))
 686 ;;;         (if (bufferp linked-buf)
 687 ;;;             (message "Symbolic link to file in buffer %s"
 688 ;;;                      (buffer-name linked-buf))))
 689           (setq buf (create-file-buffer filename))
 690           ;;      (set-buffer-major-mode buf)
 691           (set-buffer buf)
 692           (erase-buffer)
 693           (if rawfile
 694               (condition-case ()
 695                   (insert-file-contents-literally filename t)
 696                 (file-error
 697                  ;; Unconditionally set error
 698                  (setq error t)))
 699             (condition-case ()
 700                 (insert-file-contents filename t)
 701               (file-error
 702                ;; Run find-file-not-found-hooks until one returns non-nil.
 703                (or t                    ; (run-hook-with-args-until-success 'find-file-not-found-hooks)
 704                    ;; If they fail too, set error.
 705                    (setq error t)))))
 706           ;; Find the file's truename, and maybe use that as visited name.
 707           (setq buffer-file-truename truename)
 708           (setq buffer-file-number number)
 709           ;; On VMS, we may want to remember which directory in a search list
 710           ;; the file was found in.
 711           (and (eq system-type 'vax-vms)
 712                (let (logical)
 713                  (if (string-match ":" (file-name-directory filename))
 714                      (setq logical (substring (file-name-directory filename)
 715                                               0 (match-beginning 0))))
 716                  (not (member logical find-file-not-true-dirname-list)))
 717                (setq buffer-file-name buffer-file-truename))
 718           (if find-file-visit-truename
 719               (setq buffer-file-name
 720                     (setq filename
 721                           (expand-file-name buffer-file-truename))))
 722           ;; Set buffer's default directory to that of the file.
 723           (setq default-directory (file-name-directory filename))
 724           ;; Turn off backup files for certain file names.  Since
 725           ;; this is a permanent local, the major mode won't eliminate it.
 726           (and (not (funcall backup-enable-predicate buffer-file-name))
 727                (progn
 728                  (make-local-variable 'backup-inhibited)
 729                  (setq backup-inhibited t)))
 730           (if rawfile
 731               nil
 732             (after-find-file error (not nowarn)))))
 733       buf)))
 734
 735 (defun gnus-xmas-mail-strip-quoted-names (address)
 736   "Protect mail-strip-quoted-names from NIL input.
 737 XEmacs compatibility workaround."
 738   (if (null address)
 739       nil
 740     (mail-strip-quoted-names address)))
 741
 742 ;;; gnus-xmas.el ends here