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

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