Mercurial > emacs

comparison lisp/gnus/gnus-topic.el @ 31716:9968f55ad26e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Update to emacs-21-branch of the Gnus CVS repository.
author Gerd Moellmann <gerd@gnu.org>
date Tue, 19 Sep 2000 13:37:09 +0000
parents 15fc6acbae7a
children 51cea22fd2aa
comparison
equal deleted inserted replaced
31715:7c896543d225 31716:9968f55ad26e
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,96,97,98 Free Software Foundation, Inc. 2 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
3 ;; Free Software Foundation, Inc.
3 4
4 ;; Author: Ilja Weis <kult@uni-paderborn.de> 5 ;; Author: Ilja Weis <kult@uni-paderborn.de>
5 ;; Lars Magne Ingebrigtsen <larsi@gnus.org> 6 ;; Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Keywords: news 7 ;; Keywords: news
7 8
23 ;; Boston, MA 02111-1307, USA. 24 ;; Boston, MA 02111-1307, USA.
24 25
25 ;;; Commentary: 26 ;;; Commentary:
26 27
27 ;;; Code: 28 ;;; Code:
28
29 (eval-when-compile (require 'cl))
30 29
31 (eval-when-compile (require 'cl)) 30 (eval-when-compile (require 'cl))
32 31
33 (require 'gnus) 32 (require 'gnus)
34 (require 'gnus-group) 33 (require 'gnus-group)
149 (if (gnus-group-goto-group group) 148 (if (gnus-group-goto-group group)
150 (gnus-current-topic) 149 (gnus-current-topic)
151 (gnus-group-topic group)))) 150 (gnus-group-topic group))))
152 151
153 (defun gnus-topic-goto-topic (topic) 152 (defun gnus-topic-goto-topic (topic)
154 "Go to TOPIC."
155 (when topic 153 (when topic
156 (gnus-goto-char (text-property-any (point-min) (point-max) 154 (gnus-goto-char (text-property-any (point-min) (point-max)
157 'gnus-topic (intern topic))))) 155 'gnus-topic (intern topic)))))
158 156
157 (defun gnus-topic-jump-to-topic (topic)
158 "Go to TOPIC."
159 (interactive
160 (list (completing-read "Go to topic: "
161 (mapcar 'list (gnus-topic-list))
162 nil t)))
163 (dolist (topic (gnus-current-topics topic))
164 (gnus-topic-fold t))
165 (gnus-topic-goto-topic topic))
166
159 (defun gnus-current-topic () 167 (defun gnus-current-topic ()
160 "Return the name of the current topic." 168 "Return the name of the current topic."
161 (let ((result 169 (let ((result
162 (or (get-text-property (point) 'gnus-topic) 170 (or (get-text-property (point) 'gnus-topic)
163 (save-excursion 171 (save-excursion
203 (- (1+ (cdr active)) (car active)))) 211 (- (1+ (cdr active)) (car active))))
204 clevel (or (gnus-info-level info) 212 clevel (or (gnus-info-level info)
205 (if (member group gnus-zombie-list) 213 (if (member group gnus-zombie-list)
206 gnus-level-zombie gnus-level-killed)))) 214 gnus-level-zombie gnus-level-killed))))
207 (and 215 (and
208 unread ; nil means that the group is dead. 216 info ; nil means that the group is dead.
209 (<= clevel level) 217 (<= clevel level)
210 (>= clevel lowest) ; Is inside the level we want. 218 (>= clevel lowest) ; Is inside the level we want.
211 (or all 219 (or all
212 (if (eq unread t) 220 (if (or (eq unread t)
221 (eq unread nil))
213 gnus-group-list-inactive-groups 222 gnus-group-list-inactive-groups
214 (> unread 0)) 223 (> unread 0))
215 (and gnus-list-groups-with-ticked-articles 224 (and gnus-list-groups-with-ticked-articles
216 (cdr (assq 'tick (gnus-info-marks info)))) 225 (cdr (assq 'tick (gnus-info-marks info))))
217 ; Has right readedness. 226 ;; Has right readedness.
218 ;; Check for permanent visibility. 227 ;; Check for permanent visibility.
219 (and gnus-permanently-visible-groups 228 (and gnus-permanently-visible-groups
220 (string-match gnus-permanently-visible-groups group)) 229 (string-match gnus-permanently-visible-groups group))
221 (memq 'visible params) 230 (memq 'visible params)
222 (cdr (assq 'visible params))) 231 (cdr (assq 'visible params)))
361 (gnus-dribble-enter 370 (gnus-dribble-enter
362 (format "(setq gnus-topic-topology '%S)" gnus-topic-topology))) 371 (format "(setq gnus-topic-topology '%S)" gnus-topic-topology)))
363 372
364 ;;; Generating group buffers 373 ;;; Generating group buffers
365 374
366 (defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic topic-level) 375 (defun gnus-group-prepare-topics (level &optional all lowest
376 regexp list-topic topic-level)
367 "List all newsgroups with unread articles of level LEVEL or lower. 377 "List all newsgroups with unread articles of level LEVEL or lower.
368 Use the `gnus-group-topics' to sort the groups. 378 Use the `gnus-group-topics' to sort the groups.
369 If ALL is non-nil, list groups that have no unread articles. 379 If ALL is non-nil, list groups that have no unread articles.
370 If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." 380 If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
371 (set-buffer gnus-group-buffer) 381 (set-buffer gnus-group-buffer)
416 articles in the topic and its subtopics." 426 articles in the topic and its subtopics."
417 (let* ((type (pop topicl)) 427 (let* ((type (pop topicl))
418 (entries (gnus-topic-find-groups 428 (entries (gnus-topic-find-groups
419 (car type) list-level 429 (car type) list-level
420 (or all 430 (or all
421 (cdr (assq 'visible 431 (cdr (assq 'visible
422 (gnus-topic-hierarchical-parameters 432 (gnus-topic-hierarchical-parameters
423 (car type))))) 433 (car type)))))
424 lowest)) 434 lowest))
425 (visiblep (and (eq (nth 1 type) 'visible) (not silent))) 435 (visiblep (and (eq (nth 1 type) 'visible) (not silent)))
426 (gnus-group-indentation 436 (gnus-group-indentation
444 (while (setq entry (pop entries)) 454 (while (setq entry (pop entries))
445 (when visiblep 455 (when visiblep
446 (if (stringp entry) 456 (if (stringp entry)
447 ;; Dead groups. 457 ;; Dead groups.
448 (gnus-group-insert-group-line 458 (gnus-group-insert-group-line
449 entry (if (member entry gnus-zombie-list) gnus-level-zombie gnus-level-killed) 459 entry (if (member entry gnus-zombie-list)
460 gnus-level-zombie gnus-level-killed)
450 nil (- (1+ (cdr (setq active (gnus-active entry)))) 461 nil (- (1+ (cdr (setq active (gnus-active entry))))
451 (car active)) 462 (car active))
452 nil) 463 nil)
453 ;; Living groups. 464 ;; Living groups.
454 (when (setq info (nth 2 entry)) 465 (when (setq info (nth 2 entry))
492 ;; reason. I have been unable to determine why this is the 503 ;; reason. I have been unable to determine why this is the
493 ;; case, but this hack seems to take care of things. 504 ;; case, but this hack seems to take care of things.
494 (let ((data (cadr (gnus-topic-find-topology topic)))) 505 (let ((data (cadr (gnus-topic-find-topology topic))))
495 (setcdr data 506 (setcdr data
496 (list (if insert 'visible 'invisible) 507 (list (if insert 'visible 'invisible)
497 (if hide 'hide nil) 508 (caddr data)
498 (cadddr data)))) 509 (cadddr data))))
499 (if total-remove 510 (if total-remove
500 (setq gnus-topic-alist 511 (setq gnus-topic-alist
501 (delq (assoc topic gnus-topic-alist) gnus-topic-alist)) 512 (delq (assoc topic gnus-topic-alist) gnus-topic-alist))
502 (gnus-topic-insert-topic topic in-level))))) 513 (gnus-topic-insert-topic topic in-level)))))
505 "Insert TOPIC." 516 "Insert TOPIC."
506 (gnus-group-prepare-topics 517 (gnus-group-prepare-topics
507 (car gnus-group-list-mode) (cdr gnus-group-list-mode) 518 (car gnus-group-list-mode) (cdr gnus-group-list-mode)
508 nil nil topic level)) 519 nil nil topic level))
509 520
510 (defun gnus-topic-fold (&optional insert) 521 (defun gnus-topic-fold (&optional insert topic)
511 "Remove/insert the current topic." 522 "Remove/insert the current topic."
512 (let ((topic (gnus-group-topic-name))) 523 (let ((topic (or topic (gnus-group-topic-name))))
513 (when topic 524 (when topic
514 (save-excursion 525 (save-excursion
515 (if (not (gnus-group-active-topic-p)) 526 (if (not (gnus-group-active-topic-p))
516 (gnus-topic-remove-topic 527 (gnus-topic-remove-topic
517 (or insert (not (gnus-topic-visible-p)))) 528 (or insert (not (gnus-topic-visible-p))))
531 (active-topic (eq gnus-topic-alist gnus-topic-active-alist)) 542 (active-topic (eq gnus-topic-alist gnus-topic-active-alist))
532 gnus-tmp-header) 543 gnus-tmp-header)
533 (gnus-topic-update-unreads name unread) 544 (gnus-topic-update-unreads name unread)
534 (beginning-of-line) 545 (beginning-of-line)
535 ;; Insert the text. 546 ;; Insert the text.
536 (gnus-add-text-properties 547 (if shownp
537 (point) 548 (gnus-add-text-properties
538 (prog1 (1+ (point)) 549 (point)
539 (eval gnus-topic-line-format-spec)) 550 (prog1 (1+ (point))
540 (list 'gnus-topic (intern name) 551 (eval gnus-topic-line-format-spec))
541 'gnus-topic-level level 552 (list 'gnus-topic (intern name)
542 'gnus-topic-unread unread 553 'gnus-topic-level level
543 'gnus-active active-topic 554 'gnus-topic-unread unread
544 'gnus-topic-visible visiblep)))) 555 'gnus-active active-topic
556 'gnus-topic-visible visiblep)))))
545 557
546 (defun gnus-topic-update-unreads (topic unreads) 558 (defun gnus-topic-update-unreads (topic unreads)
547 (setq gnus-topic-unreads (delq (assoc topic gnus-topic-unreads) 559 (setq gnus-topic-unreads (delq (assoc topic gnus-topic-unreads)
548 gnus-topic-unreads)) 560 gnus-topic-unreads))
549 (push (cons topic unreads) gnus-topic-unreads)) 561 (push (cons topic unreads) gnus-topic-unreads))
582 (defun gnus-topic-goto-missing-group (group) 594 (defun gnus-topic-goto-missing-group (group)
583 "Place point where GROUP is supposed to be inserted." 595 "Place point where GROUP is supposed to be inserted."
584 (let* ((topic (gnus-group-topic group)) 596 (let* ((topic (gnus-group-topic group))
585 (groups (cdr (assoc topic gnus-topic-alist))) 597 (groups (cdr (assoc topic gnus-topic-alist)))
586 (g (cdr (member group groups))) 598 (g (cdr (member group groups)))
587 (unfound t)) 599 (unfound t)
600 entry)
588 ;; Try to jump to a visible group. 601 ;; Try to jump to a visible group.
589 (while (and g (not (gnus-group-goto-group (car g) t))) 602 (while (and g (not (gnus-group-goto-group (car g) t)))
590 (pop g)) 603 (pop g))
591 ;; It wasn't visible, so we try to see where to insert it. 604 ;; It wasn't visible, so we try to see where to insert it.
592 (when (not g) 605 (when (not g)
596 (forward-line 1) 609 (forward-line 1)
597 (setq unfound nil))) 610 (setq unfound nil)))
598 (when (and unfound 611 (when (and unfound
599 topic 612 topic
600 (not (gnus-topic-goto-missing-topic topic))) 613 (not (gnus-topic-goto-missing-topic topic)))
601 (gnus-topic-insert-topic-line 614 (let* ((top (gnus-topic-find-topology topic))
602 topic t t (car (gnus-topic-find-topology topic)) nil 0))))) 615 (children (cddr top))
616 (type (cadr top))
617 (unread 0)
618 (entries (gnus-topic-find-groups
619 (car type) (car gnus-group-list-mode)
620 (cdr gnus-group-list-mode))))
621 (while children
622 (incf unread (gnus-topic-unread (caar (pop children)))))
623 (while (setq entry (pop entries))
624 (when (numberp (car entry))
625 (incf unread (car entry))))
626 (gnus-topic-insert-topic-line
627 topic t t (car (gnus-topic-find-topology topic)) nil unread))))))
603 628
604 (defun gnus-topic-goto-missing-topic (topic) 629 (defun gnus-topic-goto-missing-topic (topic)
605 (if (gnus-topic-goto-topic topic) 630 (if (gnus-topic-goto-topic topic)
606 (forward-line 1) 631 (forward-line 1)
607 ;; Topic not displayed. 632 ;; Topic not displayed.
608 (let* ((top (gnus-topic-find-topology 633 (let* ((top (gnus-topic-find-topology
609 (gnus-topic-parent-topic topic))) 634 (gnus-topic-parent-topic topic)))
610 (tp (reverse (cddr top)))) 635 (tp (reverse (cddr top))))
611 (while (not (equal (caaar tp) topic)) 636 (if (not top)
612 (setq tp (cdr tp))) 637 (gnus-topic-insert-topic-line
613 (pop tp) 638 topic t t (car (gnus-topic-find-topology topic)) nil 0)
614 (while (and tp 639 (while (not (equal (caaar tp) topic))
615 (not (gnus-topic-goto-topic (caaar tp)))) 640 (setq tp (cdr tp)))
616 (pop tp)) 641 (pop tp)
617 (if tp 642 (while (and tp
618 (gnus-topic-forward-topic 1) 643 (not (gnus-topic-goto-topic (caaar tp))))
619 (gnus-topic-goto-missing-topic (caadr top)))) 644 (pop tp))
645 (if tp
646 (gnus-topic-forward-topic 1)
647 (gnus-topic-goto-missing-topic (caadr top)))))
620 nil)) 648 nil))
621 649
622 (defun gnus-topic-update-topic-line (topic-name &optional reads) 650 (defun gnus-topic-update-topic-line (topic-name &optional reads)
623 (let* ((top (gnus-topic-find-topology topic-name)) 651 (let* ((top (gnus-topic-find-topology topic-name))
624 (type (cadr top)) 652 (type (cadr top))
906 ;; Override certain group mode keys. 934 ;; Override certain group mode keys.
907 (gnus-define-keys gnus-topic-mode-map 935 (gnus-define-keys gnus-topic-mode-map
908 "=" gnus-topic-select-group 936 "=" gnus-topic-select-group
909 "\r" gnus-topic-select-group 937 "\r" gnus-topic-select-group
910 " " gnus-topic-read-group 938 " " gnus-topic-read-group
939 "\C-c\C-x" gnus-topic-expire-articles
911 "\C-k" gnus-topic-kill-group 940 "\C-k" gnus-topic-kill-group
912 "\C-y" gnus-topic-yank-group 941 "\C-y" gnus-topic-yank-group
913 "\M-g" gnus-topic-get-new-news-this-topic 942 "\M-g" gnus-topic-get-new-news-this-topic
914 "AT" gnus-topic-list-active 943 "AT" gnus-topic-list-active
915 "Gp" gnus-topic-edit-parameters 944 "Gp" gnus-topic-edit-parameters
929 "m" gnus-topic-move-group 958 "m" gnus-topic-move-group
930 "D" gnus-topic-remove-group 959 "D" gnus-topic-remove-group
931 "c" gnus-topic-copy-group 960 "c" gnus-topic-copy-group
932 "h" gnus-topic-hide-topic 961 "h" gnus-topic-hide-topic
933 "s" gnus-topic-show-topic 962 "s" gnus-topic-show-topic
963 "j" gnus-topic-jump-to-topic
934 "M" gnus-topic-move-matching 964 "M" gnus-topic-move-matching
935 "C" gnus-topic-copy-matching 965 "C" gnus-topic-copy-matching
936 "\C-i" gnus-topic-indent 966 "\C-i" gnus-topic-indent
937 [tab] gnus-topic-indent 967 [tab] gnus-topic-indent
938 "r" gnus-topic-rename 968 "r" gnus-topic-rename
960 ["Move" gnus-topic-move-group t] 990 ["Move" gnus-topic-move-group t]
961 ["Remove" gnus-topic-remove-group t] 991 ["Remove" gnus-topic-remove-group t]
962 ["Copy matching" gnus-topic-copy-matching t] 992 ["Copy matching" gnus-topic-copy-matching t]
963 ["Move matching" gnus-topic-move-matching t]) 993 ["Move matching" gnus-topic-move-matching t])
964 ("Topics" 994 ("Topics"
995 ["Goto" gnus-topic-jump-to-topic t]
965 ["Show" gnus-topic-show-topic t] 996 ["Show" gnus-topic-show-topic t]
966 ["Hide" gnus-topic-hide-topic t] 997 ["Hide" gnus-topic-hide-topic t]
967 ["Delete" gnus-topic-delete t] 998 ["Delete" gnus-topic-delete t]
968 ["Rename" gnus-topic-rename t] 999 ["Rename" gnus-topic-rename t]
969 ["Create" gnus-topic-create-topic t] 1000 ["Create" gnus-topic-create-topic t]
970 ["Mark" gnus-topic-mark-topic t] 1001 ["Mark" gnus-topic-mark-topic t]
971 ["Indent" gnus-topic-indent t] 1002 ["Indent" gnus-topic-indent t]
1003 ["Sort" gnus-topic-sort-topics t]
972 ["Toggle hide empty" gnus-topic-toggle-display-empty-topics t] 1004 ["Toggle hide empty" gnus-topic-toggle-display-empty-topics t]
973 ["Edit parameters" gnus-topic-edit-parameters t]) 1005 ["Edit parameters" gnus-topic-edit-parameters t])
974 ["List active" gnus-topic-list-active t])))) 1006 ["List active" gnus-topic-list-active t]))))
975 1007
976 (defun gnus-topic-mode (&optional arg redisplay) 1008 (defun gnus-topic-mode (&optional arg redisplay)
980 (make-local-variable 'gnus-topic-mode) 1012 (make-local-variable 'gnus-topic-mode)
981 (setq gnus-topic-mode 1013 (setq gnus-topic-mode
982 (if (null arg) (not gnus-topic-mode) 1014 (if (null arg) (not gnus-topic-mode)
983 (> (prefix-numeric-value arg) 0))) 1015 (> (prefix-numeric-value arg) 0)))
984 ;; Infest Gnus with topics. 1016 ;; Infest Gnus with topics.
985 (if (not gnus-topic-mode) 1017 (if (not gnus-topic-mode)
986 (setq gnus-goto-missing-group-function nil) 1018 (setq gnus-goto-missing-group-function nil)
987 (when (gnus-visual-p 'topic-menu 'menu) 1019 (when (gnus-visual-p 'topic-menu 'menu)
988 (gnus-topic-make-menu-bar)) 1020 (gnus-topic-make-menu-bar))
989 (gnus-set-format 'topic t) 1021 (gnus-set-format 'topic t)
990 (gnus-add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map) 1022 (gnus-add-minor-mode 'gnus-topic-mode " Topic"
1023 gnus-topic-mode-map nil (lambda (&rest junk)
1024 (interactive)
1025 (gnus-topic-mode nil t)))
991 (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic) 1026 (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic)
992 (set (make-local-variable 'gnus-group-prepare-function) 1027 (set (make-local-variable 'gnus-group-prepare-function)
993 'gnus-group-prepare-topics) 1028 'gnus-group-prepare-topics)
994 (set (make-local-variable 'gnus-group-get-parameter-function) 1029 (set (make-local-variable 'gnus-group-get-parameter-function)
995 'gnus-group-topic-parameters) 1030 'gnus-group-topic-parameters)
1030 If performed over a topic line, toggle folding the topic." 1065 If performed over a topic line, toggle folding the topic."
1031 (interactive "P") 1066 (interactive "P")
1032 (if (gnus-group-topic-p) 1067 (if (gnus-group-topic-p)
1033 (let ((gnus-group-list-mode 1068 (let ((gnus-group-list-mode
1034 (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode))) 1069 (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
1035 (gnus-topic-fold all)) 1070 (gnus-topic-fold all)
1071 (gnus-dribble-touch))
1036 (gnus-group-select-group all))) 1072 (gnus-group-select-group all)))
1037 1073
1038 (defun gnus-mouse-pick-topic (e) 1074 (defun gnus-mouse-pick-topic (e)
1039 "Select the group or topic under the mouse pointer." 1075 "Select the group or topic under the mouse pointer."
1040 (interactive "e") 1076 (interactive "e")
1041 (mouse-set-point e) 1077 (mouse-set-point e)
1042 (gnus-topic-read-group nil)) 1078 (gnus-topic-read-group nil))
1079
1080 (defun gnus-topic-expire-articles (topic)
1081 "Expire articles in this topic or group."
1082 (interactive (list (gnus-group-topic-name)))
1083 (if (not topic)
1084 (call-interactively 'gnus-group-expire-articles)
1085 (save-excursion
1086 (gnus-message 5 "Expiring groups in %s..." topic)
1087 (let ((gnus-group-marked
1088 (mapcar (lambda (entry) (car (nth 2 entry)))
1089 (gnus-topic-find-groups topic gnus-level-killed t))))
1090 (gnus-group-expire-articles nil))
1091 (gnus-message 5 "Expiring groups in %s...done" topic))))
1043 1092
1044 (defun gnus-topic-read-group (&optional all no-article group) 1093 (defun gnus-topic-read-group (&optional all no-article group)
1045 "Read news in this newsgroup. 1094 "Read news in this newsgroup.
1046 If the prefix argument ALL is non-nil, already read articles become 1095 If the prefix argument ALL is non-nil, already read articles become
1047 readable. IF ALL is a number, fetch this number of articles. If the 1096 readable. IF ALL is a number, fetch this number of articles. If the
1084 (push (list topic) gnus-topic-alist))) 1133 (push (list topic) gnus-topic-alist)))
1085 (gnus-topic-enter-dribble) 1134 (gnus-topic-enter-dribble)
1086 (gnus-group-list-groups) 1135 (gnus-group-list-groups)
1087 (gnus-topic-goto-topic topic)) 1136 (gnus-topic-goto-topic topic))
1088 1137
1138 ;; FIXME:
1139 ;; 1. When the marked groups are overlapped with the process
1140 ;; region, the behavior of move or remove is not right.
1141 ;; 2. Can't process on several marked groups with a same name,
1142 ;; because gnus-group-marked only keeps one copy.
1143
1089 (defun gnus-topic-move-group (n topic &optional copyp) 1144 (defun gnus-topic-move-group (n topic &optional copyp)
1090 "Move the next N groups to TOPIC. 1145 "Move the next N groups to TOPIC.
1091 If COPYP, copy the groups instead." 1146 If COPYP, copy the groups instead."
1092 (interactive 1147 (interactive
1093 (list current-prefix-arg 1148 (list current-prefix-arg
1094 (completing-read "Move to topic: " gnus-topic-alist nil t))) 1149 (completing-read "Move to topic: " gnus-topic-alist nil t)))
1095 (let ((groups (gnus-group-process-prefix n)) 1150 (let ((use-marked (and (not n) (not (gnus-region-active-p))
1151 gnus-group-marked t))
1152 (groups (gnus-group-process-prefix n))
1096 (topicl (assoc topic gnus-topic-alist)) 1153 (topicl (assoc topic gnus-topic-alist))
1154 (start-topic (gnus-group-topic-name))
1097 (start-group (progn (forward-line 1) (gnus-group-group-name))) 1155 (start-group (progn (forward-line 1) (gnus-group-group-name)))
1098 (start-topic (gnus-group-topic-name))
1099 entry) 1156 entry)
1157 (if (and (not groups) (not copyp) start-topic)
1158 (gnus-topic-move start-topic topic)
1159 (mapcar
1160 (lambda (g)
1161 (gnus-group-remove-mark g use-marked)
1162 (when (and
1163 (setq entry (assoc (gnus-current-topic) gnus-topic-alist))
1164 (not copyp))
1165 (setcdr entry (gnus-delete-first g (cdr entry))))
1166 (nconc topicl (list g)))
1167 groups)
1168 (gnus-topic-enter-dribble)
1169 (if start-group
1170 (gnus-group-goto-group start-group)
1171 (gnus-topic-goto-topic start-topic))
1172 (gnus-group-list-groups))))
1173
1174 (defun gnus-topic-remove-group (&optional n)
1175 "Remove the current group from the topic."
1176 (interactive "P")
1177 (let ((use-marked (and (not n) (not (gnus-region-active-p))
1178 gnus-group-marked t))
1179 (groups (gnus-group-process-prefix n)))
1100 (mapcar 1180 (mapcar
1101 (lambda (g) 1181 (lambda (group)
1102 (gnus-group-remove-mark g) 1182 (gnus-group-remove-mark group use-marked)
1103 (when (and 1183 (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist))
1104 (setq entry (assoc (gnus-current-topic) gnus-topic-alist)) 1184 (buffer-read-only nil))
1105 (not copyp)) 1185 (when (and topicl group)
1106 (setcdr entry (gnus-delete-first g (cdr entry)))) 1186 (gnus-delete-line)
1107 (nconc topicl (list g))) 1187 (gnus-delete-first group topicl))
1188 (gnus-topic-update-topic)))
1108 groups) 1189 groups)
1109 (gnus-topic-enter-dribble) 1190 (gnus-topic-enter-dribble)
1110 (if start-group 1191 (gnus-group-position-point)))
1111 (gnus-group-goto-group start-group)
1112 (gnus-topic-goto-topic start-topic))
1113 (gnus-group-list-groups)))
1114
1115 (defun gnus-topic-remove-group (&optional arg)
1116 "Remove the current group from the topic."
1117 (interactive "P")
1118 (gnus-group-iterate arg
1119 (lambda (group)
1120 (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist))
1121 (buffer-read-only nil))
1122 (when (and topicl group)
1123 (gnus-delete-line)
1124 (gnus-delete-first group topicl))
1125 (gnus-topic-update-topic)
1126 (gnus-group-position-point)))))
1127 1192
1128 (defun gnus-topic-copy-group (n topic) 1193 (defun gnus-topic-copy-group (n topic)
1129 "Copy the current group to a topic." 1194 "Copy the current group to a topic."
1130 (interactive 1195 (interactive
1131 (list current-prefix-arg 1196 (list current-prefix-arg
1143 gnus-topic-killed-topics) 1208 gnus-topic-killed-topics)
1144 (gnus-topic-remove-topic nil t) 1209 (gnus-topic-remove-topic nil t)
1145 (gnus-topic-find-topology topic nil nil gnus-topic-topology) 1210 (gnus-topic-find-topology topic nil nil gnus-topic-topology)
1146 (gnus-topic-enter-dribble)) 1211 (gnus-topic-enter-dribble))
1147 (gnus-group-kill-group n discard) 1212 (gnus-group-kill-group n discard)
1148 (gnus-topic-update-topic))) 1213 (if (not (gnus-group-topic-p))
1214 (gnus-topic-update-topic)
1215 ;; Move up one line so that we update the right topic.
1216 (forward-line -1)
1217 (gnus-topic-update-topic)
1218 (forward-line 1))))
1149 1219
1150 (defun gnus-topic-yank-group (&optional arg) 1220 (defun gnus-topic-yank-group (&optional arg)
1151 "Yank the last topic." 1221 "Yank the last topic."
1152 (interactive "p") 1222 (interactive "p")
1153 (if gnus-topic-killed-topics 1223 (if gnus-topic-killed-topics
1193 (setcdr alist (nconc yanked (cdr alist))) 1263 (setcdr alist (nconc yanked (cdr alist)))
1194 (setq alist nil)) 1264 (setq alist nil))
1195 (setq alist (cdr alist)))))) 1265 (setq alist (cdr alist))))))
1196 (gnus-topic-update-topic))) 1266 (gnus-topic-update-topic)))
1197 1267
1198 (defun gnus-topic-hide-topic () 1268 (defun gnus-topic-hide-topic (&optional permanent)
1199 "Hide the current topic." 1269 "Hide the current topic.
1200 (interactive) 1270 If PERMANENT, make it stay hidden in subsequent sessions as well."
1271 (interactive "P")
1201 (when (gnus-current-topic) 1272 (when (gnus-current-topic)
1202 (gnus-topic-goto-topic (gnus-current-topic)) 1273 (gnus-topic-goto-topic (gnus-current-topic))
1203 (gnus-topic-remove-topic nil nil 'hidden))) 1274 (if permanent
1204 1275 (setcar (cddr
1205 (defun gnus-topic-show-topic () 1276 (cadr
1206 "Show the hidden topic." 1277 (gnus-topic-find-topology (gnus-current-topic))))
1207 (interactive) 1278 'hidden))
1279 (gnus-topic-remove-topic nil nil)))
1280
1281 (defun gnus-topic-show-topic (&optional permanent)
1282 "Show the hidden topic.
1283 If PERMANENT, make it stay shown in subsequent sessions as well."
1284 (interactive "P")
1208 (when (gnus-group-topic-p) 1285 (when (gnus-group-topic-p)
1209 (gnus-topic-remove-topic t nil 'shown))) 1286 (if (not permanent)
1287 (gnus-topic-remove-topic t nil)
1288 (let ((topic
1289 (gnus-topic-find-topology
1290 (completing-read "Show topic: " gnus-topic-alist nil t))))
1291 (setcar (cddr (cadr topic)) nil)
1292 (setcar (cdr (cadr topic)) 'visible)
1293 (gnus-group-list-groups)))))
1210 1294
1211 (defun gnus-topic-mark-topic (topic &optional unmark) 1295 (defun gnus-topic-mark-topic (topic &optional unmark)
1212 "Mark all groups in the topic with the process mark." 1296 "Mark all groups in the topic with the process mark."
1213 (interactive (list (gnus-group-topic-name))) 1297 (interactive (list (gnus-group-topic-name)))
1214 (if (not topic) 1298 (if (not topic)
1448 "Sort the current topic alphabetically by backend name. 1532 "Sort the current topic alphabetically by backend name.
1449 If REVERSE, sort in reverse order." 1533 If REVERSE, sort in reverse order."
1450 (interactive "P") 1534 (interactive "P")
1451 (gnus-topic-sort-groups 'gnus-group-sort-by-method reverse)) 1535 (gnus-topic-sort-groups 'gnus-group-sort-by-method reverse))
1452 1536
1537 (defun gnus-topic-sort-topics-1 (top reverse)
1538 (if (cdr top)
1539 (let ((subtop
1540 (mapcar `(lambda (top)
1541 (gnus-topic-sort-topics-1 top ,reverse))
1542 (sort (cdr top)
1543 '(lambda (t1 t2)
1544 (string-lessp (caar t1) (caar t2)))))))
1545 (setcdr top (if reverse (reverse subtop) subtop))))
1546 top)
1547
1548 (defun gnus-topic-sort-topics (&optional topic reverse)
1549 "Sort topics in TOPIC alphabeticaly by topic name.
1550 If REVERSE, reverse the sorting order."
1551 (interactive
1552 (list (completing-read "Sort topics in : " gnus-topic-alist nil t
1553 (gnus-current-topic))
1554 current-prefix-arg))
1555 (let ((topic-topology (or (and topic (cdr (gnus-topic-find-topology topic)))
1556 gnus-topic-topology)))
1557 (gnus-topic-sort-topics-1 topic-topology reverse)
1558 (gnus-topic-enter-dribble)
1559 (gnus-group-list-groups)
1560 (gnus-topic-goto-topic topic)))
1561
1562 (defun gnus-topic-move (current to)
1563 "Move the CURRENT topic to TO."
1564 (interactive
1565 (list
1566 (gnus-group-topic-name)
1567 (completing-read "Move to topic: " gnus-topic-alist nil t)))
1568 (unless (and current to)
1569 (error "Can't find topic"))
1570 (let ((current-top (cdr (gnus-topic-find-topology current)))
1571 (to-top (cdr (gnus-topic-find-topology to))))
1572 (unless current-top
1573 (error "Can't find topic `%s'" current))
1574 (unless to-top
1575 (error "Can't find topic `%s'" to))
1576 (if (gnus-topic-find-topology to current-top 0);; Don't care the level
1577 (error "Can't move `%s' to its sub-level" current))
1578 (gnus-topic-find-topology current nil nil 'delete)
1579 (while (cdr to-top)
1580 (setq to-top (cdr to-top)))
1581 (setcdr to-top (list current-top))
1582 (gnus-topic-enter-dribble)
1583 (gnus-group-list-groups)
1584 (gnus-topic-goto-topic current)))
1585
1586 (defun gnus-subscribe-topics (newsgroup)
1587 (catch 'end
1588 (let (match gnus-group-change-level-function)
1589 (dolist (topic (gnus-topic-list))
1590 (when (and (setq match (cdr (assq 'subscribe
1591 (gnus-topic-parameters topic))))
1592 (string-match match newsgroup))
1593 ;; Just subscribe the group.
1594 (gnus-subscribe-alphabetically newsgroup)
1595 ;; Add the group to the topic.
1596 (nconc (assoc topic gnus-topic-alist) (list newsgroup))
1597 (throw 'end t))))))
1598
1453 (provide 'gnus-topic) 1599 (provide 'gnus-topic)
1454 1600
1455 ;;; gnus-topic.el ends here 1601 ;;; gnus-topic.el ends here