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