Lines Matching +defs:gnus +defs:tmp +defs:level
0 ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers
7 ;; Lars Magne Ingebrigtsen <larsi@gnus.org>
33 (require 'gnus)
34 (require 'gnus-group)
35 (require 'gnus-start)
36 (require 'gnus-util)
38 (defgroup gnus-topic nil
40 :group 'gnus-group)
42 (defvar gnus-topic-mode nil
45 (defcustom gnus-topic-mode-hook nil
48 :group 'gnus-topic)
51 (add-hook 'gnus-topic-mode-hook 'gnus-xmas-topic-menu-add))
53 (defcustom gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n"
58 %i Indentation based on topic level.
66 See Info node `(gnus)Formatting Variables'."
67 :link '(custom-manual "(gnus)Formatting Variables")
69 :group 'gnus-topic)
71 (defcustom gnus-topic-indent-level 2
74 :group 'gnus-topic)
76 (defcustom gnus-topic-display-empty-topics t
79 :group 'gnus-topic)
83 (defvar gnus-topic-active-topology nil)
84 (defvar gnus-topic-active-alist nil)
85 (defvar gnus-topic-unreads nil)
87 (defvar gnus-topology-checked-p nil
90 (defvar gnus-topic-killed-topics nil)
91 (defvar gnus-topic-inhibit-change-level nil)
93 (defconst gnus-topic-line-format-alist
98 (?a (gnus-topic-articles-in-topic entries) ?d)
100 (?l level ?d)))
102 (defvar gnus-topic-line-format-spec nil)
106 (defun gnus-group-topic-name ()
108 (let ((topic (get-text-property (gnus-point-at-bol) 'gnus-topic)))
111 (defun gnus-group-topic-level ()
112 "The level of the topic on the current line."
113 (get-text-property (gnus-point-at-bol) 'gnus-topic-level))
115 (defun gnus-group-topic-unread ()
117 (get-text-property (gnus-point-at-bol) 'gnus-topic-unread))
119 (defun gnus-topic-unread (topic)
121 (or (cdr (assoc topic gnus-topic-unreads))
124 (defun gnus-group-topic-p ()
126 (gnus-group-topic-name))
128 (defun gnus-topic-visible-p ()
130 (get-text-property (gnus-point-at-bol) 'gnus-topic-visible))
132 (defun gnus-topic-articles-in-topic (entries)
140 (defun gnus-group-topic (group)
142 (let ((alist gnus-topic-alist)
151 (defun gnus-group-parent-topic (group)
154 (set-buffer gnus-group-buffer)
155 (if (gnus-group-goto-group group)
156 (gnus-current-topic)
157 (gnus-group-topic group))))
159 (defun gnus-topic-goto-topic (topic)
161 (gnus-goto-char (text-property-any (point-min) (point-max)
162 'gnus-topic (intern topic)))))
164 (defun gnus-topic-jump-to-topic (topic)
168 (mapcar 'list (gnus-topic-list))
170 (dolist (topic (gnus-current-topics topic))
171 (gnus-topic-goto-topic topic)
172 (gnus-topic-fold t))
173 (gnus-topic-goto-topic topic))
175 (defun gnus-current-topic ()
178 (or (get-text-property (point) 'gnus-topic)
180 (and (gnus-goto-char (previous-single-property-change
181 (point) 'gnus-topic))
183 'gnus-topic))))))
187 (defun gnus-current-topics (&optional topic)
190 (let ((topic (or topic (gnus-current-topic)))
194 (setq topic (gnus-topic-parent-topic topic)))
197 (defun gnus-group-active-topic-p ()
201 (get-text-property (point) 'gnus-active)))
203 (defun gnus-topic-find-groups (topic &optional level all lowest recursive)
206 (let ((groups (cdr (assoc topic gnus-topic-alist)))
209 (setq level (or level gnus-level-unsubscribed))
213 (setq entry (gnus-gethash group gnus-newsrc-hashtb)
215 params (gnus-info-params info)
216 active (gnus-active group)
221 clevel (or (gnus-info-level info)
222 (if (member group gnus-zombie-list)
223 gnus-level-zombie gnus-level-killed))))
226 (<= clevel level)
227 (>= clevel lowest) ; Is inside the level we want.
231 gnus-group-list-inactive-groups
233 (and gnus-list-groups-with-ticked-articles
234 (cdr (assq 'tick (gnus-info-marks info))))
237 (and gnus-permanently-visible-groups
238 (string-match gnus-permanently-visible-groups group))
246 (setq recursive (cdr (gnus-topic-find-topology topic))))
250 (gnus-topic-find-groups
252 level all lowest topic-topology))))
256 (defun gnus-topic-goto-previous-topic (n)
259 (gnus-topic-goto-next-topic (- n)))
261 (defun gnus-topic-goto-next-topic (n)
266 (topic (gnus-current-topic)))
270 (gnus-topic-previous-topic topic)
271 (gnus-topic-next-topic topic))))
272 (gnus-topic-goto-topic topic)
275 (gnus-message 7 "No more topics"))
278 (defun gnus-topic-previous-topic (topic)
279 "Return the previous topic on the same level as TOPIC."
280 (let ((top (cddr (gnus-topic-find-topology
281 (gnus-topic-parent-topic topic)))))
287 (defun gnus-topic-parent-topic (topic &optional topology)
290 (setq topology gnus-topic-topology))
295 (not (setq result (gnus-topic-parent-topic
300 (defun gnus-topic-next-topic (topic &optional previous)
302 (let ((parentt (cddr (gnus-topic-find-topology
303 (gnus-topic-parent-topic topic))))
313 (defun gnus-topic-forward-topic (num)
314 "Go to the next topic on the same level as the current one."
315 (let* ((topic (gnus-current-topic))
316 (way (if (< num 0) 'gnus-topic-previous-topic
317 'gnus-topic-next-topic))
321 (when (gnus-topic-goto-topic topic)
327 (defun gnus-topic-find-topology (topic &optional topology level remove)
330 (setq topology gnus-topic-topology)
331 (setq level 0))
338 (cons level topology))
341 (not (setq result (gnus-topic-find-topology
342 topic (car topology) (1+ level)
347 (defvar gnus-tmp-topics nil)
348 (defun gnus-topic-list (&optional topology)
351 (setq topology gnus-topic-topology
352 gnus-tmp-topics nil))
353 (push (caar topology) gnus-tmp-topics)
354 (mapcar 'gnus-topic-list (cdr topology))
355 gnus-tmp-topics)
359 (defun gnus-topic-parameters (topic)
361 (let ((top (gnus-topic-find-topology topic)))
365 (defun gnus-topic-set-parameters (topic parameters)
367 (let ((top (gnus-topic-find-topology topic)))
377 (gnus-dribble-enter
378 (format "(gnus-topic-set-parameters %S '%S)" topic parameters))))
380 (defun gnus-group-topic-parameters (group)
382 (let ((params-list (copy-sequence (gnus-group-get-parameter group))))
385 (gnus-topic-hierarchical-parameters
391 ;; topic for the group via gnus-group-topic.
392 (or (and (gnus-group-goto-group group)
393 (gnus-current-topic))
394 (gnus-group-topic group)))))))
396 (defun gnus-topic-hierarchical-parameters (topic)
398 (let ((topics (gnus-current-topics topic))
401 (push (gnus-topic-parameters (pop topics)) params-list))
412 (gnus-pull (car param) out)
419 (defun gnus-topic-enter-dribble ()
420 (gnus-dribble-enter
421 (format "(setq gnus-topic-topology '%S)" gnus-topic-topology)))
425 (defun gnus-group-prepare-topics (level &optional predicate lowest
426 regexp list-topic topic-level)
427 "List all newsgroups with unread articles of level LEVEL or lower.
428 Use the `gnus-group-topics' to sort the groups.
431 If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
432 (set-buffer gnus-group-buffer)
436 (and gnus-group-listed-groups
437 (copy-sequence gnus-group-listed-groups))))
439 (gnus-update-format-specifications nil 'topic)
441 (when (or (not gnus-topic-alist)
442 (not gnus-topology-checked-p))
443 (gnus-topic-check-topology))
449 (when (or gnus-group-listed-groups
450 (and (>= level gnus-level-zombie)
451 (<= lowest gnus-level-zombie)))
452 (gnus-group-prepare-flat-list-dead
453 (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
454 gnus-level-zombie ?Z
457 (when (or gnus-group-listed-groups
458 (and (>= level gnus-level-killed)
459 (<= lowest gnus-level-killed)))
460 (gnus-group-prepare-flat-list-dead
461 (setq gnus-killed-list (sort gnus-killed-list 'string<))
462 gnus-level-killed ?K regexp)
464 (unless gnus-killed-hashtb
465 (gnus-make-hashtable-from-killed))
466 (gnus-group-prepare-flat-list-dead
467 (gnus-remove-if (lambda (group)
468 (or (gnus-gethash group gnus-newsrc-hashtb)
469 (gnus-gethash group gnus-killed-hashtb)))
471 gnus-level-killed ?K regexp)))
475 (when (or (< lowest gnus-level-zombie)
476 gnus-group-listed-groups)
478 (let ((top (gnus-topic-find-topology list-topic)))
479 (gnus-topic-prepare-topic (cdr top) (car top)
480 (or topic-level level) predicate
482 (gnus-topic-prepare-topic gnus-topic-topology 0
483 (or topic-level level) predicate
485 (gnus-group-set-mode-line)
486 (setq gnus-group-list-mode (cons level predicate))
487 (gnus-run-hooks 'gnus-group-prepare-hook))))
489 (defun gnus-topic-prepare-topic (topicl level &optional list-level
496 (entries (gnus-topic-find-groups
498 (if gnus-group-listed-groups
499 gnus-level-killed
500 list-level)
501 (or predicate gnus-group-listed-groups
503 (gnus-topic-hierarchical-parameters
505 (if gnus-group-listed-groups 0 lowest)))
507 (gnus-group-indentation
508 (make-string (* gnus-topic-indent-level level) ? ))
519 (gnus-topic-prepare-topic
520 (pop topicl) (1+ level) list-level predicate
527 (gnus-group-prepare-logic
530 (or (not gnus-group-listed-groups)
531 (if (< list-level gnus-level-zombie) nil
532 (let ((entry-level
533 (if (member entry gnus-zombie-list)
534 gnus-level-zombie gnus-level-killed)))
535 (and (<= entry-level list-level)
536 (>= entry-level lowest)))))
545 (gnus-group-prepare-logic
546 (gnus-info-group info)
547 (and (or (not gnus-group-listed-groups)
548 (let ((entry-level (gnus-info-level info)))
549 (and (<= entry-level list-level)
550 (>= entry-level lowest))))
554 (string-match regexp (gnus-info-group info))))))
558 (gnus-group-insert-group-line
559 entry (if (member entry gnus-zombie-list)
560 gnus-level-zombie gnus-level-killed)
561 nil (- (1+ (cdr (setq active (gnus-active entry))))
566 (gnus-group-insert-group-line
567 (gnus-info-group info)
568 (gnus-info-level info) (gnus-info-marks info)
569 (car entry) (gnus-info-method info)))))
578 (or gnus-topic-display-empty-topics ;We want empty topics
582 (gnus-extent-start-open (point))
583 (gnus-topic-insert-topic-line
586 level all-entries unread))
587 (gnus-topic-update-unreads (car type) unread)
588 (when gnus-group-update-tool-bar
589 (gnus-put-text-property beg end 'point-entered
590 'gnus-tool-bar-update)
591 (gnus-put-text-property beg end 'point-left
592 'gnus-tool-bar-update))
596 (defun gnus-topic-remove-topic (&optional insert total-remove hide in-level)
598 (let ((topic (gnus-group-topic-name))
599 (level (gnus-group-topic-level))
604 (> (or (gnus-group-topic-level) (1+ level)) level)))
610 (let ((data (cadr (gnus-topic-find-topology topic))))
616 (setq gnus-topic-alist
617 (delq (assoc topic gnus-topic-alist) gnus-topic-alist))
618 (gnus-topic-insert-topic topic in-level)))))
620 (defun gnus-topic-insert-topic (topic &optional level)
622 (gnus-group-prepare-topics
623 (car gnus-group-list-mode) (cdr gnus-group-list-mode)
624 nil nil topic level))
626 (defun gnus-topic-fold (&optional insert topic)
628 (let ((topic (or topic (gnus-group-topic-name))))
631 (if (not (gnus-group-active-topic-p))
632 (gnus-topic-remove-topic
633 (or insert (not (gnus-topic-visible-p))))
634 (let ((gnus-topic-topology gnus-topic-active-topology)
635 (gnus-topic-alist gnus-topic-active-alist)
636 (gnus-group-list-mode (cons 5 t)))
637 (gnus-topic-remove-topic
638 (or insert (not (gnus-topic-visible-p))) nil nil 9)
639 (gnus-topic-enter-dribble)))))))
641 (defun gnus-topic-insert-topic-line (name visiblep shownp level entries
644 (indentation (make-string (* gnus-topic-indent-level level) ? ))
647 (active-topic (eq gnus-topic-alist gnus-topic-active-alist))
648 gnus-tmp-header)
649 (gnus-topic-update-unreads name unread)
653 (gnus-add-text-properties
656 (eval gnus-topic-line-format-spec))
657 (list 'gnus-topic (intern name)
658 'gnus-topic-level level
659 'gnus-topic-unread unread
660 'gnus-active active-topic
661 'gnus-topic-visible visiblep)))))
663 (defun gnus-topic-update-unreads (topic unreads)
664 (setq gnus-topic-unreads (delq (assoc topic gnus-topic-unreads)
665 gnus-topic-unreads))
666 (push (cons topic unreads) gnus-topic-unreads))
668 (defun gnus-topic-update-topics-containing-group (group)
670 (when (and (eq major-mode 'gnus-group-mode)
671 gnus-topic-mode)
673 (let ((alist gnus-topic-alist))
680 (gnus-topic-goto-topic (caar alist)))
681 (gnus-topic-update-topic-line (caar alist)))
684 (defun gnus-topic-update-topic ()
686 (when (and (eq major-mode 'gnus-group-mode)
687 gnus-topic-mode)
688 (let ((group (gnus-group-group-name))
692 (gnus-get-info group)
693 (gnus-topic-goto-topic (gnus-current-topic)))
694 (gnus-topic-update-topic-line (gnus-group-topic-name))
697 (gnus-group-position-point)))))
699 (defun gnus-topic-goto-missing-group (group)
701 (let* ((topic (gnus-group-topic group))
702 (groups (cdr (assoc topic gnus-topic-alist)))
708 (not (gnus-group-goto-group (car g) t)))
714 (when (gnus-group-goto-group (pop g) t)
719 (not (gnus-topic-goto-missing-topic topic)))
720 (gnus-topic-display-missing-topic topic)))))
722 (defun gnus-topic-display-missing-topic (topic)
724 (let ((parent (gnus-topic-find-topology
725 (gnus-topic-parent-topic topic))))
727 (not (gnus-topic-goto-missing-topic (caadr parent))))
728 (gnus-topic-display-missing-topic (caadr parent))))
729 (gnus-topic-goto-missing-topic topic)
730 (let* ((top (gnus-topic-find-topology topic))
734 (entries (gnus-topic-find-groups
735 (car type) (car gnus-group-list-mode)
736 (cdr gnus-group-list-mode)))
739 (incf unread (gnus-topic-unread (caar (pop children)))))
743 (gnus-topic-insert-topic-line
744 topic t t (car (gnus-topic-find-topology topic)) nil unread)))
746 (defun gnus-topic-goto-missing-topic (topic)
747 (if (gnus-topic-goto-topic topic)
750 (let* ((top (gnus-topic-find-topology
751 (gnus-topic-parent-topic topic)))
754 (gnus-topic-insert-topic-line
755 topic t t (car (gnus-topic-find-topology topic)) nil 0)
760 (not (gnus-topic-goto-topic (caaar tp))))
763 (gnus-topic-forward-topic 1)
764 (gnus-topic-goto-missing-topic (caadr top)))))
767 (defun gnus-topic-update-topic-line (topic-name &optional reads)
768 (let* ((top (gnus-topic-find-topology topic-name))
771 (entries (gnus-topic-find-groups
772 (car type) (car gnus-group-list-mode)
773 (cdr gnus-group-list-mode)))
774 (parent (gnus-topic-parent-topic topic-name))
778 (when (gnus-topic-goto-topic (car type))
781 (setq unread (- (gnus-group-topic-unread) reads))
783 (incf unread (gnus-topic-unread (caar (pop children)))))
787 (setq old-unread (gnus-group-topic-unread))
789 (gnus-topic-insert-topic-line
790 (car type) (gnus-topic-visible-p)
792 (gnus-group-topic-level) all-entries unread)
793 (gnus-delete-line)
795 (setq new-unread (gnus-group-topic-unread)))
798 (gnus-topic-update-topic-line
803 (defun gnus-topic-group-indentation ()
805 (* gnus-topic-indent-level
808 (gnus-topic-goto-topic (gnus-current-topic))
809 (gnus-group-topic-level))
815 (gnus-add-shutdown 'gnus-topic-close 'gnus)
817 (defun gnus-topic-close ()
818 (setq gnus-topic-active-topology nil
819 gnus-topic-active-alist nil
820 gnus-topic-killed-topics nil
821 gnus-topology-checked-p nil))
823 (defun gnus-topic-check-topology ()
826 (unless gnus-topic-alist
827 (gnus-topic-init-alist))
829 (setq gnus-topology-checked-p t)
832 (let ((topics (gnus-topic-list))
833 (alist gnus-topic-alist)
837 (nconc gnus-topic-topology
842 (gnus-topic-enter-dribble))
846 (unless (assoc (car topics) gnus-topic-alist)
847 (push (list (car topics)) gnus-topic-alist))
852 gnus-topic-alist)))
853 (entry (last (assoc (caar gnus-topic-topology) gnus-topic-alist)))
854 (newsrc (cdr gnus-newsrc-alist))
857 (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups)
861 (let ((alist gnus-topic-alist)
866 (gnus-gethash (cadr topic) gnus-newsrc-hashtb))
870 (defun gnus-topic-init-alist ()
872 (setq gnus-topic-topology
877 (setq gnus-topic-alist
879 (mapcar (lambda (info) (gnus-info-group info))
880 (cdr gnus-newsrc-alist)))
882 (gnus-topic-enter-dribble))
886 (defun gnus-topic-clean-alist ()
888 (let ((topic-alist gnus-topic-alist)
890 (unless gnus-killed-hashtb
891 (gnus-make-hashtable-from-killed))
896 (when (and (or (gnus-gethash group gnus-active-hashtb)
897 (gnus-info-method (gnus-get-info group)))
898 (not (gnus-gethash group gnus-killed-hashtb)))
901 (setq gnus-topic-alist (nreverse result))))
903 (defun gnus-topic-change-level (group level oldlevel &optional previous)
906 (set-buffer gnus-group-buffer)
908 (unless gnus-topic-inhibit-change-level
909 (gnus-group-goto-group (or (car (nth 2 previous)) group))
910 (when (and gnus-topic-mode
911 gnus-topic-alist
912 (not gnus-topic-inhibit-change-level))
914 (if (and (< oldlevel gnus-level-zombie)
915 (>= level gnus-level-zombie))
916 (let ((alist gnus-topic-alist))
917 (while (gnus-group-goto-group group)
918 (gnus-delete-line))
924 (when (and (< level gnus-level-zombie)
925 (>= oldlevel gnus-level-zombie))
926 (let* ((prev (gnus-group-group-name))
927 (gnus-topic-inhibit-change-level t)
928 (gnus-group-indentation
930 (* gnus-topic-indent-level
932 (gnus-topic-goto-topic (gnus-current-topic))
933 (gnus-group-topic-level))
943 (gnus-current-topic)
944 (caar gnus-topic-topology)))
945 gnus-topic-alist))
960 (gnus-topic-update-topic))))))))
962 (defun gnus-topic-goto-next-group (group props)
965 (if (not (memq 'gnus-topic props))
967 (gnus-topic-goto-topic (symbol-name (cadr (memq 'gnus-topic props)))))
968 (if (gnus-group-goto-group group)
971 (let* ((list (assoc (gnus-group-topic group) gnus-topic-alist))
975 (not (gnus-group-goto-group (car after))))
981 (not (gnus-group-goto-group (car after))))
987 (gnus-topic-goto-topic (car list))
993 (defun gnus-topic-grok-active (&optional force)
997 (not gnus-topic-active-alist))
1002 gnus-active-hashtb)
1005 (setq gnus-topic-active-topology (list (list "" 'visible)))
1006 (setq gnus-topic-active-alist nil)
1007 ;; Descend the top-level hierarchy.
1008 (gnus-topic-grok-active-1 gnus-topic-active-topology groups)
1009 ;; Set the top-level topic names to something nice.
1010 (setcar (car gnus-topic-active-topology) "Gnus active")
1011 (setcar (car gnus-topic-active-alist) "Gnus active"))))
1013 (defun gnus-topic-grok-active-1 (topology groups)
1030 (setq groups (gnus-topic-grok-active-1 ntopology groups))))
1037 (push (cons name (nreverse tgroups)) gnus-topic-active-alist)
1045 (defvar gnus-topic-mode-map nil)
1046 (defvar gnus-group-topic-map nil)
1048 (unless gnus-topic-mode-map
1049 (setq gnus-topic-mode-map (make-sparse-keymap))
1052 (gnus-define-keys gnus-topic-mode-map
1053 "=" gnus-topic-select-group
1054 "\r" gnus-topic-select-group
1055 " " gnus-topic-read-group
1056 "\C-c\C-x" gnus-topic-expire-articles
1057 "c" gnus-topic-catchup-articles
1058 "\C-k" gnus-topic-kill-group
1059 "\C-y" gnus-topic-yank-group
1060 "\M-g" gnus-topic-get-new-news-this-topic
1061 "AT" gnus-topic-list-active
1062 "Gp" gnus-topic-edit-parameters
1063 "#" gnus-topic-mark-topic
1064 "\M-#" gnus-topic-unmark-topic
1065 [tab] gnus-topic-indent
1066 [(meta tab)] gnus-topic-unindent
1067 "\C-i" gnus-topic-indent
1068 "\M-\C-i" gnus-topic-unindent
1069 gnus-mouse-2 gnus-mouse-pick-topic)
1072 (gnus-define-keys (gnus-group-topic-map "T" gnus-group-mode-map)
1073 "#" gnus-topic-mark-topic
1074 "\M-#" gnus-topic-unmark-topic
1075 "n" gnus-topic-create-topic
1076 "m" gnus-topic-move-group
1077 "D" gnus-topic-remove-group
1078 "c" gnus-topic-copy-group
1079 "h" gnus-topic-hide-topic
1080 "s" gnus-topic-show-topic
1081 "j" gnus-topic-jump-to-topic
1082 "M" gnus-topic-move-matching
1083 "C" gnus-topic-copy-matching
1084 "\M-p" gnus-topic-goto-previous-topic
1085 "\M-n" gnus-topic-goto-next-topic
1086 "\C-i" gnus-topic-indent
1087 [tab] gnus-topic-indent
1088 "r" gnus-topic-rename
1089 "\177" gnus-topic-delete
1090 [delete] gnus-topic-delete
1091 "H" gnus-topic-toggle-display-empty-topics)
1093 (gnus-define-keys (gnus-topic-sort-map "S" gnus-group-topic-map)
1094 "s" gnus-topic-sort-groups
1095 "a" gnus-topic-sort-groups-by-alphabet
1096 "u" gnus-topic-sort-groups-by-unread
1097 "l" gnus-topic-sort-groups-by-level
1098 "e" gnus-topic-sort-groups-by-server
1099 "v" gnus-topic-sort-groups-by-score
1100 "r" gnus-topic-sort-groups-by-rank
1101 "m" gnus-topic-sort-groups-by-method))
1103 (defun gnus-topic-make-menu-bar ()
1104 (unless (boundp 'gnus-topic-menu)
1106 gnus-topic-menu gnus-topic-mode-map ""
1108 ["Toggle topics" gnus-topic-mode t]
1110 ["Copy..." gnus-topic-copy-group t]
1111 ["Move..." gnus-topic-move-group t]
1112 ["Remove" gnus-topic-remove-group t]
1113 ["Copy matching..." gnus-topic-copy-matching t]
1114 ["Move matching..." gnus-topic-move-matching t])
1116 ["Goto..." gnus-topic-jump-to-topic t]
1117 ["Show" gnus-topic-show-topic t]
1118 ["Hide" gnus-topic-hide-topic t]
1119 ["Delete" gnus-topic-delete t]
1120 ["Rename..." gnus-topic-rename t]
1121 ["Create..." gnus-topic-create-topic t]
1122 ["Mark" gnus-topic-mark-topic t]
1123 ["Indent" gnus-topic-indent t]
1124 ["Sort" gnus-topic-sort-topics t]
1125 ["Previous topic" gnus-topic-goto-previous-topic t]
1126 ["Next topic" gnus-topic-goto-next-topic t]
1127 ["Toggle hide empty" gnus-topic-toggle-display-empty-topics t]
1128 ["Edit parameters" gnus-topic-edit-parameters t])
1129 ["List active" gnus-topic-list-active t]))))
1131 (defun gnus-topic-mode (&optional arg redisplay)
1134 (when (eq major-mode 'gnus-group-mode)
1135 (make-local-variable 'gnus-topic-mode)
1136 (setq gnus-topic-mode
1137 (if (null arg) (not gnus-topic-mode)
1140 (if (not gnus-topic-mode)
1141 (setq gnus-goto-missing-group-function nil)
1142 (when (gnus-visual-p 'topic-menu 'menu)
1143 (gnus-topic-make-menu-bar))
1144 (gnus-set-format 'topic t)
1145 (gnus-add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map)
1146 (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic)
1147 (set (make-local-variable 'gnus-group-prepare-function)
1148 'gnus-group-prepare-topics)
1149 (set (make-local-variable 'gnus-group-get-parameter-function)
1150 'gnus-group-topic-parameters)
1151 (set (make-local-variable 'gnus-group-goto-next-group-function)
1152 'gnus-topic-goto-next-group)
1153 (set (make-local-variable 'gnus-group-indentation-function)
1154 'gnus-topic-group-indentation)
1155 (set (make-local-variable 'gnus-group-update-group-function)
1156 'gnus-topic-update-topics-containing-group)
1157 (set (make-local-variable 'gnus-group-sort-alist-function)
1158 'gnus-group-sort-topic)
1159 (setq gnus-group-change-level-function 'gnus-topic-change-level)
1160 (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group)
1161 (gnus-make-local-hook 'gnus-check-bogus-groups-hook)
1162 (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist
1164 (setq gnus-topology-checked-p nil)
1166 (when gnus-newsrc-alist
1167 (gnus-topic-check-topology))
1168 (gnus-run-hooks 'gnus-topic-mode-hook))
1170 (unless gnus-topic-mode
1171 (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic)
1172 (setq gnus-group-change-level-function nil)
1173 (remove-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist)
1174 (setq gnus-group-prepare-function 'gnus-group-prepare-flat)
1175 (setq gnus-group-sort-alist-function 'gnus-group-sort-flat))
1177 (gnus-group-list-groups))))
1179 (defun gnus-topic-select-group (&optional all)
1188 (when (and (eobp) (not (gnus-group-group-name)))
1190 (if (gnus-group-topic-p)
1191 (let ((gnus-group-list-mode
1192 (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
1193 (gnus-topic-fold all)
1194 (gnus-dribble-touch))
1195 (gnus-group-select-group all)))
1197 (defun gnus-mouse-pick-topic (e)
1201 (gnus-topic-read-group nil))
1203 (defun gnus-topic-expire-articles (topic)
1205 (interactive (list (gnus-group-topic-name)))
1207 (call-interactively 'gnus-group-expire-articles)
1209 (gnus-message 5 "Expiring groups in %s..." topic)
1210 (let ((gnus-group-marked
1212 (gnus-topic-find-groups topic gnus-level-killed t
1214 (gnus-group-expire-articles nil))
1215 (gnus-message 5 "Expiring groups in %s...done" topic))))
1217 (defun gnus-topic-catchup-articles (topic)
1219 Also see `gnus-group-catchup'."
1220 (interactive (list (gnus-group-topic-name)))
1222 (call-interactively 'gnus-group-catchup-current)
1226 (gnus-topic-find-groups topic gnus-level-killed t
1229 (gnus-group-marked groups))
1230 (gnus-group-catchup-current)
1231 (mapcar 'gnus-topic-update-topics-containing-group groups)))))
1233 (defun gnus-topic-read-group (&optional all no-article group)
1243 (if (gnus-group-topic-p)
1244 (let ((gnus-group-list-mode
1245 (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
1246 (gnus-topic-fold all))
1247 (gnus-group-read-group all no-article group)))
1249 (defun gnus-topic-create-topic (topic parent &optional previous full-topic)
1255 (gnus-current-topic)))
1257 (when (gnus-topic-find-topology topic)
1260 (setq parent (caar gnus-topic-topology)))
1261 (let ((top (cdr (gnus-topic-find-topology parent)))
1272 (unless (assoc topic gnus-topic-alist)
1273 (push (list topic) gnus-topic-alist)))
1274 (gnus-topic-enter-dribble)
1275 (gnus-group-list-groups)
1276 (gnus-topic-goto-topic topic))
1282 ;; because gnus-group-marked only keeps one copy.
1284 (defun gnus-topic-move-group (n topic &optional copyp)
1289 (gnus-completing-read "Move to topic" gnus-topic-alist nil t
1290 'gnus-topic-history)))
1291 (let ((use-marked (and (not n) (not (gnus-region-active-p))
1292 gnus-group-marked t))
1293 (groups (gnus-group-process-prefix n))
1294 (topicl (assoc topic gnus-topic-alist))
1295 (start-topic (gnus-group-topic-name))
1296 (start-group (progn (forward-line 1) (gnus-group-group-name)))
1299 (gnus-topic-move start-topic topic)
1302 (gnus-group-remove-mark g use-marked)
1304 (setq entry (assoc (gnus-current-topic) gnus-topic-alist))
1306 (setcdr entry (gnus-delete-first g (cdr entry))))
1309 (gnus-topic-enter-dribble)
1311 (gnus-group-goto-group start-group)
1312 (gnus-topic-goto-topic start-topic))
1313 (gnus-group-list-groups))))
1315 (defun gnus-topic-remove-group (&optional n)
1318 (let ((use-marked (and (not n) (not (gnus-region-active-p))
1319 gnus-group-marked t))
1320 (groups (gnus-group-process-prefix n)))
1323 (gnus-group-remove-mark group use-marked)
1324 (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist))
1327 (gnus-delete-line)
1328 (gnus-delete-first group topicl))
1329 (gnus-topic-update-topic)))
1331 (gnus-topic-enter-dribble)
1332 (gnus-group-position-point)))
1334 (defun gnus-topic-copy-group (n topic)
1338 (completing-read "Copy to topic: " gnus-topic-alist nil t)))
1339 (gnus-topic-move-group n topic t))
1341 (defun gnus-topic-kill-group (&optional n discard)
1344 (if (gnus-group-topic-p)
1345 (let ((topic (gnus-group-topic-name)))
1347 (gnus-topic-find-topology topic)
1348 (assoc topic gnus-topic-alist))
1349 gnus-topic-killed-topics)
1350 (gnus-topic-remove-topic nil t)
1351 (gnus-topic-find-topology topic nil nil gnus-topic-topology)
1352 (gnus-topic-enter-dribble))
1353 (gnus-group-kill-group n discard)
1354 (if (not (gnus-group-topic-p))
1355 (gnus-topic-update-topic)
1358 (gnus-topic-update-topic)
1361 (defun gnus-topic-yank-group (&optional arg)
1364 (if gnus-topic-killed-topics
1366 (or (gnus-group-topic-name)
1367 (gnus-topic-next-topic (gnus-current-topic))))
1368 (data (pop gnus-topic-killed-topics))
1371 (push alist gnus-topic-alist)
1372 (gnus-topic-create-topic
1373 (caar item) (gnus-topic-parent-topic previous) previous
1375 (gnus-topic-enter-dribble)
1376 (gnus-topic-goto-topic (caar item)))
1377 (let* ((prev (gnus-group-group-name))
1378 (gnus-topic-inhibit-change-level t)
1379 (gnus-group-indentation
1381 (* gnus-topic-indent-level
1383 (gnus-topic-goto-topic (gnus-current-topic))
1384 (gnus-group-topic-level))
1389 (setq yanked (gnus-group-yank-group arg))
1394 (gnus-current-topic))
1395 gnus-topic-alist))
1407 (gnus-topic-update-topic)))
1409 (defun gnus-topic-hide-topic (&optional permanent)
1413 (when (gnus-current-topic)
1414 (gnus-topic-goto-topic (gnus-current-topic))
1418 (gnus-topic-find-topology (gnus-current-topic))))
1420 (gnus-topic-remove-topic nil nil)))
1422 (defun gnus-topic-show-topic (&optional permanent)
1426 (when (gnus-group-topic-p)
1428 (gnus-topic-remove-topic t nil)
1430 (gnus-topic-find-topology
1431 (completing-read "Show topic: " gnus-topic-alist nil t))))
1434 (gnus-group-list-groups)))))
1436 (defun gnus-topic-mark-topic (topic &optional unmark non-recursive)
1439 (interactive (list (gnus-group-topic-name)
1443 (call-interactively 'gnus-group-mark-group)
1445 (let ((groups (gnus-topic-find-groups topic gnus-level-killed t nil
1448 (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark)
1449 (gnus-info-group (nth 2 (pop groups)))))))))
1451 (defun gnus-topic-unmark-topic (topic &optional dummy non-recursive)
1454 (interactive (list (gnus-group-topic-name)
1458 (call-interactively 'gnus-group-unmark-group)
1459 (gnus-topic-mark-topic topic t non-recursive)))
1461 (defun gnus-topic-get-new-news-this-topic (&optional n)
1464 (if (not (gnus-group-topic-p))
1465 (gnus-group-get-new-news-this-group n)
1466 (let* ((topic (gnus-group-topic-name))
1467 (data (cadr (gnus-topic-find-topology topic))))
1469 (gnus-topic-mark-topic topic nil (and n t))
1470 (gnus-group-get-new-news-this-group))
1471 (gnus-topic-remove-topic (eq 'visible (cadr data))))))
1473 (defun gnus-topic-move-matching (regexp topic &optional copyp)
1479 (setq topic (completing-read "Move to topic: " gnus-topic-alist nil t))
1481 (gnus-group-mark-regexp regexp)
1482 (gnus-topic-move-group nil topic copyp))
1484 (defun gnus-topic-copy-matching (regexp topic &optional copyp)
1490 (setq topic (completing-read "Copy to topic: " gnus-topic-alist nil t))
1492 (gnus-topic-move-matching regexp topic t))
1494 (defun gnus-topic-delete (topic)
1496 (interactive (list (gnus-group-topic-name)))
1499 (let ((entry (assoc topic gnus-topic-alist))
1504 (when (gnus-topic-goto-topic topic)
1505 (gnus-delete-line))
1507 (setq gnus-topic-alist (delq entry gnus-topic-alist))
1509 (gnus-topic-find-topology topic nil nil 'delete)
1510 (gnus-dribble-touch)))
1512 (defun gnus-topic-rename (old-name new-name)
1515 (let ((topic (gnus-current-topic)))
1519 (when (gnus-topic-find-topology new-name)
1526 (let ((top (gnus-topic-find-topology old-name))
1527 (entry (assoc old-name gnus-topic-alist)))
1533 (gnus-dribble-touch)
1534 (gnus-group-list-groups)
1537 (defun gnus-topic-indent (&optional unindent)
1542 (gnus-topic-unindent)
1543 (let* ((topic (gnus-current-topic))
1544 (parent (gnus-topic-previous-topic topic))
1549 (gnus-topic-goto-topic topic)
1550 (gnus-topic-kill-group)
1551 (push (cdar gnus-topic-killed-topics) gnus-topic-alist)
1552 (gnus-topic-create-topic
1553 topic parent nil (cdar (car gnus-topic-killed-topics)))
1554 (pop gnus-topic-killed-topics)
1555 (or (gnus-topic-goto-topic topic)
1556 (gnus-topic-goto-topic parent))))))
1558 (defun gnus-topic-unindent ()
1561 (let* ((topic (gnus-current-topic))
1562 (parent (gnus-topic-parent-topic topic))
1563 (grandparent (gnus-topic-parent-topic parent)))
1567 (gnus-topic-goto-topic topic)
1568 (gnus-topic-kill-group)
1569 (push (cdar gnus-topic-killed-topics) gnus-topic-alist)
1570 (gnus-topic-create-topic
1571 topic grandparent (gnus-topic-next-topic parent)
1572 (cdar (car gnus-topic-killed-topics)))
1573 (pop gnus-topic-killed-topics)
1574 (gnus-topic-goto-topic topic))))
1576 (defun gnus-topic-list-active (&optional force)
1581 (gnus-get-killed-groups))
1582 (gnus-topic-grok-active force)
1583 (let ((gnus-topic-topology gnus-topic-active-topology)
1584 (gnus-topic-alist gnus-topic-active-alist)
1585 gnus-killed-list gnus-zombie-list)
1586 (gnus-group-list-groups gnus-level-killed nil 1)))
1588 (defun gnus-topic-toggle-display-empty-topics ()
1591 (setq gnus-topic-display-empty-topics
1592 (not gnus-topic-display-empty-topics))
1593 (gnus-group-list-groups)
1595 (if gnus-topic-display-empty-topics
1600 (defun gnus-topic-edit-parameters (group)
1603 (interactive (list (gnus-group-group-name)))
1605 (gnus-group-edit-group-parameters group)
1606 (if (not (gnus-group-topic-p))
1608 (let ((topic (gnus-group-topic-name)))
1609 (gnus-edit-form
1610 (gnus-topic-parameters topic)
1614 (gnus-topic-set-parameters ,topic form)))))))
1616 (defun gnus-group-sort-topic (func reverse)
1618 (let ((alist gnus-topic-alist))
1624 (gnus-topic-sort-topic (pop alist) func reverse))))
1626 (defun gnus-topic-sort-topic (topic func reverse)
1634 (lambda (info) (gnus-info-group info))
1637 (lambda (group) (gnus-get-info group))
1644 (defun gnus-topic-sort-groups (func &optional reverse)
1647 (interactive (list gnus-group-sort-function current-prefix-arg))
1648 (let ((topic (assoc (gnus-current-topic) gnus-topic-alist)))
1649 (gnus-topic-sort-topic
1650 topic (gnus-make-sort-function func) reverse)
1651 (gnus-group-list-groups)))
1653 (defun gnus-topic-sort-groups-by-alphabet (&optional reverse)
1657 (gnus-topic-sort-groups 'gnus-group-sort-by-alphabet reverse))
1659 (defun gnus-topic-sort-groups-by-unread (&optional reverse)
1663 (gnus-topic-sort-groups 'gnus-group-sort-by-unread reverse))
1665 (defun gnus-topic-sort-groups-by-level (&optional reverse)
1666 "Sort the current topic by group level.
1669 (gnus-topic-sort-groups 'gnus-group-sort-by-level reverse))
1671 (defun gnus-topic-sort-groups-by-score (&optional reverse)
1675 (gnus-topic-sort-groups 'gnus-group-sort-by-score reverse))
1677 (defun gnus-topic-sort-groups-by-rank (&optional reverse)
1681 (gnus-topic-sort-groups 'gnus-group-sort-by-rank reverse))
1683 (defun gnus-topic-sort-groups-by-method (&optional reverse)
1687 (gnus-topic-sort-groups 'gnus-group-sort-by-method reverse))
1689 (defun gnus-topic-sort-groups-by-server (&optional reverse)
1693 (gnus-topic-sort-groups 'gnus-group-sort-by-server reverse))
1695 (defun gnus-topic-sort-topics-1 (top reverse)
1698 (mapcar (gnus-byte-compile
1700 (gnus-topic-sort-topics-1 top ,reverse)))
1707 (defun gnus-topic-sort-topics (&optional topic reverse)
1711 (list (completing-read "Sort topics in : " gnus-topic-alist nil t
1712 (gnus-current-topic))
1714 (let ((topic-topology (or (and topic (cdr (gnus-topic-find-topology topic)))
1715 gnus-topic-topology)))
1716 (gnus-topic-sort-topics-1 topic-topology reverse)
1717 (gnus-topic-enter-dribble)
1718 (gnus-group-list-groups)
1719 (gnus-topic-goto-topic topic)))
1721 (defun gnus-topic-move (current to)
1725 (gnus-group-topic-name)
1726 (completing-read "Move to topic: " gnus-topic-alist nil t)))
1729 (let ((current-top (cdr (gnus-topic-find-topology current)))
1730 (to-top (cdr (gnus-topic-find-topology to))))
1735 (if (gnus-topic-find-topology to current-top 0);; Don't care the level
1736 (error "Can't move `%s' to its sub-level" current))
1737 (gnus-topic-find-topology current nil nil 'delete)
1741 (gnus-topic-enter-dribble)
1742 (gnus-group-list-groups)
1743 (gnus-topic-goto-topic current)))
1745 (defun gnus-subscribe-topics (newsgroup)
1747 (let (match gnus-group-change-level-function)
1748 (dolist (topic (gnus-topic-list))
1750 (gnus-topic-parameters topic))))
1753 (gnus-subscribe-alphabetically newsgroup)
1755 (nconc (assoc topic gnus-topic-alist) (list newsgroup))
1756 ;; if this topic specifies a default level, use it
1757 (let ((subscribe-level (cdr (assq 'subscribe-level
1758 (gnus-topic-parameters topic)))))
1759 (when subscribe-level
1760 (gnus-group-change-level newsgroup subscribe-level
1761 gnus-level-default-subscribed)))
1765 (provide 'gnus-topic)
1768 ;;; gnus-topic.el ends here