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

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