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