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

   1 ;;; gnus-xmas.el --- Gnus functions for XEmacs
   2 ;; Copyright (C) 1995 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 (defvar menu-bar-mode t)
  29
  30 (defvar gnus-xmas-glyph-directory nil
  31   "*Directory where Gnus logos and icons are located.
  32 If this variable is nil, Gnus will try to locate the directory
  33 automatically.")
  34
  35 ;;; Internal variables.
  36
  37 (defvar gnus-xmas-logo (make-glyph (make-specifier 'image)))
  38
  39 ;; Don't warn about these undefined variables.
  40
  41 (defvar gnus-group-mode-hook)
  42 (defvar gnus-summary-mode-hook)
  43 (defvar gnus-article-mode-hook)
  44
  45 ;;defined in gnus.el
  46 (defvar gnus-active-hashtb)
  47 (defvar gnus-article-buffer)
  48 (defvar gnus-auto-center-summary)
  49 (defvar gnus-buffer-list)
  50 (defvar gnus-current-headers)
  51 (defvar gnus-level-killed)
  52 (defvar gnus-level-zombie)
  53 (defvar gnus-newsgroup-bookmarks)
  54 (defvar gnus-newsgroup-dependencies)
  55 (defvar gnus-newsgroup-selected-overlay)
  56 (defvar gnus-newsrc-hashtb)
  57 (defvar gnus-read-mark)
  58 (defvar gnus-refer-article-method)
  59 (defvar gnus-reffed-article-number)
  60 (defvar gnus-unread-mark)
  61 (defvar gnus-version)
  62 (defvar gnus-view-pseudos)
  63 (defvar gnus-view-pseudos-separately)
  64 (defvar gnus-visual)
  65 (defvar gnus-zombie-list)
  66 ;;defined in gnus-msg.el
  67 (defvar gnus-article-copy)
  68 (defvar gnus-check-before-posting)
  69 ;;defined in gnus-vis.el
  70 (defvar gnus-article-button-face)
  71 (defvar gnus-article-mouse-face)
  72 (defvar gnus-summary-selected-face)
  73 (defvar gnus-group-reading-menu)
  74 (defvar gnus-group-group-menu)
  75 (defvar gnus-group-misc-menu)
  76 (defvar gnus-summary-article-menu)
  77 (defvar gnus-summary-thread-menu)
  78 (defvar gnus-summary-misc-menu)
  79 (defvar gnus-summary-post-menu)
  80 (defvar gnus-summary-kill-menu)
  81 (defvar gnus-article-article-menu)
  82 (defvar gnus-article-treatment-menu)
  83 (defvar gnus-mouse-2)
  84 (defvar standard-display-table)
  85
  86 (defun gnus-xmas-set-text-properties (start end props &optional buffer)
  87   "You should NEVER use this function.  It is ideologically blasphemous.
  88 It is provided only to ease porting of broken FSF Emacs programs."
  89   (if (and (stringp buffer) (not (setq buffer (get-buffer buffer))))
  90       nil
  91     (map-extents (lambda (extent ignored)
  92                    (remove-text-properties
  93                     start end
  94                     (list (extent-property extent 'text-prop) nil)
  95                     buffer))
  96                  buffer start end nil nil 'text-prop)
  97     (add-text-properties start end props buffer)))
  98
  99 (defun gnus-xmas-highlight-selected-summary ()
 100   ;; Highlight selected article in summary buffer
 101   (if gnus-summary-selected-face
 102       (progn
 103         (if gnus-newsgroup-selected-overlay
 104             (delete-extent gnus-newsgroup-selected-overlay))
 105         (setq gnus-newsgroup-selected-overlay
 106               (make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
 107         (set-extent-face gnus-newsgroup-selected-overlay
 108                          gnus-summary-selected-face))))
 109
 110 (defun gnus-xmas-summary-recenter ()
 111   (let* ((top (cond ((< (window-height) 4) 0)
 112                     ((< (window-height) 7) 1)
 113                     (t 2)))
 114          (height (- (window-height) 2))
 115          (bottom (save-excursion (goto-char (point-max))
 116                                  (forward-line (- height))
 117                                  (point)))
 118          (window (get-buffer-window (current-buffer))))
 119     (and
 120      ;; The user has to want it,
 121      gnus-auto-center-summary
 122      ;; the article buffer must be displayed,
 123      (get-buffer-window gnus-article-buffer)
 124      ;; Set the window start to either `bottom', which is the biggest
 125      ;; possible valid number, or the second line from the top,
 126      ;; whichever is the least.
 127      (set-window-start
 128       window (min bottom (save-excursion
 129                            (forward-line (- top)) (point)))))))
 130
 131 (defun gnus-xmas-group-insert-group-line-info (group)
 132   (let ((entry (gnus-gethash group gnus-newsrc-hashtb))
 133         (beg (point))
 134         active info)
 135     (if entry
 136         (progn
 137           (setq info (nth 2 entry))
 138           (gnus-group-insert-group-line
 139            group (gnus-info-level info) (gnus-info-marks info)
 140            (car entry) (gnus-info-method info)))
 141       (setq active (gnus-gethash group gnus-active-hashtb))
 142
 143       (gnus-group-insert-group-line
 144        group (if (member group gnus-zombie-list) gnus-level-zombie
 145                    gnus-level-killed)
 146        nil (if active (- (1+ (cdr active)) (car active)) 0) nil))
 147     (save-excursion
 148       (goto-char beg)
 149       (remove-text-properties
 150        (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
 151        '(gnus-group nil)))))
 152
 153 (defun gnus-xmas-copy-article-buffer (&optional article-buffer)
 154   (setq gnus-article-copy (get-buffer-create " *gnus article copy*"))
 155   (buffer-disable-undo gnus-article-copy)
 156   (or (memq gnus-article-copy gnus-buffer-list)
 157       (setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list)))
 158   (let ((article-buffer (or article-buffer gnus-article-buffer))
 159         buf)
 160     (if (and (get-buffer article-buffer)
 161              (buffer-name (get-buffer article-buffer)))
 162         (save-excursion
 163           (set-buffer article-buffer)
 164           (widen)
 165           (setq buf (buffer-substring (point-min) (point-max)))
 166           (set-buffer gnus-article-copy)
 167           (erase-buffer)
 168           (insert (format "%s" buf))))))
 169
 170 (defun gnus-xmas-article-push-button (event)
 171   "Check text under the mouse pointer for a callback function.
 172 If the text under the mouse pointer has a `gnus-callback' property,
 173 call it with the value of the `gnus-data' text property."
 174   (interactive "e")
 175   (set-buffer (window-buffer (event-window event)))
 176   (let* ((pos (event-closest-point event))
 177          (data (get-text-property pos 'gnus-data))
 178          (fun (get-text-property pos 'gnus-callback)))
 179     (if fun (funcall fun data))))
 180
 181 (defun gnus-xmas-move-overlay (extent start end &optional buffer)
 182   (set-extent-endpoints extent start end))
 183
 184 ;; Fixed by Christopher Davis <ckd@loiosh.kei.com>.
 185 (defun gnus-xmas-article-add-button (from to fun &optional data)
 186   "Create a button between FROM and TO with callback FUN and data DATA."
 187   (and gnus-article-button-face
 188        (gnus-overlay-put (gnus-make-overlay from to)
 189                          'face gnus-article-button-face))
 190   (add-text-properties
 191    from to
 192    (nconc
 193     (and gnus-article-mouse-face
 194          (list 'mouse-face gnus-article-mouse-face))
 195     (list 'gnus-callback fun)
 196     (and data (list 'gnus-data data))
 197     (list 'highlight t))))
 198
 199 (defun gnus-xmas-window-top-edge (&optional window)
 200   (nth 1 (window-pixel-edges window)))
 201
 202 ;; Select the lowest window on the frame.
 203 (defun gnus-xmas-appt-select-lowest-window ()
 204   (let* ((lowest-window (selected-window))
 205          (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
 206          (last-window (previous-window))
 207          (window-search t))
 208     (while window-search
 209       (let* ((this-window (next-window))
 210              (next-bottom-edge (car (cdr (cdr (cdr
 211                                                (window-pixel-edges
 212                                                 this-window)))))))
 213         (if (< bottom-edge next-bottom-edge)
 214             (progn
 215               (setq bottom-edge next-bottom-edge)
 216               (setq lowest-window this-window)))
 217
 218         (select-window this-window)
 219         (if (eq last-window this-window)
 220             (progn
 221               (select-window lowest-window)
 222               (setq window-search nil)))))))
 223
 224 (defun gnus-xmas-group-menu-add ()
 225   (easy-menu-add gnus-group-reading-menu)
 226   (easy-menu-add gnus-group-group-menu)
 227   (easy-menu-add gnus-group-misc-menu))
 228
 229 (defun gnus-xmas-summary-menu-add ()
 230   (easy-menu-add gnus-summary-article-menu)
 231   (easy-menu-add gnus-summary-thread-menu)
 232   (easy-menu-add gnus-summary-misc-menu)
 233   (easy-menu-add gnus-summary-post-menu)
 234   (easy-menu-add gnus-summary-kill-menu))
 235
 236 (defun gnus-xmas-article-menu-add ()
 237   (easy-menu-add gnus-article-article-menu)
 238   (easy-menu-add gnus-article-treatment-menu))
 239
 240
 241 (defun gnus-xmas-define ()
 242   (setq gnus-mouse-2 [button2])
 243
 244   (or (memq 'underline (list-faces))
 245       (and (fboundp 'make-face)
 246            (funcall (intern "make-face") 'underline)))
 247   ;; Must avoid calling set-face-underline-p directly, because it
 248   ;; is a defsubst in emacs19, and will make the .elc files non
 249   ;; portable!
 250   (or (face-differs-from-default-p 'underline)
 251       (funcall (intern "set-face-underline-p") 'underline t))
 252
 253   (fset 'gnus-make-overlay 'make-extent)
 254   (fset 'gnus-overlay-put 'set-extent-property)
 255   (fset 'gnus-move-overlay 'gnus-xmas-move-overlay)
 256
 257   (fset 'set-text-properties 'gnus-xmas-set-text-properties)
 258
 259   (or (boundp 'standard-display-table) (setq standard-display-table nil))
 260   (or (boundp 'read-event) (fset 'read-event 'next-command-event))
 261
 262   (defvar gnus-mouse-face-prop 'highlight)
 263
 264   ;; Fix by "jeff (j.d.) sparkes" <jsparkes@bnr.ca>.
 265   (defvar gnus-display-type (device-class)
 266     "A symbol indicating the display Emacs is running under.
 267 The symbol should be one of `color', `grayscale' or `mono'. If Emacs
 268 guesses this display attribute wrongly, either set this variable in
 269 your `~/.emacs' or set the resource `Emacs.displayType' in your
 270 `~/.Xdefaults'. See also `gnus-background-mode'.
 271
 272 This is a meta-variable that will affect what default values other
 273 variables get.  You would normally not change this variable, but
 274 pounce directly on the real variables themselves.")
 275
 276
 277   (or (fboundp 'x-color-values)
 278       (fset 'x-color-values
 279             (lambda (color)
 280               (color-instance-rgb-components
 281                (make-color-instance color)))))
 282
 283   (defvar gnus-background-mode
 284     (let ((bg-resource
 285            (condition-case ()
 286                (x-get-resource ".backgroundMode" "BackgroundMode" 'string)
 287              (error nil)))
 288           (params (frame-parameters)))
 289       (cond (bg-resource (intern (downcase bg-resource)))
 290             ((and (assq 'background-color params)
 291                   (< (apply '+ (x-color-values
 292                                 (cdr (assq 'background-color params))))
 293                      (/ (apply '+ (x-color-values "white")) 3)))
 294              'dark)
 295             (t 'light)))
 296     "A symbol indicating the Emacs background brightness.
 297 The symbol should be one of `light' or `dark'.
 298 If Emacs guesses this frame attribute wrongly, either set this variable in
 299 your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
 300 `~/.Xdefaults'.
 301 See also `gnus-display-type'.
 302
 303 This is a meta-variable that will affect what default values other
 304 variables get.  You would normally not change this variable, but
 305 pounce directly on the real variables themselves.")
 306   )
 307
 308
 309
 310 (defun gnus-xmas-redefine ()
 311
 312
 313   (fset 'gnus-summary-make-display-table (lambda () nil))
 314   (fset 'gnus-visual-turn-off-edit-menu 'identity)
 315   (fset 'gnus-highlight-selected-summary
 316         'gnus-xmas-highlight-selected-summary)
 317   (fset 'gnus-summary-recenter 'gnus-xmas-summary-recenter)
 318   (fset 'gnus-group-insert-group-line-info
 319         'gnus-xmas-group-insert-group-line-info)
 320   (fset 'gnus-copy-article-buffer 'gnus-xmas-copy-article-buffer)
 321   (fset 'gnus-article-push-button 'gnus-xmas-article-push-button)
 322   (fset 'gnus-article-add-button 'gnus-xmas-article-add-button)
 323   (fset 'gnus-window-top-edge 'gnus-xmas-window-top-edge)
 324   (fset 'set-text-properties 'gnus-xmas-set-text-properties)
 325
 326   (or (fboundp 'appt-select-lowest-window)
 327       (fset 'appt-select-lowest-window
 328             'gnus-xmas-appt-select-lowest-window))
 329
 330   (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add)
 331   (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add)
 332   (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add)
 333
 334   (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar)
 335   (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar))
 336
 337
 338 ;;; XEmacs logo and toolbar.
 339
 340 (defun gnus-xmas-find-glyph-directory ()
 341   (or gnus-xmas-glyph-directory ; We have a dir already...
 342       (let ((path load-path)
 343             dir)
 344         ;; We try to find the dir by looking at the load path,
 345         ;; stripping away the last component and adding "etc/".
 346         (while path
 347           (setq dir (concat
 348                      (file-name-directory (directory-file-name (car path)))
 349                      "etc/"))
 350           (if (and (file-exists-p dir)
 351                    (file-directory-p dir)
 352                    (file-exists-p (concat dir "gnus-group-exit-icon-up.xpm")))
 353               (setq gnus-xmas-glyph-directory dir
 354                     path nil)
 355             (setq path (cdr path))))
 356         gnus-xmas-glyph-directory)))
 357
 358 (defun gnus-xmas-group-startup (&optional x y)
 359   "Insert startup message in current buffer."
 360   ;; Insert the message.
 361   (erase-buffer)
 362   (if (featurep 'xpm)
 363       (progn
 364         (set-glyph-property gnus-xmas-logo 'image  "~/tmp/gnus.xpm")
 365         (set-glyph-image gnus-xmas-logo "~/tmp/gnus.xpm" 'global 'x)
 366
 367         (insert " ")
 368         (set-extent-begin-glyph (make-extent (point) (point)) gnus-xmas-logo)
 369         (insert "
 370    Gnus * A newsreader for Emacsen
 371  A Praxis Release * larsi@ifi.uio.no")
 372         (goto-char (point-min))
 373         (while (not (eobp))
 374           (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
 375                                ? ))
 376           (forward-line 1))
 377         (goto-char (point-min))
 378         ;; +4 is fuzzy factor.
 379         (insert-char ?\n (/ (max (- (window-height) (or y 24)) 0) 2)))
 380
 381     (insert
 382      (format "
 383      %s
 384            A newsreader
 385       for GNU Emacs
 386
 387         Based on GNUS
 388              written by
 389      Masanobu UMEDA
 390
 391        A Praxis Release
 392       larsi@ifi.uio.no
 393 "
 394              gnus-version))
 395     ;; And then hack it.
 396     ;; 18 is the longest line.
 397     (indent-rigidly (point-min) (point-max)
 398                     (/ (max (- (window-width) (or x 28)) 0) 2))
 399     (goto-char (point-min))
 400     ;; +4 is fuzzy factor.
 401     (insert-char ?\n (/ (max (- (window-height) (or y 12)) 0) 2)))
 402
 403   ;; Fontify some.
 404   (goto-char (point-min))
 405   (search-forward "Praxis")
 406   (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)
 407   (goto-char (point-min)))
 408
 409 ;;; The toolbar.
 410
 411 (defvar gnus-use-toolbar 'default-toolbar
 412   "*If nil, do not use a toolbar.
 413 If it is non-nil, it must be a toolbar.  The five legal values are
 414 `default-toolbar', `top-toolbar', `bottom-toolbar',
 415 `right-toolbar', and `left-toolbar'.")
 416
 417 (defvar gnus-group-toolbar
 418   '([gnus-group-exit-icon gnus-group-exit t "Exit Gnus"]
 419     [gnus-group-kill-group-icon gnus-group-kill-group t "Kill group"]
 420     [gnus-group-get-new-news-icon gnus-group-get-new-news t "Get new news"]
 421     [gnus-group-get-new-news-this-group-icon
 422      gnus-group-get-new-news-this-group t "Get new news in this group"]
 423     [gnus-group-catchup-current-icon
 424      gnus-group-catchup-current t "Catchup group"]
 425     [gnus-group-describe-group-icon
 426      gnus-group-describe-group t "Describe group"])
 427   "The group buffer toolbar.")
 428
 429 (defvar gnus-summary-toolbar
 430   '([gnus-summary-post-news-icon
 431      gnus-summary-post-news t "Post an article"]
 432     [gnus-summary-save-article-file-icon
 433      gnus-summary-save-article-file t "Save article in file"]
 434     [gnus-summary-save-article-icon
 435      gnus-summary-save-article t "Save article"]
 436     [gnus-summary-reply-icon
 437      gnus-summary-reply t "Mail a reply"]
 438     [gnus-summary-reply-with-original-icon
 439      gnus-summary-reply-with-original t "Mail a reply and yank the original"]
 440     [gnus-summary-followup-icon
 441      gnus-summary-followup t "Post a followup"]
 442     [gnus-summary-followup-with-original-icon
 443      gnus-summary-followup-with-original t
 444      "Post a followup and yank the original"]
 445     [gnus-uu-decode-uu-icon
 446      gnus-uu-decode-uu t "Decode uuencoded articles"]
 447     [gnus-uu-post-news-icon
 448      gnus-uu-post-news t "Post an uuencoded article"]
 449     [gnus-summary-caesar-message-icon
 450      gnus-summary-caesar-message t "Rot 13"]
 451     [gnus-summary-cancel-article-icon
 452      gnus-summary-cancel-article t "Cancel article"])
 453   "The summary buffer toolbar.")
 454
 455 (defun gnus-xmas-setup-toolbar (bar &optional force)
 456   (let ((dir (gnus-xmas-find-glyph-directory))
 457         icon up down disabled name)
 458     (if (not dir)
 459         ()
 460       (if (and (not force)
 461                (boundp (aref (car bar) 0)))
 462           dir
 463         (while bar
 464           (setq icon (aref (car bar) 0)
 465                 name (symbol-name icon)
 466                 bar (cdr bar))
 467           (setq up (concat dir name "-up.xpm"))
 468           (setq down (concat dir name "-down.xpm"))
 469           (setq disabled (concat dir name "-disabled.xpm"))
 470           (if (not (file-exists-p up))
 471               (set icon nil)
 472             (set icon (toolbar-make-button-list
 473                        up (and (file-exists-p down) down)
 474                        (and (file-exists-p disabled) disabled)))))
 475         dir))))
 476
 477 (defun gnus-xmas-setup-group-toolbar ()
 478   (and gnus-use-toolbar
 479        (gnus-xmas-setup-toolbar gnus-group-toolbar)
 480        (set-specifier (symbol-value gnus-use-toolbar)
 481                       (cons (current-buffer) gnus-group-toolbar))))
 482
 483 (defun gnus-xmas-setup-summary-toolbar ()
 484   (and gnus-use-toolbar
 485        (gnus-xmas-setup-toolbar gnus-summary-toolbar)
 486        (set-specifier (symbol-value gnus-use-toolbar)
 487                       (cons (current-buffer) gnus-summary-toolbar))))
 488
 489 ;;; gnus-xmas.el ends here