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