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

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