X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-topic.el;h=88fe35d8b0c230e10c09e8d68291fda0e7169caf;hb=d6b44b3c5ff2acbf182fc1223a610dbf9af98ba4;hp=57452c70dcc2831333d703c5e1ae2503be190823;hpb=27ec3f18a6e3fd44a32ac11e56dec68eed7a47dc;p=gnus diff --git a/lisp/gnus-topic.el b/lisp/gnus-topic.el index 57452c70d..88fe35d8b 100644 --- a/lisp/gnus-topic.el +++ b/lisp/gnus-topic.el @@ -1,5 +1,6 @@ ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers -;; Copyright (C) 1995,96,97,98,99 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 +;; Free Software Foundation, Inc. ;; Author: Ilja Weis ;; Lars Magne Ingebrigtsen @@ -222,7 +223,7 @@ If TOPIC, start with that topic." (> unread 0)) (and gnus-list-groups-with-ticked-articles (cdr (assq 'tick (gnus-info-marks info)))) - ; Has right readedness. + ;; Has right readedness. ;; Check for permanent visibility. (and gnus-permanently-visible-groups (string-match gnus-permanently-visible-groups group)) @@ -504,7 +505,7 @@ articles in the topic and its subtopics." (let ((data (cadr (gnus-topic-find-topology topic)))) (setcdr data (list (if insert 'visible 'invisible) - (if hide 'hide nil) + hide (cadddr data)))) (if total-remove (setq gnus-topic-alist @@ -543,15 +544,16 @@ articles in the topic and its subtopics." (gnus-topic-update-unreads name unread) (beginning-of-line) ;; Insert the text. - (gnus-add-text-properties - (point) - (prog1 (1+ (point)) - (eval gnus-topic-line-format-spec)) - (list 'gnus-topic (intern name) - 'gnus-topic-level level - 'gnus-topic-unread unread - 'gnus-active active-topic - 'gnus-topic-visible visiblep)))) + (if shownp + (gnus-add-text-properties + (point) + (prog1 (1+ (point)) + (eval gnus-topic-line-format-spec)) + (list 'gnus-topic (intern name) + 'gnus-topic-level level + 'gnus-topic-unread unread + 'gnus-active active-topic + 'gnus-topic-visible visiblep))))) (defun gnus-topic-update-unreads (topic unreads) (setq gnus-topic-unreads (delq (assoc topic gnus-topic-unreads) @@ -594,7 +596,8 @@ articles in the topic and its subtopics." (let* ((topic (gnus-group-topic group)) (groups (cdr (assoc topic gnus-topic-alist))) (g (cdr (member group groups))) - (unfound t)) + (unfound t) + entry) ;; Try to jump to a visible group. (while (and g (not (gnus-group-goto-group (car g) t))) (pop g)) @@ -608,8 +611,20 @@ articles in the topic and its subtopics." (when (and unfound topic (not (gnus-topic-goto-missing-topic topic))) - (gnus-topic-insert-topic-line - topic t t (car (gnus-topic-find-topology topic)) nil 0))))) + (let* ((top (gnus-topic-find-topology topic)) + (children (cddr top)) + (type (cadr top)) + (unread 0) + (entries (gnus-topic-find-groups + (car type) (car gnus-group-list-mode) + (cdr gnus-group-list-mode)))) + (while children + (incf unread (gnus-topic-unread (caar (pop children))))) + (while (setq entry (pop entries)) + (when (numberp (car entry)) + (incf unread (car entry)))) + (gnus-topic-insert-topic-line + topic t t (car (gnus-topic-find-topology topic)) nil unread)))))) (defun gnus-topic-goto-missing-topic (topic) (if (gnus-topic-goto-topic topic) @@ -999,7 +1014,7 @@ articles in the topic and its subtopics." (if (null arg) (not gnus-topic-mode) (> (prefix-numeric-value arg) 0))) ;; Infest Gnus with topics. - (if (not gnus-topic-mode) + (if (not gnus-topic-mode) (setq gnus-goto-missing-group-function nil) (when (gnus-visual-p 'topic-menu 'menu) (gnus-topic-make-menu-bar)) @@ -1066,9 +1081,9 @@ If performed over a topic line, toggle folding the topic." (save-excursion (gnus-message 5 "Expiring groups in %s..." topic) (let ((gnus-group-marked - (mapcar (lambda (entry) (car (nth 2 entry))) - (gnus-topic-find-groups topic gnus-level-killed t)))) - (gnus-group-expire-articles nil)) + (mapcar (lambda (entry) (car (nth 2 entry))) + (gnus-topic-find-groups topic gnus-level-killed t)))) + (gnus-group-expire-articles nil)) (gnus-message 5 "Expiring groups in %s...done" topic)))) (defun gnus-topic-read-group (&optional all no-article group) @@ -1116,13 +1131,21 @@ When used interactively, PARENT will be the topic under point." (gnus-group-list-groups) (gnus-topic-goto-topic topic)) +;; FIXME: +;; 1. When the marked groups are overlapped with the process +;; region, the behavior of move or remove is not right. +;; 2. Can't process on several marked groups with a same name, +;; because gnus-group-marked only keeps one copy. + (defun gnus-topic-move-group (n topic &optional copyp) "Move the next N groups to TOPIC. If COPYP, copy the groups instead." (interactive (list current-prefix-arg (completing-read "Move to topic: " gnus-topic-alist nil t))) - (let ((groups (gnus-group-process-prefix n)) + (let ((use-marked (and (not n) (not (gnus-region-active-p)) + gnus-group-marked t)) + (groups (gnus-group-process-prefix n)) (topicl (assoc topic gnus-topic-alist)) (start-topic (gnus-group-topic-name)) (start-group (progn (forward-line 1) (gnus-group-group-name))) @@ -1131,7 +1154,7 @@ If COPYP, copy the groups instead." (gnus-topic-move start-topic topic) (mapcar (lambda (g) - (gnus-group-remove-mark g) + (gnus-group-remove-mark g use-marked) (when (and (setq entry (assoc (gnus-current-topic) gnus-topic-alist)) (not copyp)) @@ -1144,18 +1167,24 @@ If COPYP, copy the groups instead." (gnus-topic-goto-topic start-topic)) (gnus-group-list-groups)))) -(defun gnus-topic-remove-group (&optional arg) +(defun gnus-topic-remove-group (&optional n) "Remove the current group from the topic." (interactive "P") - (gnus-group-iterate arg - (lambda (group) - (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist)) - (buffer-read-only nil)) - (when (and topicl group) - (gnus-delete-line) - (gnus-delete-first group topicl)) - (gnus-topic-update-topic) - (gnus-group-position-point))))) + (let ((use-marked (and (not n) (not (gnus-region-active-p)) + gnus-group-marked t)) + (groups (gnus-group-process-prefix n))) + (mapcar + (lambda (group) + (gnus-group-remove-mark group use-marked) + (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist)) + (buffer-read-only nil)) + (when (and topicl group) + (gnus-delete-line) + (gnus-delete-first group topicl)) + (gnus-topic-update-topic))) + groups) + (gnus-topic-enter-dribble) + (gnus-group-position-point))) (defun gnus-topic-copy-group (n topic) "Copy the current group to a topic." @@ -1232,13 +1261,13 @@ If COPYP, copy the groups instead." (interactive) (when (gnus-current-topic) (gnus-topic-goto-topic (gnus-current-topic)) - (gnus-topic-remove-topic nil nil 'hidden))) + (gnus-topic-remove-topic nil nil))) (defun gnus-topic-show-topic () "Show the hidden topic." (interactive) (when (gnus-group-topic-p) - (gnus-topic-remove-topic t nil 'shown))) + (gnus-topic-remove-topic t nil))) (defun gnus-topic-mark-topic (topic &optional unmark) "Mark all groups in the topic with the process mark." @@ -1521,7 +1550,7 @@ If REVERSE, reverse the sorting order." (error "Can't find topic `%s'" current)) (unless to-top (error "Can't find topic `%s'" to)) - (if (gnus-topic-find-topology to current-top 0) ;; Don't care the level + (if (gnus-topic-find-topology to current-top 0);; Don't care the level (error "Can't move `%s' to its sub-level" current)) (gnus-topic-find-topology current nil nil 'delete) (while (cdr to-top) @@ -1531,6 +1560,19 @@ If REVERSE, reverse the sorting order." (gnus-group-list-groups) (gnus-topic-goto-topic current))) +(defun gnus-subscribe-topics (newsgroup) + (catch 'end + (let (match gnus-group-change-level-function) + (dolist (topic (gnus-topic-list)) + (when (and (setq match (cdr (assq 'subscribe + (gnus-topic-parameters topic)))) + (string-match match newsgroup)) + ;; Just subscribe the group. + (gnus-subscribe-alphabetically newsgroup) + ;; Add the group to the topic. + (nconc (assoc topic gnus-topic-alist) (list newsgroup)) + (throw 'end t)))))) + (provide 'gnus-topic) ;;; gnus-topic.el ends here