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