cgit.sxemacs.org Git - gnus/blob - lisp/gnus-salt.el

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