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

   1 ;;; gnus-salt.el --- alternate summary mode interfaces for Gnus
   2 ;; Copyright (C) 1996,97 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   5
   6 ;; This file is part of GNU Emacs.
   7
   8 ;; GNU Emacs is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2, or (at your option)
  11 ;; any later version.
  12
  13 ;; GNU Emacs is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  21 ;; Boston, MA 02111-1307, USA.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (eval-when-compile (require 'cl))
  28
  29 (require 'gnus)
  30 (require 'gnus-sum)
  31
  32 ;;;
  33 ;;; gnus-pick-mode
  34 ;;;
  35
  36 (defvar gnus-pick-mode nil
  37   "Minor mode for providing a pick-and-read interface in Gnus summary buffers.")
  38
  39 (defcustom gnus-pick-display-summary nil
  40   "*Display summary while reading."
  41   :type 'boolean
  42   :group 'gnus-summary-pick)
  43
  44 (defcustom gnus-pick-mode-hook nil
  45   "Hook run in summary pick mode buffers."
  46   :type 'hook
  47   :group 'gnus-summary-pick)
  48
  49 (defcustom gnus-mark-unpicked-articles-as-read nil
  50   "*If non-nil, mark all unpicked articles as read."
  51   :type 'boolean
  52   :group 'gnus-summary-pick)
  53
  54 (defcustom gnus-pick-elegant-flow t
  55   "If non-nil, gnus-pick-start-reading will run gnus-summary-next-group when no articles have been picked."
  56   :type 'boolean
  57   :group 'gnus-summary-pick)
  58
  59 (defcustom gnus-summary-pick-line-format
  60   "%-5P %U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n"
  61   "*The format specification of the lines in pick buffers.
  62 It accepts the same format specs that `gnus-summary-line-format' does."
  63   :type 'string
  64   :group 'gnus-summary-pick)
  65
  66 ;;; Internal variables.
  67
  68 (defvar gnus-pick-mode-map nil)
  69
  70 (unless gnus-pick-mode-map
  71   (setq gnus-pick-mode-map (make-sparse-keymap))
  72
  73   (gnus-define-keys
  74    gnus-pick-mode-map
  75    "t" gnus-uu-mark-thread
  76    "T" gnus-uu-unmark-thread
  77    " " gnus-pick-next-page
  78    "u" gnus-summary-unmark-as-processable
  79    "U" gnus-summary-unmark-all-processable
  80    "v" gnus-uu-mark-over
  81    "r" gnus-uu-mark-region
  82    "R" gnus-uu-unmark-region
  83    "e" gnus-uu-mark-by-regexp
  84    "E" gnus-uu-mark-by-regexp
  85    "b" gnus-uu-mark-buffer
  86    "B" gnus-uu-unmark-buffer
  87    "." gnus-pick-article
  88    gnus-down-mouse-2 gnus-pick-mouse-pick-region
  89    ;;gnus-mouse-2 gnus-pick-mouse-pick
  90    "X" gnus-pick-start-reading
  91    "\r" gnus-pick-start-reading))
  92
  93 (defun gnus-pick-make-menu-bar ()
  94   (unless (boundp 'gnus-pick-menu)
  95     (easy-menu-define
  96      gnus-pick-menu gnus-pick-mode-map ""
  97      '("Pick"
  98        ("Pick"
  99         ["Article" gnus-summary-mark-as-processable t]
 100         ["Thread" gnus-uu-mark-thread t]
 101         ["Region" gnus-uu-mark-region t]
 102         ["Regexp" gnus-uu-mark-regexp t]
 103         ["Buffer" gnus-uu-mark-buffer t])
 104        ("Unpick"
 105         ["Article" gnus-summary-unmark-as-processable t]
 106         ["Thread" gnus-uu-unmark-thread t]
 107         ["Region" gnus-uu-unmark-region t]
 108         ["Regexp" gnus-uu-unmark-regexp t]
 109         ["Buffer" gnus-uu-unmark-buffer t])
 110        ["Start reading" gnus-pick-start-reading t]
 111        ["Switch pick mode off" gnus-pick-mode gnus-pick-mode]))))
 112
 113 (defun gnus-pick-mode (&optional arg)
 114   "Minor mode for providing a pick-and-read interface in Gnus summary buffers.
 115
 116 \\{gnus-pick-mode-map}"
 117   (interactive "P")
 118   (when (eq major-mode 'gnus-summary-mode)
 119     (if (not (set (make-local-variable 'gnus-pick-mode)
 120                   (if (null arg) (not gnus-pick-mode)
 121                     (> (prefix-numeric-value arg) 0))))
 122         (remove-hook 'gnus-message-setup-hook 'gnus-pick-setup-message)
 123       ;; Make sure that we don't select any articles upon group entry.
 124       (set (make-local-variable 'gnus-auto-select-first) nil)
 125       ;; Change line format.
 126       (setq gnus-summary-line-format gnus-summary-pick-line-format)
 127       (setq gnus-summary-line-format-spec nil)
 128       (gnus-update-format-specifications nil 'summary)
 129       (gnus-update-summary-mark-positions)
 130       (add-hook 'gnus-message-setup-hook 'gnus-pick-setup-message)
 131       (set (make-local-variable 'gnus-summary-goto-unread) 'never)
 132       ;; Set up the menu.
 133       (when (gnus-visual-p 'pick-menu 'menu)
 134         (gnus-pick-make-menu-bar))
 135       (gnus-add-minor-mode 'gnus-pick-mode " Pick" gnus-pick-mode-map)
 136       (run-hooks 'gnus-pick-mode-hook))))
 137
 138 (defun gnus-pick-setup-message ()
 139   "Make Message do the right thing on exit."
 140   (when (and (gnus-buffer-live-p gnus-summary-buffer)
 141              (save-excursion
 142                (set-buffer gnus-summary-buffer)
 143                gnus-pick-mode))
 144     (message-add-action
 145      '(gnus-configure-windows 'pick t) 'send 'exit 'postpone 'kill)))
 146
 147 (defvar gnus-pick-line-number 1)
 148 (defun gnus-pick-line-number ()
 149   "Return the current line number."
 150   (if (bobp)
 151       (setq gnus-pick-line-number 1)
 152     (incf gnus-pick-line-number)))
 153
 154 (defun gnus-pick-start-reading (&optional catch-up)
 155   "Start reading the picked articles.
 156 If given a prefix, mark all unpicked articles as read."
 157   (interactive "P")
 158   (if gnus-newsgroup-processable
 159       (progn
 160         (gnus-summary-limit-to-articles nil)
 161         (when (or catch-up gnus-mark-unpicked-articles-as-read)
 162           (gnus-summary-limit-mark-excluded-as-read))
 163         (gnus-summary-first-article)
 164         (gnus-configure-windows
 165          (if gnus-pick-display-summary 'article 'pick) t))
 166     (if gnus-pick-elegant-flow
 167         (progn
 168           (when (or catch-up gnus-mark-unpicked-articles-as-read)
 169             (gnus-summary-catchup nil t))
 170           (if (gnus-group-quit-config gnus-newsgroup-name)
 171               (gnus-summary-exit)
 172             (gnus-summary-next-group)))
 173       (error "No articles have been picked"))))
 174
 175 (defun gnus-pick-article (&optional arg)
 176   "Pick the article on the current line.
 177 If ARG, pick the article on that line instead."
 178   (interactive "P")
 179   (when arg
 180     (let (pos)
 181       (save-excursion
 182         (goto-char (point-min))
 183         (when (zerop (forward-line (1- (prefix-numeric-value arg))))
 184           (setq pos (point))))
 185       (if (not pos)
 186           (gnus-error 2 "No such line: %s" arg)
 187         (goto-char pos))))
 188   (gnus-summary-mark-as-processable 1))
 189
 190 (defun gnus-pick-mouse-pick (e)
 191   (interactive "e")
 192   (mouse-set-point e)
 193   (save-excursion
 194     (gnus-summary-mark-as-processable 1)))
 195
 196 (defun gnus-pick-mouse-pick-region (start-event)
 197   "Pick articles that the mouse is dragged over.
 198 This must be bound to a button-down mouse event."
 199   (interactive "e")
 200   (mouse-minibuffer-check start-event)
 201   (let* ((echo-keystrokes 0)
 202          (start-posn (event-start start-event))
 203          (start-point (posn-point start-posn))
 204          (start-line (1+ (count-lines 1 start-point)))
 205          (start-window (posn-window start-posn))
 206          (start-frame (window-frame start-window))
 207          (bounds (window-edges start-window))
 208          (top (nth 1 bounds))
 209          (bottom (if (window-minibuffer-p start-window)
 210                      (nth 3 bounds)
 211                    ;; Don't count the mode line.
 212                    (1- (nth 3 bounds))))
 213          (click-count (1- (event-click-count start-event))))
 214     (setq mouse-selection-click-count click-count)
 215     (setq mouse-selection-click-count-buffer (current-buffer))
 216     (mouse-set-point start-event)
 217     ;; In case the down click is in the middle of some intangible text,
 218     ;; use the end of that text, and put it in START-POINT.
 219     (when (< (point) start-point)
 220       (goto-char start-point))
 221     (gnus-pick-article)
 222     (setq start-point (point))
 223     ;; end-of-range is used only in the single-click case.
 224     ;; It is the place where the drag has reached so far
 225     ;; (but not outside the window where the drag started).
 226     (let (event end end-point last-end-point (end-of-range (point)))
 227       (track-mouse
 228        (while (progn
 229                 (setq event (read-event))
 230                 (or (mouse-movement-p event)
 231                     (eq (car-safe event) 'switch-frame)))
 232          (if (eq (car-safe event) 'switch-frame)
 233              nil
 234            (setq end (event-end event)
 235                  end-point (posn-point end))
 236            (when end-point
 237              (setq last-end-point end-point))
 238
 239            (cond
 240             ;; Are we moving within the original window?
 241             ((and (eq (posn-window end) start-window)
 242                   (integer-or-marker-p end-point))
 243              ;; Go to START-POINT first, so that when we move to END-POINT,
 244              ;; if it's in the middle of intangible text,
 245              ;; point jumps in the direction away from START-POINT.
 246              (goto-char start-point)
 247              (goto-char end-point)
 248              (gnus-pick-article)
 249              ;; In case the user moved his mouse really fast, pick
 250              ;; articles on the line between this one and the last one.
 251              (let* ((this-line (1+ (count-lines 1 end-point)))
 252                     (min-line (min this-line start-line))
 253                     (max-line (max this-line start-line)))
 254                (while (< min-line max-line)
 255                  (goto-line min-line)
 256                  (gnus-pick-article)
 257                  (setq min-line (1+ min-line)))
 258                (setq start-line this-line))
 259              (when (zerop (% click-count 3))
 260                (setq end-of-range (point))))
 261             (t
 262              (let ((mouse-row (cdr (cdr (mouse-position)))))
 263                (cond
 264                 ((null mouse-row))
 265                 ((< mouse-row top)
 266                  (mouse-scroll-subr start-window (- mouse-row top)))
 267                 ((>= mouse-row bottom)
 268                  (mouse-scroll-subr start-window
 269                                     (1+ (- mouse-row bottom)))))))))))
 270       (when (consp event)
 271         (let ((fun (key-binding (vector (car event)))))
 272           ;; Run the binding of the terminating up-event, if possible.
 273           ;; In the case of a multiple click, it gives the wrong results,
 274           ;; because it would fail to set up a region.
 275           (when nil
 276             ;; (and (= (mod mouse-selection-click-count 3) 0) (fboundp fun))
 277             ;; In this case, we can just let the up-event execute normally.
 278             (let ((end (event-end event)))
 279               ;; Set the position in the event before we replay it,
 280               ;; because otherwise it may have a position in the wrong
 281               ;; buffer.
 282               (setcar (cdr end) end-of-range)
 283               ;; Delete the overlay before calling the function,
 284               ;; because delete-overlay increases buffer-modified-tick.
 285               (push event unread-command-events))))))))
 286
 287 (defun gnus-pick-next-page ()
 288   "Go to the next page.  If at the end of the buffer, start reading articles."
 289   (interactive)
 290   (let ((scroll-in-place nil))
 291     (condition-case nil
 292         (scroll-up)
 293       (end-of-buffer (gnus-pick-start-reading)))))
 294
 295 ;;;
 296 ;;; gnus-binary-mode
 297 ;;;
 298
 299 (defvar gnus-binary-mode nil
 300   "Minor mode for providing a binary group interface in Gnus summary buffers.")
 301
 302 (defvar gnus-binary-mode-hook nil
 303   "Hook run in summary binary mode buffers.")
 304
 305 (defvar gnus-binary-mode-map nil)
 306
 307 (unless gnus-binary-mode-map
 308   (setq gnus-binary-mode-map (make-sparse-keymap))
 309
 310   (gnus-define-keys
 311    gnus-binary-mode-map
 312    "g" gnus-binary-show-article))
 313
 314 (defun gnus-binary-make-menu-bar ()
 315   (unless (boundp 'gnus-binary-menu)
 316     (easy-menu-define
 317      gnus-binary-menu gnus-binary-mode-map ""
 318      '("Pick"
 319        ["Switch binary mode off" gnus-binary-mode t]))))
 320
 321 (defun gnus-binary-mode (&optional arg)
 322   "Minor mode for providing a binary group interface in Gnus summary buffers."
 323   (interactive "P")
 324   (when (eq major-mode 'gnus-summary-mode)
 325     (make-local-variable 'gnus-binary-mode)
 326     (setq gnus-binary-mode
 327           (if (null arg) (not gnus-binary-mode)
 328             (> (prefix-numeric-value arg) 0)))
 329     (when gnus-binary-mode
 330       ;; Make sure that we don't select any articles upon group entry.
 331       (make-local-variable 'gnus-auto-select-first)
 332       (setq gnus-auto-select-first nil)
 333       (make-local-variable 'gnus-summary-display-article-function)
 334       (setq gnus-summary-display-article-function 'gnus-binary-display-article)
 335       ;; Set up the menu.
 336       (when (gnus-visual-p 'binary-menu 'menu)
 337         (gnus-binary-make-menu-bar))
 338       (gnus-add-minor-mode 'gnus-binary-mode " Binary" gnus-binary-mode-map)
 339       (run-hooks 'gnus-binary-mode-hook))))
 340
 341 (defun gnus-binary-display-article (article &optional all-header)
 342   "Run ARTICLE through the binary decode functions."
 343   (when (gnus-summary-goto-subject article)
 344     (let ((gnus-view-pseudos 'automatic))
 345       (gnus-uu-decode-uu))))
 346
 347 (defun gnus-binary-show-article (&optional arg)
 348   "Bypass the binary functions and show the article."
 349   (interactive "P")
 350   (let (gnus-summary-display-article-function)
 351     (gnus-summary-show-article arg)))
 352
 353 ;;;
 354 ;;; gnus-tree-mode
 355 ;;;
 356
 357 (defcustom gnus-tree-line-format "%(%[%3,3n%]%)"
 358   "Format of tree elements."
 359   :type 'string
 360   :group 'gnus-summary-tree)
 361
 362 (defcustom gnus-tree-minimize-window t
 363   "If non-nil, minimize the tree buffer window.
 364 If a number, never let the tree buffer grow taller than that number of
 365 lines."
 366   :type 'boolean
 367   :group 'gnus-summary-tree)
 368
 369 (defcustom gnus-selected-tree-face 'modeline
 370   "*Face used for highlighting selected articles in the thread tree."
 371   :type 'face
 372   :group 'gnus-summary-tree)
 373
 374 (defvar gnus-tree-brackets '((?\[ . ?\]) (?\( . ?\))
 375                              (?\{ . ?\}) (?< . ?>))
 376   "Brackets used in tree nodes.")
 377
 378 (defvar gnus-tree-parent-child-edges '(?- ?\\ ?|)
 379   "Characters used to connect parents with children.")
 380
 381 (defcustom gnus-tree-mode-line-format "Gnus: %%b %S %Z"
 382   "*The format specification for the tree mode line."
 383   :type 'string
 384   :group 'gnus-summary-tree)
 385
 386 (defcustom gnus-generate-tree-function 'gnus-generate-vertical-tree
 387   "*Function for generating a thread tree.
 388 Two predefined functions are available:
 389 `gnus-generate-horizontal-tree' and `gnus-generate-vertical-tree'."
 390   :type '(radio (function-item gnus-generate-vertical-tree)
 391                 (function-item gnus-generate-horizontal-tree)
 392                 (function :tag "Other" nil))
 393   :group 'gnus-summary-tree)
 394
 395 (defcustom gnus-tree-mode-hook nil
 396   "*Hook run in tree mode buffers."
 397   :type 'hook
 398   :group 'gnus-summary-tree)
 399
 400 ;;; Internal variables.
 401
 402 (defvar gnus-tree-line-format-alist
 403   `((?n gnus-tmp-name ?s)
 404     (?f gnus-tmp-from ?s)
 405     (?N gnus-tmp-number ?d)
 406     (?\[ gnus-tmp-open-bracket ?c)
 407     (?\] gnus-tmp-close-bracket ?c)
 408     (?s gnus-tmp-subject ?s)))
 409
 410 (defvar gnus-tree-mode-line-format-alist gnus-summary-mode-line-format-alist)
 411
 412 (defvar gnus-tree-mode-line-format-spec nil)
 413 (defvar gnus-tree-line-format-spec nil)
 414
 415 (defvar gnus-tree-node-length nil)
 416 (defvar gnus-selected-tree-overlay nil)
 417
 418 (defvar gnus-tree-displayed-thread nil)
 419
 420 (defvar gnus-tree-mode-map nil)
 421 (put 'gnus-tree-mode 'mode-class 'special)
 422
 423 (unless gnus-tree-mode-map
 424   (setq gnus-tree-mode-map (make-keymap))
 425   (suppress-keymap gnus-tree-mode-map)
 426   (gnus-define-keys
 427    gnus-tree-mode-map
 428    "\r" gnus-tree-select-article
 429    gnus-mouse-2 gnus-tree-pick-article
 430    "\C-?" gnus-tree-read-summary-keys
 431    "h" gnus-tree-show-summary
 432
 433    "\C-c\C-i" gnus-info-find-node)
 434
 435   (substitute-key-definition
 436    'undefined 'gnus-tree-read-summary-keys gnus-tree-mode-map))
 437
 438 (defun gnus-tree-make-menu-bar ()
 439   (unless (boundp 'gnus-tree-menu)
 440     (easy-menu-define
 441      gnus-tree-menu gnus-tree-mode-map ""
 442      '("Tree"
 443        ["Select article" gnus-tree-select-article t]))))
 444
 445 (defun gnus-tree-mode ()
 446   "Major mode for displaying thread trees."
 447   (interactive)
 448   (setq gnus-tree-mode-line-format-spec
 449         (gnus-parse-format gnus-tree-mode-line-format
 450                            gnus-summary-mode-line-format-alist))
 451   (setq gnus-tree-line-format-spec
 452         (gnus-parse-format gnus-tree-line-format
 453                            gnus-tree-line-format-alist t))
 454   (when (gnus-visual-p 'tree-menu 'menu)
 455     (gnus-tree-make-menu-bar))
 456   (kill-all-local-variables)
 457   (gnus-simplify-mode-line)
 458   (setq mode-name "Tree")
 459   (setq major-mode 'gnus-tree-mode)
 460   (use-local-map gnus-tree-mode-map)
 461   (buffer-disable-undo (current-buffer))
 462   (setq buffer-read-only t)
 463   (setq truncate-lines t)
 464   (save-excursion
 465     (gnus-set-work-buffer)
 466     (gnus-tree-node-insert (make-mail-header "") nil)
 467     (setq gnus-tree-node-length (1- (point))))
 468   (run-hooks 'gnus-tree-mode-hook))
 469
 470 (defun gnus-tree-read-summary-keys (&optional arg)
 471   "Read a summary buffer key sequence and execute it."
 472   (interactive "P")
 473   (let ((buf (current-buffer))
 474         win)
 475     (gnus-article-read-summary-keys arg nil t)
 476     (when (setq win (get-buffer-window buf))
 477       (select-window win)
 478       (when gnus-selected-tree-overlay
 479         (goto-char (or (gnus-overlay-end gnus-selected-tree-overlay) 1)))
 480       (gnus-tree-minimize))))
 481
 482 (defun gnus-tree-show-summary ()
 483   "Reconfigure windows to show summary buffer."
 484   (interactive)
 485   (if (not (gnus-buffer-live-p gnus-summary-buffer))
 486       (error "There is no summary buffer for this tree buffer")
 487     (gnus-configure-windows 'article)
 488     (gnus-summary-goto-subject gnus-current-article)))
 489
 490 (defun gnus-tree-select-article (article)
 491   "Select the article under point, if any."
 492   (interactive (list (gnus-tree-article-number)))
 493   (let ((buf (current-buffer)))
 494     (when article
 495       (save-excursion
 496         (set-buffer gnus-summary-buffer)
 497         (gnus-summary-goto-article article))
 498       (select-window (get-buffer-window buf)))))
 499
 500 (defun gnus-tree-pick-article (e)
 501   "Select the article under the mouse pointer."
 502   (interactive "e")
 503   (mouse-set-point e)
 504   (gnus-tree-select-article (gnus-tree-article-number)))
 505
 506 (defun gnus-tree-article-number ()
 507   (get-text-property (point) 'gnus-number))
 508
 509 (defun gnus-tree-article-region (article)
 510   "Return a cons with BEG and END of the article region."
 511   (let ((pos (text-property-any (point-min) (point-max) 'gnus-number article)))
 512     (when pos
 513       (cons pos (next-single-property-change pos 'gnus-number)))))
 514
 515 (defun gnus-tree-goto-article (article)
 516   (let ((pos (text-property-any (point-min) (point-max) 'gnus-number article)))
 517     (when pos
 518       (goto-char pos))))
 519
 520 (defun gnus-tree-recenter ()
 521   "Center point in the tree window."
 522   (let ((selected (selected-window))
 523         (tree-window (get-buffer-window gnus-tree-buffer t)))
 524     (when tree-window
 525       (select-window tree-window)
 526       (when gnus-selected-tree-overlay
 527         (goto-char (or (gnus-overlay-end gnus-selected-tree-overlay) 1)))
 528       (let* ((top (cond ((< (window-height) 4) 0)
 529                         ((< (window-height) 7) 1)
 530                         (t 2)))
 531              (height (1- (window-height)))
 532              (bottom (save-excursion (goto-char (point-max))
 533                                      (forward-line (- height))
 534                                      (point))))
 535         ;; Set the window start to either `bottom', which is the biggest
 536         ;; possible valid number, or the second line from the top,
 537         ;; whichever is the least.
 538         (set-window-start
 539          tree-window (min bottom (save-excursion
 540                                    (forward-line (- top)) (point)))))
 541       (select-window selected))))
 542
 543 (defun gnus-get-tree-buffer ()
 544   "Return the tree buffer properly initialized."
 545   (save-excursion
 546     (set-buffer (get-buffer-create gnus-tree-buffer))
 547     (unless (eq major-mode 'gnus-tree-mode)
 548       (gnus-add-current-to-buffer-list)
 549       (gnus-tree-mode))
 550     (current-buffer)))
 551
 552 (defun gnus-tree-minimize ()
 553   (when (and gnus-tree-minimize-window
 554              (not (one-window-p)))
 555     (let ((windows 0)
 556           tot-win-height)
 557       (walk-windows (lambda (window) (incf windows)))
 558       (setq tot-win-height
 559             (- (frame-height)
 560                (* window-min-height (1- windows))
 561                2))
 562       (let* ((window-min-height 2)
 563              (height (count-lines (point-min) (point-max)))
 564              (min (max (1- window-min-height) height))
 565              (tot (if (numberp gnus-tree-minimize-window)
 566                       (min gnus-tree-minimize-window min)
 567                     min))
 568              (win (get-buffer-window (current-buffer)))
 569              (wh (and win (1- (window-height win)))))
 570         (setq tot (min tot tot-win-height))
 571         (when (and win
 572                    (not (eq tot wh)))
 573           (let ((selected (selected-window)))
 574             (when (ignore-errors (select-window win))
 575               (enlarge-window (- tot wh))
 576               (select-window selected))))))))
 577
 578 ;;; Generating the tree.
 579
 580 (defun gnus-tree-node-insert (header sparse &optional adopted)
 581   (let* ((dummy (stringp header))
 582          (header (if (vectorp header) header
 583                    (progn
 584                      (setq header (make-mail-header "*****"))
 585                      (mail-header-set-number header 0)
 586                      (mail-header-set-lines header 0)
 587                      (mail-header-set-chars header 0)
 588                      header)))
 589          (gnus-tmp-from (mail-header-from header))
 590          (gnus-tmp-subject (mail-header-subject header))
 591          (gnus-tmp-number (mail-header-number header))
 592          (gnus-tmp-name
 593           (cond
 594            ((string-match "(.+)" gnus-tmp-from)
 595             (substring gnus-tmp-from
 596                        (1+ (match-beginning 0)) (1- (match-end 0))))
 597            ((string-match "<[^>]+> *$" gnus-tmp-from)
 598             (let ((beg (match-beginning 0)))
 599               (or (and (string-match "^\"[^\"]*\"" gnus-tmp-from)
 600                        (substring gnus-tmp-from (1+ (match-beginning 0))
 601                                   (1- (match-end 0))))
 602                   (substring gnus-tmp-from 0 beg))))
 603            ((memq gnus-tmp-number sparse)
 604             "***")
 605            (t gnus-tmp-from)))
 606          (gnus-tmp-open-bracket
 607           (cond ((memq gnus-tmp-number sparse)
 608                  (caadr gnus-tree-brackets))
 609                 (dummy (caaddr gnus-tree-brackets))
 610                 (adopted (car (nth 3 gnus-tree-brackets)))
 611                 (t (caar gnus-tree-brackets))))
 612          (gnus-tmp-close-bracket
 613           (cond ((memq gnus-tmp-number sparse)
 614                  (cdadr gnus-tree-brackets))
 615                 (adopted (cdr (nth 3 gnus-tree-brackets)))
 616                 (dummy
 617                  (cdaddr gnus-tree-brackets))
 618                 (t (cdar gnus-tree-brackets))))
 619          (buffer-read-only nil)
 620          beg end)
 621     (gnus-add-text-properties
 622      (setq beg (point))
 623      (setq end (progn (eval gnus-tree-line-format-spec) (point)))
 624      (list 'gnus-number gnus-tmp-number))
 625     (when (or t (gnus-visual-p 'tree-highlight 'highlight))
 626       (gnus-tree-highlight-node gnus-tmp-number beg end))))
 627
 628 (defun gnus-tree-highlight-node (article beg end)
 629   "Highlight current line according to `gnus-summary-highlight'."
 630   (let ((list gnus-summary-highlight)
 631         face)
 632     (save-excursion
 633       (set-buffer gnus-summary-buffer)
 634       (let* ((score (or (cdr (assq article gnus-newsgroup-scored))
 635                         gnus-summary-default-score 0))
 636              (default gnus-summary-default-score)
 637              (mark (or (gnus-summary-article-mark article) gnus-unread-mark)))
 638         ;; Eval the cars of the lists until we find a match.
 639         (while (and list
 640                     (not (eval (caar list))))
 641           (setq list (cdr list)))))
 642     (unless (eq (setq face (cdar list)) (get-text-property beg 'face))
 643       (gnus-put-text-property
 644        beg end 'face
 645        (if (boundp face) (symbol-value face) face)))))
 646
 647 (defun gnus-tree-indent (level)
 648   (insert (make-string (1- (* (1+ gnus-tree-node-length) level)) ? )))
 649
 650 (defvar gnus-tmp-limit)
 651 (defvar gnus-tmp-sparse)
 652 (defvar gnus-tmp-indent)
 653
 654 (defun gnus-generate-tree (thread)
 655   "Generate a thread tree for THREAD."
 656   (save-excursion
 657     (set-buffer (gnus-get-tree-buffer))
 658     (let ((buffer-read-only nil)
 659           (gnus-tmp-indent 0))
 660       (erase-buffer)
 661       (funcall gnus-generate-tree-function thread 0)
 662       (gnus-set-mode-line 'tree)
 663       (goto-char (point-min))
 664       (gnus-tree-minimize)
 665       (gnus-tree-recenter)
 666       (let ((selected (selected-window)))
 667         (when (get-buffer-window (set-buffer gnus-tree-buffer) t)
 668           (select-window (get-buffer-window (set-buffer gnus-tree-buffer) t))
 669           (gnus-horizontal-recenter)
 670           (select-window selected))))))
 671
 672 (defun gnus-generate-horizontal-tree (thread level &optional dummyp adopted)
 673   "Generate a horizontal tree."
 674   (let* ((dummy (stringp (car thread)))
 675          (do (or dummy
 676                  (and (car thread)
 677                       (memq (mail-header-number (car thread))
 678                             gnus-tmp-limit))))
 679          col beg)
 680     (if (not do)
 681         ;; We don't want this article.
 682         (setq thread (cdr thread))
 683       (if (not (bolp))
 684           ;; Not the first article on the line, so we insert a "-".
 685           (insert (car gnus-tree-parent-child-edges))
 686         ;; If the level isn't zero, then we insert some indentation.
 687         (unless (zerop level)
 688           (gnus-tree-indent level)
 689           (insert (cadr gnus-tree-parent-child-edges))
 690           (setq col (- (setq beg (point)) (gnus-point-at-bol) 1))
 691           ;; Draw "|" lines upwards.
 692           (while (progn
 693                    (forward-line -1)
 694                    (forward-char col)
 695                    (= (following-char) ? ))
 696             (delete-char 1)
 697             (insert (caddr gnus-tree-parent-child-edges)))
 698           (goto-char beg)))
 699       (setq dummyp nil)
 700       ;; Insert the article node.
 701       (gnus-tree-node-insert (pop thread) gnus-tmp-sparse adopted))
 702     (if (null thread)
 703         ;; End of the thread, so we go to the next line.
 704         (unless (bolp)
 705           (insert "\n"))
 706       ;; Recurse downwards in all children of this article.
 707       (while thread
 708         (gnus-generate-horizontal-tree
 709          (pop thread) (if do (1+ level) level)
 710          (or dummyp dummy) dummy)))))
 711
 712 (defsubst gnus-tree-indent-vertical ()
 713   (let ((len (- (* (1+ gnus-tree-node-length) gnus-tmp-indent)
 714                 (- (point) (gnus-point-at-bol)))))
 715     (when (> len 0)
 716       (insert (make-string len ? )))))
 717
 718 (defsubst gnus-tree-forward-line (n)
 719   (while (>= (decf n) 0)
 720     (unless (zerop (forward-line 1))
 721       (end-of-line)
 722       (insert "\n")))
 723   (end-of-line))
 724
 725 (defun gnus-generate-vertical-tree (thread level &optional dummyp adopted)
 726   "Generate a vertical tree."
 727   (let* ((dummy (stringp (car thread)))
 728          (do (or dummy
 729                  (and (car thread)
 730                       (memq (mail-header-number (car thread))
 731                             gnus-tmp-limit))))
 732          beg)
 733     (if (not do)
 734         ;; We don't want this article.
 735         (setq thread (cdr thread))
 736       (if (not (save-excursion (beginning-of-line) (bobp)))
 737           ;; Not the first article on the line, so we insert a "-".
 738           (progn
 739             (gnus-tree-indent-vertical)
 740             (insert (make-string (/ gnus-tree-node-length 2) ? ))
 741             (insert (caddr gnus-tree-parent-child-edges))
 742             (gnus-tree-forward-line 1))
 743         ;; If the level isn't zero, then we insert some indentation.
 744         (unless (zerop gnus-tmp-indent)
 745           (gnus-tree-forward-line (1- (* 2 level)))
 746           (gnus-tree-indent-vertical)
 747           (delete-char -1)
 748           (insert (cadr gnus-tree-parent-child-edges))
 749           (setq beg (point))
 750           (forward-char -1)
 751           ;; Draw "-" lines leftwards.
 752           (while (= (char-after (1- (point))) ? )
 753             (delete-char -1)
 754             (insert (car gnus-tree-parent-child-edges))
 755             (forward-char -1))
 756           (goto-char beg)
 757           (gnus-tree-forward-line 1)))
 758       (setq dummyp nil)
 759       ;; Insert the article node.
 760       (gnus-tree-indent-vertical)
 761       (gnus-tree-node-insert (pop thread) gnus-tmp-sparse adopted)
 762       (gnus-tree-forward-line 1))
 763     (if (null thread)
 764         ;; End of the thread, so we go to the next line.
 765         (progn
 766           (goto-char (point-min))
 767           (end-of-line)
 768           (incf gnus-tmp-indent))
 769       ;; Recurse downwards in all children of this article.
 770       (while thread
 771         (gnus-generate-vertical-tree
 772          (pop thread) (if do (1+ level) level)
 773          (or dummyp dummy) dummy)))))
 774
 775 ;;; Interface functions.
 776
 777 (defun gnus-possibly-generate-tree (article &optional force)
 778   "Generate the thread tree for ARTICLE if it isn't displayed already."
 779   (when (save-excursion
 780           (set-buffer gnus-summary-buffer)
 781           (and gnus-use-trees
 782                gnus-show-threads
 783                (vectorp (gnus-summary-article-header article))))
 784     (save-excursion
 785       (let ((top (save-excursion
 786                    (set-buffer gnus-summary-buffer)
 787                    (gnus-cut-thread
 788                     (gnus-remove-thread
 789                      (mail-header-id
 790                       (gnus-summary-article-header article))
 791                      t))))
 792             (gnus-tmp-limit gnus-newsgroup-limit)
 793             (gnus-tmp-sparse gnus-newsgroup-sparse))
 794         (when (or force
 795                   (not (eq top gnus-tree-displayed-thread)))
 796           (gnus-generate-tree top)
 797           (setq gnus-tree-displayed-thread top))))))
 798
 799 (defun gnus-tree-open (group)
 800   (gnus-get-tree-buffer))
 801
 802 (defun gnus-tree-close (group)
 803                                         ;(gnus-kill-buffer gnus-tree-buffer)
 804   )
 805
 806 (defun gnus-highlight-selected-tree (article)
 807   "Highlight the selected article in the tree."
 808   (let ((buf (current-buffer))
 809         region)
 810     (set-buffer gnus-tree-buffer)
 811     (when (setq region (gnus-tree-article-region article))
 812       (when (or (not gnus-selected-tree-overlay)
 813                 (gnus-extent-detached-p gnus-selected-tree-overlay))
 814         ;; Create a new overlay.
 815         (gnus-overlay-put
 816          (setq gnus-selected-tree-overlay (gnus-make-overlay 1 2))
 817          'face gnus-selected-tree-face))
 818       ;; Move the overlay to the article.
 819       (gnus-move-overlay
 820        gnus-selected-tree-overlay (goto-char (car region)) (cdr region))
 821       (gnus-tree-minimize)
 822       (gnus-tree-recenter)
 823       (let ((selected (selected-window)))
 824         (when (get-buffer-window (set-buffer gnus-tree-buffer) t)
 825           (select-window (get-buffer-window (set-buffer gnus-tree-buffer) t))
 826           (gnus-horizontal-recenter)
 827           (select-window selected))))
 828     ;; If we remove this save-excursion, it updates the wrong mode lines?!?
 829     (save-excursion
 830       (set-buffer gnus-tree-buffer)
 831       (gnus-set-mode-line 'tree))
 832     (set-buffer buf)))
 833
 834 (defun gnus-tree-highlight-article (article face)
 835   (save-excursion
 836     (set-buffer (gnus-get-tree-buffer))
 837     (let (region)
 838       (when (setq region (gnus-tree-article-region article))
 839         (gnus-put-text-property (car region) (cdr region) 'face face)
 840         (set-window-point
 841          (get-buffer-window (current-buffer) t) (cdr region))))))
 842
 843 ;;;
 844 ;;; gnus-carpal
 845 ;;;
 846
 847 (defvar gnus-carpal-group-buffer-buttons
 848   '(("next" . gnus-group-next-unread-group)
 849     ("prev" . gnus-group-prev-unread-group)
 850     ("read" . gnus-group-read-group)
 851     ("select" . gnus-group-select-group)
 852     ("catch-up" . gnus-group-catchup-current)
 853     ("new-news" . gnus-group-get-new-news-this-group)
 854     ("toggle-sub" . gnus-group-unsubscribe-current-group)
 855     ("subscribe" . gnus-group-unsubscribe-group)
 856     ("kill" . gnus-group-kill-group)
 857     ("yank" . gnus-group-yank-group)
 858     ("describe" . gnus-group-describe-group)
 859     "list"
 860     ("subscribed" . gnus-group-list-groups)
 861     ("all" . gnus-group-list-all-groups)
 862     ("killed" . gnus-group-list-killed)
 863     ("zombies" . gnus-group-list-zombies)
 864     ("matching" . gnus-group-list-matching)
 865     ("post" . gnus-group-post-news)
 866     ("mail" . gnus-group-mail)
 867     ("rescan" . gnus-group-get-new-news)
 868     ("browse-foreign" . gnus-group-browse-foreign)
 869     ("exit" . gnus-group-exit)))
 870
 871 (defvar gnus-carpal-summary-buffer-buttons
 872   '("mark"
 873     ("read" . gnus-summary-mark-as-read-forward)
 874     ("tick" . gnus-summary-tick-article-forward)
 875     ("clear" . gnus-summary-clear-mark-forward)
 876     ("expirable" . gnus-summary-mark-as-expirable)
 877     "move"
 878     ("scroll" . gnus-summary-next-page)
 879     ("next-unread" . gnus-summary-next-unread-article)
 880     ("prev-unread" . gnus-summary-prev-unread-article)
 881     ("first" . gnus-summary-first-unread-article)
 882     ("best" . gnus-summary-best-unread-article)
 883     "article"
 884     ("headers" . gnus-summary-toggle-header)
 885     ("uudecode" . gnus-uu-decode-uu)
 886     ("enter-digest" . gnus-summary-enter-digest-group)
 887     ("fetch-parent" . gnus-summary-refer-parent-article)
 888     "mail"
 889     ("move" . gnus-summary-move-article)
 890     ("copy" . gnus-summary-copy-article)
 891     ("respool" . gnus-summary-respool-article)
 892     "threads"
 893     ("lower" . gnus-summary-lower-thread)
 894     ("kill" . gnus-summary-kill-thread)
 895     "post"
 896     ("post" . gnus-summary-post-news)
 897     ("mail" . gnus-summary-mail)
 898     ("followup" . gnus-summary-followup-with-original)
 899     ("reply" . gnus-summary-reply-with-original)
 900     ("cancel" . gnus-summary-cancel-article)
 901     "misc"
 902     ("exit" . gnus-summary-exit)
 903     ("fed-up" . gnus-summary-catchup-and-goto-next-group)))
 904
 905 (defvar gnus-carpal-server-buffer-buttons
 906   '(("add" . gnus-server-add-server)
 907     ("browse" . gnus-server-browse-server)
 908     ("list" . gnus-server-list-servers)
 909     ("kill" . gnus-server-kill-server)
 910     ("yank" . gnus-server-yank-server)
 911     ("copy" . gnus-server-copy-server)
 912     ("exit" . gnus-server-exit)))
 913
 914 (defvar gnus-carpal-browse-buffer-buttons
 915   '(("subscribe" . gnus-browse-unsubscribe-current-group)
 916     ("exit" . gnus-browse-exit)))
 917
 918 (defvar gnus-carpal-group-buffer "*Carpal Group*")
 919 (defvar gnus-carpal-summary-buffer "*Carpal Summary*")
 920 (defvar gnus-carpal-server-buffer "*Carpal Server*")
 921 (defvar gnus-carpal-browse-buffer "*Carpal Browse*")
 922
 923 (defvar gnus-carpal-attached-buffer nil)
 924
 925 (defvar gnus-carpal-mode-hook nil
 926   "*Hook run in carpal mode buffers.")
 927
 928 (defvar gnus-carpal-button-face 'bold
 929   "*Face used on carpal buttons.")
 930
 931 (defvar gnus-carpal-header-face 'bold-italic
 932   "*Face used on carpal buffer headers.")
 933
 934 (defvar gnus-carpal-mode-map nil)
 935 (put 'gnus-carpal-mode 'mode-class 'special)
 936
 937 (if gnus-carpal-mode-map
 938     nil
 939   (setq gnus-carpal-mode-map (make-keymap))
 940   (suppress-keymap gnus-carpal-mode-map)
 941   (define-key gnus-carpal-mode-map " " 'gnus-carpal-select)
 942   (define-key gnus-carpal-mode-map "\r" 'gnus-carpal-select)
 943   (define-key gnus-carpal-mode-map gnus-mouse-2 'gnus-carpal-mouse-select))
 944
 945 (defun gnus-carpal-mode ()
 946   "Major mode for clicking buttons.
 947
 948 All normal editing commands are switched off.
 949 \\<gnus-carpal-mode-map>
 950 The following commands are available:
 951
 952 \\{gnus-carpal-mode-map}"
 953   (interactive)
 954   (kill-all-local-variables)
 955   (setq mode-line-modified (cdr gnus-mode-line-modified))
 956   (setq major-mode 'gnus-carpal-mode)
 957   (setq mode-name "Gnus Carpal")
 958   (setq mode-line-process nil)
 959   (use-local-map gnus-carpal-mode-map)
 960   (buffer-disable-undo (current-buffer))
 961   (setq buffer-read-only t)
 962   (make-local-variable 'gnus-carpal-attached-buffer)
 963   (run-hooks 'gnus-carpal-mode-hook))
 964
 965 (defun gnus-carpal-setup-buffer (type)
 966   (let ((buffer (symbol-value (intern (format "gnus-carpal-%s-buffer" type)))))
 967     (if (get-buffer buffer)
 968         ()
 969       (save-excursion
 970         (set-buffer (get-buffer-create buffer))
 971         (gnus-carpal-mode)
 972         (setq gnus-carpal-attached-buffer
 973               (intern (format "gnus-%s-buffer" type)))
 974         (gnus-add-current-to-buffer-list)
 975         (let ((buttons (symbol-value
 976                         (intern (format "gnus-carpal-%s-buffer-buttons"
 977                                         type))))
 978               (buffer-read-only nil)
 979               button)
 980           (while buttons
 981             (setq button (car buttons)
 982                   buttons (cdr buttons))
 983             (if (stringp button)
 984                 (gnus-set-text-properties
 985                  (point)
 986                  (prog2 (insert button) (point) (insert " "))
 987                  (list 'face gnus-carpal-header-face))
 988               (gnus-set-text-properties
 989                (point)
 990                (prog2 (insert (car button)) (point) (insert " "))
 991                (list 'gnus-callback (cdr button)
 992                      'face gnus-carpal-button-face
 993                      gnus-mouse-face-prop 'highlight))))
 994           (let ((fill-column (- (window-width) 2)))
 995             (fill-region (point-min) (point-max)))
 996           (set-window-point (get-buffer-window (current-buffer))
 997                             (point-min)))))))
 998
 999 (defun gnus-carpal-select ()
1000   "Select the button under point."
1001   (interactive)
1002   (let ((func (get-text-property (point) 'gnus-callback)))
1003     (if (null func)
1004         ()
1005       (pop-to-buffer (symbol-value gnus-carpal-attached-buffer))
1006       (call-interactively func))))
1007
1008 (defun gnus-carpal-mouse-select (event)
1009   "Select the button under the mouse pointer."
1010   (interactive "e")
1011   (mouse-set-point event)
1012   (gnus-carpal-select))
1013
1014 ;;; Allow redefinition of functions.
1015 (gnus-ems-redefine)
1016
1017 (provide 'gnus-salt)
1018
1019 ;;; gnus-salt.el ends here