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