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