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