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