Mercurial > emacs

comparison lisp/gnus/gnus-topic.el @ 89971:cce1c0ee76ee

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Revision: miles@gnu.org--gnu-2004/emacs--unicode--0--patch-36 Merge from emacs--cvs-trunk--0, emacs--gnus--5.10, gnus--rel--5.10 Patches applied: * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523 Merge from emacs--gnus--5.10, gnus--rel--5.10 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-524 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-534 Update from CVS * miles@gnu.org--gnu-2004/emacs--gnus--5.10--base-0 tag of miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-464 * miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-1 Import from CVS branch gnus-5_10-branch * miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-2 Merge from lorentey@elte.hu--2004/emacs--multi-tty--0, emacs--cvs-trunk--0 * miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-3 Merge from gnus--rel--5.10 * miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-4 Merge from gnus--rel--5.10 * miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-18 Update from CVS * miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-19 Remove autoconf-generated files from archive * miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-20 Update from CVS
author Miles Bader <miles@gnu.org>
date Thu, 09 Sep 2004 09:36:36 +0000
parents 561b856c5b1f 55fd4f77387a
children f9a65d7ebd29
comparison
equal deleted inserted replaced
89970:a849e5779b8c 89971:cce1c0ee76ee
1 ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers 1 ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers
2 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 2 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
3 ;; Free Software Foundation, Inc. 3 ;; Free Software Foundation, Inc.
4 4
5 ;; Author: Ilja Weis <kult@uni-paderborn.de> 5 ;; Author: Ilja Weis <kult@uni-paderborn.de>
6 ;; Lars Magne Ingebrigtsen <larsi@gnus.org> 6 ;; Lars Magne Ingebrigtsen <larsi@gnus.org>
7 ;; Keywords: news 7 ;; Keywords: news
43 43
44 (defcustom gnus-topic-mode-hook nil 44 (defcustom gnus-topic-mode-hook nil
45 "Hook run in topic mode buffers." 45 "Hook run in topic mode buffers."
46 :type 'hook 46 :type 'hook
47 :group 'gnus-topic) 47 :group 'gnus-topic)
48
49 (when (featurep 'xemacs)
50 (add-hook 'gnus-topic-mode-hook 'gnus-xmas-topic-menu-add))
48 51
49 (defcustom gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n" 52 (defcustom gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n"
50 "Format of topic lines. 53 "Format of topic lines.
51 It works along the same lines as a normal formatting string, 54 It works along the same lines as a normal formatting string,
52 with some simple extensions. 55 with some simple extensions.
55 %n Topic name. 58 %n Topic name.
56 %v Nothing if the topic is visible, \"...\" otherwise. 59 %v Nothing if the topic is visible, \"...\" otherwise.
57 %g Number of groups in the topic. 60 %g Number of groups in the topic.
58 %a Number of unread articles in the groups in the topic. 61 %a Number of unread articles in the groups in the topic.
59 %A Number of unread articles in the groups in the topic and its subtopics. 62 %A Number of unread articles in the groups in the topic and its subtopics.
60 " 63
64 General format specifiers can also be used.
65 See Info node `(gnus)Formatting Variables'."
66 :link '(custom-manual "(gnus)Formatting Variables")
61 :type 'string 67 :type 'string
62 :group 'gnus-topic) 68 :group 'gnus-topic)
63 69
64 (defcustom gnus-topic-indent-level 2 70 (defcustom gnus-topic-indent-level 2
65 "*How much each subtopic should be indented." 71 "*How much each subtopic should be indented."
159 (interactive 165 (interactive
160 (list (completing-read "Go to topic: " 166 (list (completing-read "Go to topic: "
161 (mapcar 'list (gnus-topic-list)) 167 (mapcar 'list (gnus-topic-list))
162 nil t))) 168 nil t)))
163 (dolist (topic (gnus-current-topics topic)) 169 (dolist (topic (gnus-current-topics topic))
170 (gnus-topic-goto-topic topic)
164 (gnus-topic-fold t)) 171 (gnus-topic-fold t))
165 (gnus-topic-goto-topic topic)) 172 (gnus-topic-goto-topic topic))
166 173
167 (defun gnus-current-topic () 174 (defun gnus-current-topic ()
168 "Return the name of the current topic." 175 "Return the name of the current topic."
194 201
195 (defun gnus-topic-find-groups (topic &optional level all lowest recursive) 202 (defun gnus-topic-find-groups (topic &optional level all lowest recursive)
196 "Return entries for all visible groups in TOPIC. 203 "Return entries for all visible groups in TOPIC.
197 If RECURSIVE is t, return groups in its subtopics too." 204 If RECURSIVE is t, return groups in its subtopics too."
198 (let ((groups (cdr (assoc topic gnus-topic-alist))) 205 (let ((groups (cdr (assoc topic gnus-topic-alist)))
199 info clevel unread group params visible-groups entry active) 206 info clevel unread group params visible-groups entry active)
200 (setq lowest (or lowest 1)) 207 (setq lowest (or lowest 1))
201 (setq level (or level gnus-level-unsubscribed)) 208 (setq level (or level gnus-level-unsubscribed))
202 ;; We go through the newsrc to look for matches. 209 ;; We go through the newsrc to look for matches.
203 (while groups 210 (while groups
204 (when (setq group (pop groups)) 211 (when (setq group (pop groups))
243 (caar topic-topology) 250 (caar topic-topology)
244 level all lowest topic-topology)))) 251 level all lowest topic-topology))))
245 (cdr recursive))) 252 (cdr recursive)))
246 visible-groups)) 253 visible-groups))
247 254
255 (defun gnus-topic-goto-previous-topic (n)
256 "Go to the N'th previous topic."
257 (interactive "p")
258 (gnus-topic-goto-next-topic (- n)))
259
260 (defun gnus-topic-goto-next-topic (n)
261 "Go to the N'th next topic."
262 (interactive "p")
263 (let ((backward (< n 0))
264 (n (abs n))
265 (topic (gnus-current-topic)))
266 (while (and (> n 0)
267 (setq topic
268 (if backward
269 (gnus-topic-previous-topic topic)
270 (gnus-topic-next-topic topic))))
271 (gnus-topic-goto-topic topic)
272 (setq n (1- n)))
273 (when (/= 0 n)
274 (gnus-message 7 "No more topics"))
275 n))
276
248 (defun gnus-topic-previous-topic (topic) 277 (defun gnus-topic-previous-topic (topic)
249 "Return the previous topic on the same level as TOPIC." 278 "Return the previous topic on the same level as TOPIC."
250 (let ((top (cddr (gnus-topic-find-topology 279 (let ((top (cddr (gnus-topic-find-topology
251 (gnus-topic-parent-topic topic))))) 280 (gnus-topic-parent-topic topic)))))
252 (unless (equal topic (caaar top)) 281 (unless (equal topic (caaar top))
349 378
350 (defun gnus-group-topic-parameters (group) 379 (defun gnus-group-topic-parameters (group)
351 "Compute the group parameters for GROUP taking into account inheritance from topics." 380 "Compute the group parameters for GROUP taking into account inheritance from topics."
352 (let ((params-list (copy-sequence (gnus-group-get-parameter group)))) 381 (let ((params-list (copy-sequence (gnus-group-get-parameter group))))
353 (save-excursion 382 (save-excursion
354 (gnus-group-goto-group group)
355 (nconc params-list 383 (nconc params-list
356 (gnus-topic-hierarchical-parameters (gnus-current-topic)))))) 384 (gnus-topic-hierarchical-parameters
385 ;; First we try to go to the group within the group
386 ;; buffer and find the topic for the group that way.
387 ;; This hopefully copes well with groups that are in
388 ;; more than one topic. Failing that (i.e. when the
389 ;; group isn't visible in the group buffer) we find a
390 ;; topic for the group via gnus-group-topic.
391 (or (and (gnus-group-goto-group group)
392 (gnus-current-topic))
393 (gnus-group-topic group)))))))
357 394
358 (defun gnus-topic-hierarchical-parameters (topic) 395 (defun gnus-topic-hierarchical-parameters (topic)
359 "Return a topic list computed for TOPIC." 396 "Return a topic list computed for TOPIC."
360 (let ((topics (gnus-current-topics topic)) 397 (let ((topics (gnus-current-topics topic))
361 params-list param out params) 398 params-list param out params)
382 (gnus-dribble-enter 419 (gnus-dribble-enter
383 (format "(setq gnus-topic-topology '%S)" gnus-topic-topology))) 420 (format "(setq gnus-topic-topology '%S)" gnus-topic-topology)))
384 421
385 ;;; Generating group buffers 422 ;;; Generating group buffers
386 423
387 (defun gnus-group-prepare-topics (level &optional all lowest 424 (defun gnus-group-prepare-topics (level &optional predicate lowest
388 regexp list-topic topic-level) 425 regexp list-topic topic-level)
389 "List all newsgroups with unread articles of level LEVEL or lower. 426 "List all newsgroups with unread articles of level LEVEL or lower.
390 Use the `gnus-group-topics' to sort the groups. 427 Use the `gnus-group-topics' to sort the groups.
391 If ALL is non-nil, list groups that have no unread articles. 428 If PREDICTE is a function, list groups that the function returns non-nil;
429 if it is t, list groups that have no unread articles.
392 If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." 430 If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
393 (set-buffer gnus-group-buffer) 431 (set-buffer gnus-group-buffer)
394 (let ((buffer-read-only nil) 432 (let ((buffer-read-only nil)
395 (lowest (or lowest 1))) 433 (lowest (or lowest 1))
396 434 (not-in-list
435 (and gnus-group-listed-groups
436 (copy-sequence gnus-group-listed-groups))))
437
438 (gnus-update-format-specifications nil 'topic)
439
397 (when (or (not gnus-topic-alist) 440 (when (or (not gnus-topic-alist)
398 (not gnus-topology-checked-p)) 441 (not gnus-topology-checked-p))
399 (gnus-topic-check-topology)) 442 (gnus-topic-check-topology))
400 443
401 (unless list-topic 444 (unless list-topic
402 (erase-buffer)) 445 (erase-buffer))
403 446
404 ;; List dead groups? 447 ;; List dead groups?
405 (when (and (>= level gnus-level-zombie) 448 (when (or gnus-group-listed-groups
406 (<= lowest gnus-level-zombie)) 449 (and (>= level gnus-level-zombie)
450 (<= lowest gnus-level-zombie)))
407 (gnus-group-prepare-flat-list-dead 451 (gnus-group-prepare-flat-list-dead
408 (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) 452 (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
409 gnus-level-zombie ?Z 453 gnus-level-zombie ?Z
410 regexp)) 454 regexp))
411 455
412 (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)) 456 (when (or gnus-group-listed-groups
457 (and (>= level gnus-level-killed)
458 (<= lowest gnus-level-killed)))
413 (gnus-group-prepare-flat-list-dead 459 (gnus-group-prepare-flat-list-dead
414 (setq gnus-killed-list (sort gnus-killed-list 'string<)) 460 (setq gnus-killed-list (sort gnus-killed-list 'string<))
415 gnus-level-killed ?K 461 gnus-level-killed ?K regexp)
416 regexp)) 462 (when not-in-list
463 (unless gnus-killed-hashtb
464 (gnus-make-hashtable-from-killed))
465 (gnus-group-prepare-flat-list-dead
466 (gnus-remove-if (lambda (group)
467 (or (gnus-gethash group gnus-newsrc-hashtb)
468 (gnus-gethash group gnus-killed-hashtb)))
469 not-in-list)
470 gnus-level-killed ?K regexp)))
417 471
418 ;; Use topics. 472 ;; Use topics.
419 (prog1 473 (prog1
420 (when (< lowest gnus-level-zombie) 474 (when (or (< lowest gnus-level-zombie)
475 gnus-group-listed-groups)
421 (if list-topic 476 (if list-topic
422 (let ((top (gnus-topic-find-topology list-topic))) 477 (let ((top (gnus-topic-find-topology list-topic)))
423 (gnus-topic-prepare-topic (cdr top) (car top) 478 (gnus-topic-prepare-topic (cdr top) (car top)
424 (or topic-level level) all 479 (or topic-level level) predicate
425 nil lowest)) 480 nil lowest regexp))
426 (gnus-topic-prepare-topic gnus-topic-topology 0 481 (gnus-topic-prepare-topic gnus-topic-topology 0
427 (or topic-level level) all 482 (or topic-level level) predicate
428 nil lowest))) 483 nil lowest regexp)))
429
430 (gnus-group-set-mode-line) 484 (gnus-group-set-mode-line)
431 (setq gnus-group-list-mode (cons level all)) 485 (setq gnus-group-list-mode (cons level predicate))
432 (gnus-run-hooks 'gnus-group-prepare-hook)))) 486 (gnus-run-hooks 'gnus-group-prepare-hook))))
433 487
434 (defun gnus-topic-prepare-topic (topicl level &optional list-level all silent 488 (defun gnus-topic-prepare-topic (topicl level &optional list-level
435 lowest) 489 predicate silent
490 lowest regexp)
436 "Insert TOPIC into the group buffer. 491 "Insert TOPIC into the group buffer.
437 If SILENT, don't insert anything. Return the number of unread 492 If SILENT, don't insert anything. Return the number of unread
438 articles in the topic and its subtopics." 493 articles in the topic and its subtopics."
439 (let* ((type (pop topicl)) 494 (let* ((type (pop topicl))
440 (entries (gnus-topic-find-groups 495 (entries (gnus-topic-find-groups
441 (car type) list-level 496 (car type)
442 (or all 497 (if gnus-group-listed-groups
498 gnus-level-killed
499 list-level)
500 (or predicate gnus-group-listed-groups
443 (cdr (assq 'visible 501 (cdr (assq 'visible
444 (gnus-topic-hierarchical-parameters 502 (gnus-topic-hierarchical-parameters
445 (car type))))) 503 (car type)))))
446 lowest)) 504 (if gnus-group-listed-groups 0 lowest)))
447 (visiblep (and (eq (nth 1 type) 'visible) (not silent))) 505 (visiblep (and (eq (nth 1 type) 'visible) (not silent)))
448 (gnus-group-indentation 506 (gnus-group-indentation
449 (make-string (* gnus-topic-indent-level level) ? )) 507 (make-string (* gnus-topic-indent-level level) ? ))
450 (beg (progn (beginning-of-line) (point))) 508 (beg (progn (beginning-of-line) (point)))
451 (topicl (reverse topicl)) 509 (topicl (reverse topicl))
456 info entry end active tick) 514 info entry end active tick)
457 ;; Insert any sub-topics. 515 ;; Insert any sub-topics.
458 (while topicl 516 (while topicl
459 (incf unread 517 (incf unread
460 (gnus-topic-prepare-topic 518 (gnus-topic-prepare-topic
461 (pop topicl) (1+ level) list-level all 519 (pop topicl) (1+ level) list-level predicate
462 (not visiblep) lowest))) 520 (not visiblep) lowest regexp)))
463 (setq end (point)) 521 (setq end (point))
464 (goto-char beg) 522 (goto-char beg)
465 ;; Insert all the groups that belong in this topic. 523 ;; Insert all the groups that belong in this topic.
466 (while (setq entry (pop entries)) 524 (while (setq entry (pop entries))
467 (when visiblep 525 (when (if (stringp entry)
468 (if (stringp entry) 526 (gnus-group-prepare-logic
469 ;; Dead groups. 527 entry
470 (gnus-group-insert-group-line 528 (and
471 entry (if (member entry gnus-zombie-list) 529 (or (not gnus-group-listed-groups)
472 gnus-level-zombie gnus-level-killed) 530 (if (< list-level gnus-level-zombie) nil
473 nil (- (1+ (cdr (setq active (gnus-active entry)))) 531 (let ((entry-level
474 (car active)) 532 (if (member entry gnus-zombie-list)
475 nil) 533 gnus-level-zombie gnus-level-killed)))
476 ;; Living groups. 534 (and (<= entry-level list-level)
477 (when (setq info (nth 2 entry)) 535 (>= entry-level lowest)))))
478 (gnus-group-insert-group-line 536 (cond
479 (gnus-info-group info) 537 ((stringp regexp)
480 (gnus-info-level info) (gnus-info-marks info) 538 (string-match regexp entry))
481 (car entry) (gnus-info-method info))))) 539 ((functionp regexp)
482 (when (and (listp entry) 540 (funcall regexp entry))
483 (numberp (car entry))) 541 ((null regexp) t)
484 (incf unread (car entry))) 542 (t nil))))
485 (when (listp entry) 543 (setq info (nth 2 entry))
486 (setq tick t))) 544 (gnus-group-prepare-logic
545 (gnus-info-group info)
546 (and (or (not gnus-group-listed-groups)
547 (let ((entry-level (gnus-info-level info)))
548 (and (<= entry-level list-level)
549 (>= entry-level lowest))))
550 (or (not (functionp predicate))
551 (funcall predicate info))
552 (or (not (stringp regexp))
553 (string-match regexp (gnus-info-group info))))))
554 (when visiblep
555 (if (stringp entry)
556 ;; Dead groups.
557 (gnus-group-insert-group-line
558 entry (if (member entry gnus-zombie-list)
559 gnus-level-zombie gnus-level-killed)
560 nil (- (1+ (cdr (setq active (gnus-active entry))))
561 (car active))
562 nil)
563 ;; Living groups.
564 (when (setq info (nth 2 entry))
565 (gnus-group-insert-group-line
566 (gnus-info-group info)
567 (gnus-info-level info) (gnus-info-marks info)
568 (car entry) (gnus-info-method info)))))
569 (when (and (listp entry)
570 (numberp (car entry)))
571 (incf unread (car entry)))
572 (when (listp entry)
573 (setq tick t))))
487 (goto-char beg) 574 (goto-char beg)
488 ;; Insert the topic line. 575 ;; Insert the topic line.
489 (when (and (not silent) 576 (when (and (not silent)
490 (or gnus-topic-display-empty-topics ;We want empty topics 577 (or gnus-topic-display-empty-topics ;We want empty topics
491 (not (zerop unread)) ;Non-empty 578 (not (zerop unread)) ;Non-empty
591 (defun gnus-topic-update-topic () 678 (defun gnus-topic-update-topic ()
592 "Update all parent topics to the current group." 679 "Update all parent topics to the current group."
593 (when (and (eq major-mode 'gnus-group-mode) 680 (when (and (eq major-mode 'gnus-group-mode)
594 gnus-topic-mode) 681 gnus-topic-mode)
595 (let ((group (gnus-group-group-name)) 682 (let ((group (gnus-group-group-name))
596 (m (point-marker)) 683 (m (point-marker))
597 (buffer-read-only nil)) 684 (buffer-read-only nil))
598 (when (and group 685 (when (and group
599 (gnus-get-info group) 686 (gnus-get-info group)
600 (gnus-topic-goto-topic (gnus-current-topic))) 687 (gnus-topic-goto-topic (gnus-current-topic)))
601 (gnus-topic-update-topic-line (gnus-group-topic-name)) 688 (gnus-topic-update-topic-line (gnus-group-topic-name))
609 (groups (cdr (assoc topic gnus-topic-alist))) 696 (groups (cdr (assoc topic gnus-topic-alist)))
610 (g (cdr (member group groups))) 697 (g (cdr (member group groups)))
611 (unfound t) 698 (unfound t)
612 entry) 699 entry)
613 ;; Try to jump to a visible group. 700 ;; Try to jump to a visible group.
614 (while (and g (not (gnus-group-goto-group (car g) t))) 701 (while (and g
702 (not (gnus-group-goto-group (car g) t)))
615 (pop g)) 703 (pop g))
616 ;; It wasn't visible, so we try to see where to insert it. 704 ;; It wasn't visible, so we try to see where to insert it.
617 (when (not g) 705 (when (not g)
618 (setq g (cdr (member group (reverse groups)))) 706 (setq g (cdr (member group (reverse groups))))
619 (while (and g unfound) 707 (while (and g unfound)
621 (forward-line 1) 709 (forward-line 1)
622 (setq unfound nil))) 710 (setq unfound nil)))
623 (when (and unfound 711 (when (and unfound
624 topic 712 topic
625 (not (gnus-topic-goto-missing-topic topic))) 713 (not (gnus-topic-goto-missing-topic topic)))
626 (let* ((top (gnus-topic-find-topology topic)) 714 (gnus-topic-display-missing-topic topic)))))
627 (children (cddr top)) 715
628 (type (cadr top)) 716 (defun gnus-topic-display-missing-topic (topic)
629 (unread 0) 717 "Insert topic lines recursively for missing topics."
630 (entries (gnus-topic-find-groups 718 (let ((parent (gnus-topic-find-topology
631 (car type) (car gnus-group-list-mode) 719 (gnus-topic-parent-topic topic))))
632 (cdr gnus-group-list-mode)))) 720 (when (and parent
633 (while children 721 (not (gnus-topic-goto-missing-topic (caadr parent))))
634 (incf unread (gnus-topic-unread (caar (pop children))))) 722 (gnus-topic-display-missing-topic (caadr parent))))
635 (while (setq entry (pop entries)) 723 (gnus-topic-goto-missing-topic topic)
636 (when (numberp (car entry)) 724 (let* ((top (gnus-topic-find-topology topic))
637 (incf unread (car entry)))) 725 (children (cddr top))
638 (gnus-topic-insert-topic-line 726 (type (cadr top))
639 topic t t (car (gnus-topic-find-topology topic)) nil unread)))))) 727 (unread 0)
728 (entries (gnus-topic-find-groups
729 (car type) (car gnus-group-list-mode)
730 (cdr gnus-group-list-mode)))
731 entry)
732 (while children
733 (incf unread (gnus-topic-unread (caar (pop children)))))
734 (while (setq entry (pop entries))
735 (when (numberp (car entry))
736 (incf unread (car entry))))
737 (gnus-topic-insert-topic-line
738 topic t t (car (gnus-topic-find-topology topic)) nil unread)))
640 739
641 (defun gnus-topic-goto-missing-topic (topic) 740 (defun gnus-topic-goto-missing-topic (topic)
642 (if (gnus-topic-goto-topic topic) 741 (if (gnus-topic-goto-topic topic)
643 (forward-line 1) 742 (forward-line 1)
644 ;; Topic not displayed. 743 ;; Topic not displayed.
828 (gnus-group-topic-level)) 927 (gnus-group-topic-level))
829 0)) 928 0))
830 ? )) 929 ? ))
831 (yanked (list group)) 930 (yanked (list group))
832 alist talist end) 931 alist talist end)
833 ;; Then we enter the yanked groups into the topics they belong 932 ;; Then we enter the yanked groups into the topics
834 ;; to. 933 ;; they belong to.
835 (when (setq alist (assoc (save-excursion 934 (when (setq alist (assoc (save-excursion
836 (forward-line -1) 935 (forward-line -1)
837 (or 936 (or
838 (gnus-current-topic) 937 (gnus-current-topic)
839 (caar gnus-topic-topology))) 938 (caar gnus-topic-topology)))
947 (gnus-define-keys gnus-topic-mode-map 1046 (gnus-define-keys gnus-topic-mode-map
948 "=" gnus-topic-select-group 1047 "=" gnus-topic-select-group
949 "\r" gnus-topic-select-group 1048 "\r" gnus-topic-select-group
950 " " gnus-topic-read-group 1049 " " gnus-topic-read-group
951 "\C-c\C-x" gnus-topic-expire-articles 1050 "\C-c\C-x" gnus-topic-expire-articles
1051 "c" gnus-topic-catchup-articles
952 "\C-k" gnus-topic-kill-group 1052 "\C-k" gnus-topic-kill-group
953 "\C-y" gnus-topic-yank-group 1053 "\C-y" gnus-topic-yank-group
954 "\M-g" gnus-topic-get-new-news-this-topic 1054 "\M-g" gnus-topic-get-new-news-this-topic
955 "AT" gnus-topic-list-active 1055 "AT" gnus-topic-list-active
956 "Gp" gnus-topic-edit-parameters 1056 "Gp" gnus-topic-edit-parameters
973 "h" gnus-topic-hide-topic 1073 "h" gnus-topic-hide-topic
974 "s" gnus-topic-show-topic 1074 "s" gnus-topic-show-topic
975 "j" gnus-topic-jump-to-topic 1075 "j" gnus-topic-jump-to-topic
976 "M" gnus-topic-move-matching 1076 "M" gnus-topic-move-matching
977 "C" gnus-topic-copy-matching 1077 "C" gnus-topic-copy-matching
1078 "\M-p" gnus-topic-goto-previous-topic
1079 "\M-n" gnus-topic-goto-next-topic
978 "\C-i" gnus-topic-indent 1080 "\C-i" gnus-topic-indent
979 [tab] gnus-topic-indent 1081 [tab] gnus-topic-indent
980 "r" gnus-topic-rename 1082 "r" gnus-topic-rename
981 "\177" gnus-topic-delete 1083 "\177" gnus-topic-delete
982 [delete] gnus-topic-delete 1084 [delete] gnus-topic-delete
985 (gnus-define-keys (gnus-topic-sort-map "S" gnus-group-topic-map) 1087 (gnus-define-keys (gnus-topic-sort-map "S" gnus-group-topic-map)
986 "s" gnus-topic-sort-groups 1088 "s" gnus-topic-sort-groups
987 "a" gnus-topic-sort-groups-by-alphabet 1089 "a" gnus-topic-sort-groups-by-alphabet
988 "u" gnus-topic-sort-groups-by-unread 1090 "u" gnus-topic-sort-groups-by-unread
989 "l" gnus-topic-sort-groups-by-level 1091 "l" gnus-topic-sort-groups-by-level
1092 "e" gnus-topic-sort-groups-by-server
990 "v" gnus-topic-sort-groups-by-score 1093 "v" gnus-topic-sort-groups-by-score
991 "r" gnus-topic-sort-groups-by-rank 1094 "r" gnus-topic-sort-groups-by-rank
992 "m" gnus-topic-sort-groups-by-method)) 1095 "m" gnus-topic-sort-groups-by-method))
993 1096
994 (defun gnus-topic-make-menu-bar () 1097 (defun gnus-topic-make-menu-bar ()
996 (easy-menu-define 1099 (easy-menu-define
997 gnus-topic-menu gnus-topic-mode-map "" 1100 gnus-topic-menu gnus-topic-mode-map ""
998 '("Topics" 1101 '("Topics"
999 ["Toggle topics" gnus-topic-mode t] 1102 ["Toggle topics" gnus-topic-mode t]
1000 ("Groups" 1103 ("Groups"
1001 ["Copy" gnus-topic-copy-group t] 1104 ["Copy..." gnus-topic-copy-group t]
1002 ["Move" gnus-topic-move-group t] 1105 ["Move..." gnus-topic-move-group t]
1003 ["Remove" gnus-topic-remove-group t] 1106 ["Remove" gnus-topic-remove-group t]
1004 ["Copy matching" gnus-topic-copy-matching t] 1107 ["Copy matching..." gnus-topic-copy-matching t]
1005 ["Move matching" gnus-topic-move-matching t]) 1108 ["Move matching..." gnus-topic-move-matching t])
1006 ("Topics" 1109 ("Topics"
1007 ["Goto" gnus-topic-jump-to-topic t] 1110 ["Goto..." gnus-topic-jump-to-topic t]
1008 ["Show" gnus-topic-show-topic t] 1111 ["Show" gnus-topic-show-topic t]
1009 ["Hide" gnus-topic-hide-topic t] 1112 ["Hide" gnus-topic-hide-topic t]
1010 ["Delete" gnus-topic-delete t] 1113 ["Delete" gnus-topic-delete t]
1011 ["Rename" gnus-topic-rename t] 1114 ["Rename..." gnus-topic-rename t]
1012 ["Create" gnus-topic-create-topic t] 1115 ["Create..." gnus-topic-create-topic t]
1013 ["Mark" gnus-topic-mark-topic t] 1116 ["Mark" gnus-topic-mark-topic t]
1014 ["Indent" gnus-topic-indent t] 1117 ["Indent" gnus-topic-indent t]
1015 ["Sort" gnus-topic-sort-topics t] 1118 ["Sort" gnus-topic-sort-topics t]
1119 ["Previous topic" gnus-topic-goto-previous-topic t]
1120 ["Next topic" gnus-topic-goto-next-topic t]
1016 ["Toggle hide empty" gnus-topic-toggle-display-empty-topics t] 1121 ["Toggle hide empty" gnus-topic-toggle-display-empty-topics t]
1017 ["Edit parameters" gnus-topic-edit-parameters t]) 1122 ["Edit parameters" gnus-topic-edit-parameters t])
1018 ["List active" gnus-topic-list-active t])))) 1123 ["List active" gnus-topic-list-active t]))))
1019 1124
1020 (defun gnus-topic-mode (&optional arg redisplay) 1125 (defun gnus-topic-mode (&optional arg redisplay)
1025 (setq gnus-topic-mode 1130 (setq gnus-topic-mode
1026 (if (null arg) (not gnus-topic-mode) 1131 (if (null arg) (not gnus-topic-mode)
1027 (> (prefix-numeric-value arg) 0))) 1132 (> (prefix-numeric-value arg) 0)))
1028 ;; Infest Gnus with topics. 1133 ;; Infest Gnus with topics.
1029 (if (not gnus-topic-mode) 1134 (if (not gnus-topic-mode)
1030 (setq gnus-goto-missing-group-function nil) 1135 (setq gnus-goto-missing-group-function nil)
1031 (when (gnus-visual-p 'topic-menu 'menu) 1136 (when (gnus-visual-p 'topic-menu 'menu)
1032 (gnus-topic-make-menu-bar)) 1137 (gnus-topic-make-menu-bar))
1033 (gnus-set-format 'topic t) 1138 (gnus-set-format 'topic t)
1034 (gnus-add-minor-mode 'gnus-topic-mode " Topic" 1139 (gnus-add-minor-mode 'gnus-topic-mode " Topic"
1035 gnus-topic-mode-map nil (lambda (&rest junk) 1140 gnus-topic-mode-map nil (lambda (&rest junk)
1048 'gnus-topic-update-topics-containing-group) 1153 'gnus-topic-update-topics-containing-group)
1049 (set (make-local-variable 'gnus-group-sort-alist-function) 1154 (set (make-local-variable 'gnus-group-sort-alist-function)
1050 'gnus-group-sort-topic) 1155 'gnus-group-sort-topic)
1051 (setq gnus-group-change-level-function 'gnus-topic-change-level) 1156 (setq gnus-group-change-level-function 'gnus-topic-change-level)
1052 (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group) 1157 (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group)
1053 (make-local-hook 'gnus-check-bogus-groups-hook) 1158 (gnus-make-local-hook 'gnus-check-bogus-groups-hook)
1054 (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist) 1159 (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist
1160 nil 'local)
1055 (setq gnus-topology-checked-p nil) 1161 (setq gnus-topology-checked-p nil)
1056 ;; We check the topology. 1162 ;; We check the topology.
1057 (when gnus-newsrc-alist 1163 (when gnus-newsrc-alist
1058 (gnus-topic-check-topology)) 1164 (gnus-topic-check-topology))
1059 (gnus-run-hooks 'gnus-topic-mode-hook)) 1165 (gnus-run-hooks 'gnus-topic-mode-hook))
1068 (gnus-group-list-groups)))) 1174 (gnus-group-list-groups))))
1069 1175
1070 (defun gnus-topic-select-group (&optional all) 1176 (defun gnus-topic-select-group (&optional all)
1071 "Select this newsgroup. 1177 "Select this newsgroup.
1072 No article is selected automatically. 1178 No article is selected automatically.
1179 If the group is opened, just switch the summary buffer.
1073 If ALL is non-nil, already read articles become readable. 1180 If ALL is non-nil, already read articles become readable.
1074 If ALL is a number, fetch this number of articles. 1181 If ALL is a number, fetch this number of articles.
1075 1182
1076 If performed over a topic line, toggle folding the topic." 1183 If performed over a topic line, toggle folding the topic."
1077 (interactive "P") 1184 (interactive "P")
1185 (when (and (eobp) (not (gnus-group-group-name)))
1186 (forward-line -1))
1078 (if (gnus-group-topic-p) 1187 (if (gnus-group-topic-p)
1079 (let ((gnus-group-list-mode 1188 (let ((gnus-group-list-mode
1080 (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode))) 1189 (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
1081 (gnus-topic-fold all) 1190 (gnus-topic-fold all)
1082 (gnus-dribble-touch)) 1191 (gnus-dribble-touch))
1095 (call-interactively 'gnus-group-expire-articles) 1204 (call-interactively 'gnus-group-expire-articles)
1096 (save-excursion 1205 (save-excursion
1097 (gnus-message 5 "Expiring groups in %s..." topic) 1206 (gnus-message 5 "Expiring groups in %s..." topic)
1098 (let ((gnus-group-marked 1207 (let ((gnus-group-marked
1099 (mapcar (lambda (entry) (car (nth 2 entry))) 1208 (mapcar (lambda (entry) (car (nth 2 entry)))
1100 (gnus-topic-find-groups topic gnus-level-killed t)))) 1209 (gnus-topic-find-groups topic gnus-level-killed t
1210 nil t))))
1101 (gnus-group-expire-articles nil)) 1211 (gnus-group-expire-articles nil))
1102 (gnus-message 5 "Expiring groups in %s...done" topic)))) 1212 (gnus-message 5 "Expiring groups in %s...done" topic))))
1213
1214 (defun gnus-topic-catchup-articles (topic)
1215 "Catchup this topic or group.
1216 Also see `gnus-group-catchup'."
1217 (interactive (list (gnus-group-topic-name)))
1218 (if (not topic)
1219 (call-interactively 'gnus-group-catchup-current)
1220 (save-excursion
1221 (let* ((groups
1222 (mapcar (lambda (entry) (car (nth 2 entry)))
1223 (gnus-topic-find-groups topic gnus-level-killed t
1224 nil t)))
1225 (buffer-read-only nil)
1226 (gnus-group-marked groups))
1227 (gnus-group-catchup-current)
1228 (mapcar 'gnus-topic-update-topics-containing-group groups)))))
1103 1229
1104 (defun gnus-topic-read-group (&optional all no-article group) 1230 (defun gnus-topic-read-group (&optional all no-article group)
1105 "Read news in this newsgroup. 1231 "Read news in this newsgroup.
1106 If the prefix argument ALL is non-nil, already read articles become 1232 If the prefix argument ALL is non-nil, already read articles become
1107 readable. IF ALL is a number, fetch this number of articles. If the 1233 readable. IF ALL is a number, fetch this number of articles. If the
1155 (defun gnus-topic-move-group (n topic &optional copyp) 1281 (defun gnus-topic-move-group (n topic &optional copyp)
1156 "Move the next N groups to TOPIC. 1282 "Move the next N groups to TOPIC.
1157 If COPYP, copy the groups instead." 1283 If COPYP, copy the groups instead."
1158 (interactive 1284 (interactive
1159 (list current-prefix-arg 1285 (list current-prefix-arg
1160 (completing-read "Move to topic: " gnus-topic-alist nil t))) 1286 (gnus-completing-read "Move to topic" gnus-topic-alist nil t
1287 'gnus-topic-history)))
1161 (let ((use-marked (and (not n) (not (gnus-region-active-p)) 1288 (let ((use-marked (and (not n) (not (gnus-region-active-p))
1162 gnus-group-marked t)) 1289 gnus-group-marked t))
1163 (groups (gnus-group-process-prefix n)) 1290 (groups (gnus-group-process-prefix n))
1164 (topicl (assoc topic gnus-topic-alist)) 1291 (topicl (assoc topic gnus-topic-alist))
1165 (start-topic (gnus-group-topic-name)) 1292 (start-topic (gnus-group-topic-name))
1301 (completing-read "Show topic: " gnus-topic-alist nil t)))) 1428 (completing-read "Show topic: " gnus-topic-alist nil t))))
1302 (setcar (cddr (cadr topic)) nil) 1429 (setcar (cddr (cadr topic)) nil)
1303 (setcar (cdr (cadr topic)) 'visible) 1430 (setcar (cdr (cadr topic)) 'visible)
1304 (gnus-group-list-groups))))) 1431 (gnus-group-list-groups)))))
1305 1432
1306 (defun gnus-topic-mark-topic (topic &optional unmark recursive) 1433 (defun gnus-topic-mark-topic (topic &optional unmark non-recursive)
1307 "Mark all groups in the TOPIC with the process mark. 1434 "Mark all groups in the TOPIC with the process mark.
1308 If RECURSIVE is t, mark its subtopics too." 1435 If NON-RECURSIVE (which is the prefix) is t, don't mark its subtopics."
1309 (interactive (list (gnus-group-topic-name) 1436 (interactive (list (gnus-group-topic-name)
1310 nil 1437 nil
1311 (and current-prefix-arg t))) 1438 (and current-prefix-arg t)))
1312 (if (not topic) 1439 (if (not topic)
1313 (call-interactively 'gnus-group-mark-group) 1440 (call-interactively 'gnus-group-mark-group)
1314 (save-excursion 1441 (save-excursion
1315 (let ((groups (gnus-topic-find-groups topic gnus-level-killed t nil 1442 (let ((groups (gnus-topic-find-groups topic gnus-level-killed t nil
1316 recursive))) 1443 (not non-recursive))))
1317 (while groups 1444 (while groups
1318 (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) 1445 (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark)
1319 (gnus-info-group (nth 2 (pop groups))))))))) 1446 (gnus-info-group (nth 2 (pop groups)))))))))
1320 1447
1321 (defun gnus-topic-unmark-topic (topic &optional dummy recursive) 1448 (defun gnus-topic-unmark-topic (topic &optional dummy non-recursive)
1322 "Remove the process mark from all groups in the TOPIC. 1449 "Remove the process mark from all groups in the TOPIC.
1323 If RECURSIVE is t, unmark its subtopics too." 1450 If NON-RECURSIVE (which is the prefix) is t, don't unmark its subtopics."
1324 (interactive (list (gnus-group-topic-name) 1451 (interactive (list (gnus-group-topic-name)
1325 nil 1452 nil
1326 (and current-prefix-arg t))) 1453 (and current-prefix-arg t)))
1327 (if (not topic) 1454 (if (not topic)
1328 (call-interactively 'gnus-group-unmark-group) 1455 (call-interactively 'gnus-group-unmark-group)
1329 (gnus-topic-mark-topic topic t recursive))) 1456 (gnus-topic-mark-topic topic t non-recursive)))
1330 1457
1331 (defun gnus-topic-get-new-news-this-topic (&optional n) 1458 (defun gnus-topic-get-new-news-this-topic (&optional n)
1332 "Check for new news in the current topic." 1459 "Check for new news in the current topic."
1333 (interactive "P") 1460 (interactive "P")
1334 (if (not (gnus-group-topic-p)) 1461 (if (not (gnus-group-topic-p))
1335 (gnus-group-get-new-news-this-group n) 1462 (gnus-group-get-new-news-this-group n)
1336 (gnus-topic-mark-topic (gnus-group-topic-name) nil (and n t)) 1463 (let* ((topic (gnus-group-topic-name))
1337 (gnus-group-get-new-news-this-group))) 1464 (data (cadr (gnus-topic-find-topology topic))))
1465 (save-excursion
1466 (gnus-topic-mark-topic topic nil (and n t))
1467 (gnus-group-get-new-news-this-group))
1468 (gnus-topic-remove-topic (eq 'visible (cadr data))))))
1338 1469
1339 (defun gnus-topic-move-matching (regexp topic &optional copyp) 1470 (defun gnus-topic-move-matching (regexp topic &optional copyp)
1340 "Move all groups that match REGEXP to some topic." 1471 "Move all groups that match REGEXP to some topic."
1341 (interactive 1472 (interactive
1342 (let (topic) 1473 (let (topic)
1378 (defun gnus-topic-rename (old-name new-name) 1509 (defun gnus-topic-rename (old-name new-name)
1379 "Rename a topic." 1510 "Rename a topic."
1380 (interactive 1511 (interactive
1381 (let ((topic (gnus-current-topic))) 1512 (let ((topic (gnus-current-topic)))
1382 (list topic 1513 (list topic
1383 (read-string (format "Rename %s to: " topic))))) 1514 (read-string (format "Rename %s to: " topic) topic))))
1384 ;; Check whether the new name exists. 1515 ;; Check whether the new name exists.
1385 (when (gnus-topic-find-topology new-name) 1516 (when (gnus-topic-find-topology new-name)
1386 (error "Topic '%s' already exists" new-name)) 1517 (error "Topic '%s' already exists" new-name))
1387 ;; "nil" is an invalid name, for reasons I'd rather not go 1518 ;; "nil" is an invalid name, for reasons I'd rather not go
1388 ;; into here. Trust me. 1519 ;; into here. Trust me.
1550 "Sort the current topic alphabetically by backend name. 1681 "Sort the current topic alphabetically by backend name.
1551 If REVERSE, sort in reverse order." 1682 If REVERSE, sort in reverse order."
1552 (interactive "P") 1683 (interactive "P")
1553 (gnus-topic-sort-groups 'gnus-group-sort-by-method reverse)) 1684 (gnus-topic-sort-groups 'gnus-group-sort-by-method reverse))
1554 1685
1686 (defun gnus-topic-sort-groups-by-server (&optional reverse)
1687 "Sort the current topic alphabetically by server name.
1688 If REVERSE, sort in reverse order."
1689 (interactive "P")
1690 (gnus-topic-sort-groups 'gnus-group-sort-by-server reverse))
1691
1555 (defun gnus-topic-sort-topics-1 (top reverse) 1692 (defun gnus-topic-sort-topics-1 (top reverse)
1556 (if (cdr top) 1693 (if (cdr top)
1557 (let ((subtop 1694 (let ((subtop
1558 (mapcar `(lambda (top) 1695 (mapcar (gnus-byte-compile
1559 (gnus-topic-sort-topics-1 top ,reverse)) 1696 `(lambda (top)
1697 (gnus-topic-sort-topics-1 top ,reverse)))
1560 (sort (cdr top) 1698 (sort (cdr top)
1561 '(lambda (t1 t2) 1699 (lambda (t1 t2)
1562 (string-lessp (caar t1) (caar t2))))))) 1700 (string-lessp (caar t1) (caar t2)))))))
1563 (setcdr top (if reverse (reverse subtop) subtop)))) 1701 (setcdr top (if reverse (reverse subtop) subtop))))
1564 top) 1702 top)
1565 1703
1566 (defun gnus-topic-sort-topics (&optional topic reverse) 1704 (defun gnus-topic-sort-topics (&optional topic reverse)
1567 "Sort topics in TOPIC alphabetically by topic name. 1705 "Sort topics in TOPIC alphabetically by topic name.
1610 (string-match match newsgroup)) 1748 (string-match match newsgroup))
1611 ;; Just subscribe the group. 1749 ;; Just subscribe the group.
1612 (gnus-subscribe-alphabetically newsgroup) 1750 (gnus-subscribe-alphabetically newsgroup)
1613 ;; Add the group to the topic. 1751 ;; Add the group to the topic.
1614 (nconc (assoc topic gnus-topic-alist) (list newsgroup)) 1752 (nconc (assoc topic gnus-topic-alist) (list newsgroup))
1615 (throw 'end t)))))) 1753 ;; if this topic specifies a default level, use it
1754 (let ((subscribe-level (cdr (assq 'subscribe-level
1755 (gnus-topic-parameters topic)))))
1756 (when subscribe-level
1757 (gnus-group-change-level newsgroup subscribe-level
1758 gnus-level-default-subscribed)))
1759 (throw 'end t)))
1760 nil)))
1616 1761
1617 (provide 'gnus-topic) 1762 (provide 'gnus-topic)
1618 1763
1619 ;;; arch-tag: bf176856-f30c-40f0-ae77-e41529a1134c 1764 ;;; arch-tag: bf176856-f30c-40f0-ae77-e41529a1134c
1620 ;;; gnus-topic.el ends here 1765 ;;; gnus-topic.el ends here