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