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