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