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