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