X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-topic.el;h=9d259881b091230bb0f30ed7a6c467c1bef50e6b;hb=9a8731d6dea8021a10dec1b42f382609336a9aa9;hp=c1db079481360972d7b365bf7a1022a6d436d6ad;hpb=19de10b70d605a6daec50259c0f3fe286418a402;p=gnus diff --git a/lisp/gnus-topic.el b/lisp/gnus-topic.el index c1db07948..9d259881b 100644 --- a/lisp/gnus-topic.el +++ b/lisp/gnus-topic.el @@ -1,6 +1,7 @@ ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 -;; Free Software Foundation, Inc. + +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, +;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Ilja Weis ;; Lars Magne Ingebrigtsen @@ -8,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -19,9 +20,7 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -104,16 +103,16 @@ See Info node `(gnus)Formatting Variables'." (defun gnus-group-topic-name () "The name of the topic on the current line." - (let ((topic (get-text-property (gnus-point-at-bol) 'gnus-topic))) + (let ((topic (get-text-property (point-at-bol) 'gnus-topic))) (and topic (symbol-name topic)))) (defun gnus-group-topic-level () "The level of the topic on the current line." - (get-text-property (gnus-point-at-bol) 'gnus-topic-level)) + (get-text-property (point-at-bol) 'gnus-topic-level)) (defun gnus-group-topic-unread () "The number of unread articles in topic on the current line." - (get-text-property (gnus-point-at-bol) 'gnus-topic-unread)) + (get-text-property (point-at-bol) 'gnus-topic-unread)) (defun gnus-topic-unread (topic) "Return the number of unread articles in TOPIC." @@ -126,7 +125,7 @@ See Info node `(gnus)Formatting Variables'." (defun gnus-topic-visible-p () "Return non-nil if the current topic is visible." - (get-text-property (gnus-point-at-bol) 'gnus-topic-visible)) + (get-text-property (point-at-bol) 'gnus-topic-visible)) (defun gnus-topic-articles-in-topic (entries) (let ((total 0) @@ -166,9 +165,11 @@ See Info node `(gnus)Formatting Variables'." (list (completing-read "Go to topic: " (mapcar 'list (gnus-topic-list)) nil t))) - (dolist (topic (gnus-current-topics topic)) - (gnus-topic-goto-topic topic) - (gnus-topic-fold t)) + (let ((buffer-read-only nil)) + (dolist (topic (gnus-current-topics topic)) + (unless (gnus-topic-goto-topic topic) + (gnus-topic-goto-missing-topic topic) + (gnus-topic-display-missing-topic topic)))) (gnus-topic-goto-topic topic)) (defun gnus-current-topic () @@ -195,9 +196,7 @@ If TOPIC, start with that topic." (defun gnus-group-active-topic-p () "Say whether the current topic comes from the active topics." - (save-excursion - (beginning-of-line) - (get-text-property (point) 'gnus-active))) + (get-text-property (point-at-bol) 'gnus-active)) (defun gnus-topic-find-groups (topic &optional level all lowest recursive) "Return entries for all visible groups in TOPIC. @@ -209,7 +208,7 @@ If RECURSIVE is t, return groups in its subtopics too." ;; We go through the newsrc to look for matches. (while groups (when (setq group (pop groups)) - (setq entry (gnus-gethash group gnus-newsrc-hashtb) + (setq entry (gnus-group-entry group) info (nth 2 entry) params (gnus-info-params info) active (gnus-active group) @@ -243,13 +242,12 @@ If RECURSIVE is t, return groups in its subtopics too." (when recursive (if (eq recursive t) (setq recursive (cdr (gnus-topic-find-topology topic)))) - (mapcar (lambda (topic-topology) - (setq visible-groups - (nconc visible-groups - (gnus-topic-find-groups - (caar topic-topology) - level all lowest topic-topology)))) - (cdr recursive))) + (dolist (topic-topology (cdr recursive)) + (setq visible-groups + (nconc visible-groups + (gnus-topic-find-groups + (caar topic-topology) + level all lowest topic-topology))))) visible-groups)) (defun gnus-topic-goto-previous-topic (n) @@ -350,7 +348,7 @@ If RECURSIVE is t, return groups in its subtopics too." (setq topology gnus-topic-topology gnus-tmp-topics nil)) (push (caar topology) gnus-tmp-topics) - (mapcar 'gnus-topic-list (cdr topology)) + (mapc 'gnus-topic-list (cdr topology)) gnus-tmp-topics) ;;; Topic parameter jazz @@ -377,39 +375,50 @@ If RECURSIVE is t, return groups in its subtopics too." (format "(gnus-topic-set-parameters %S '%S)" topic parameters)))) (defun gnus-group-topic-parameters (group) - "Compute the group parameters for GROUP taking into account inheritance from topics." + "Compute the group parameters for GROUP in topic mode. +Possibly inherit parameters from topics above GROUP." (let ((params-list (copy-sequence (gnus-group-get-parameter group)))) (save-excursion - (nconc params-list - (gnus-topic-hierarchical-parameters - ;; First we try to go to the group within the group - ;; buffer and find the topic for the group that way. - ;; This hopefully copes well with groups that are in - ;; more than one topic. Failing that (i.e. when the - ;; group isn't visible in the group buffer) we find a - ;; topic for the group via gnus-group-topic. - (or (and (gnus-group-goto-group group) - (gnus-current-topic)) - (gnus-group-topic group))))))) - -(defun gnus-topic-hierarchical-parameters (topic) - "Return a topic list computed for TOPIC." - (let ((topics (gnus-current-topics topic)) - params-list param out params) - (while topics - (push (gnus-topic-parameters (pop topics)) params-list)) - ;; We probably have lots of nil elements here, so - ;; we remove them. Probably faster than doing this "properly". - (setq params-list (delq nil params-list)) + (gnus-topic-hierarchical-parameters + ;; First we try to go to the group within the group buffer and find the + ;; topic for the group that way. This hopefully copes well with groups + ;; that are in more than one topic. Failing that (i.e. when the group + ;; isn't visible in the group buffer) we find a topic for the group via + ;; gnus-group-topic. + (or (and (gnus-group-goto-group group) + (gnus-current-topic)) + (gnus-group-topic group)) + params-list)))) + +(defun gnus-topic-hierarchical-parameters (topic &optional group-params-list) + "Compute the topic parameters for TOPIC. +Possibly inherit parameters from topics above TOPIC. +If optional argument GROUP-PARAMS-LIST is non-nil, use it as the basis for +inheritance." + (let ((params-list + ;; We probably have lots of nil elements here, so we remove them. + ;; Probably faster than doing this "properly". + (delq nil (cons group-params-list + (mapcar 'gnus-topic-parameters + (gnus-current-topics topic))))) + param out params) ;; Now we have all the parameters, so we go through them ;; and do inheritance in the obvious way. - (while (setq params (pop params-list)) - (while (setq param (pop params)) - (when (atom param) - (setq param (cons param t))) - ;; Override any old versions of this param. - (gnus-pull (car param) out) - (push param out))) + (let (posting-style) + (while (setq params (pop params-list)) + (while (setq param (pop params)) + (when (atom param) + (setq param (cons param t))) + (cond ((eq (car param) 'posting-style) + (let ((param (cdr param)) + elt) + (while (setq elt (pop param)) + (unless (assoc (car elt) posting-style) + (push elt posting-style))))) + (t + (unless (assq (car param) out) + (push param out)))))) + (and posting-style (push (cons 'posting-style posting-style) out))) ;; Return the resulting parameter list. out)) @@ -435,6 +444,8 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." (and gnus-group-listed-groups (copy-sequence gnus-group-listed-groups)))) + (gnus-update-format-specifications nil 'topic) + (when (or (not gnus-topic-alist) (not gnus-topology-checked-p)) (gnus-topic-check-topology)) @@ -462,7 +473,7 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." (gnus-make-hashtable-from-killed)) (gnus-group-prepare-flat-list-dead (gnus-remove-if (lambda (group) - (or (gnus-gethash group gnus-newsrc-hashtb) + (or (gnus-group-entry group) (gnus-gethash group gnus-killed-hashtb))) not-in-list) gnus-level-killed ?K regexp))) @@ -582,6 +593,11 @@ articles in the topic and its subtopics." (not (eq (nth 2 type) 'hidden)) level all-entries unread)) (gnus-topic-update-unreads (car type) unread) + (when gnus-group-update-tool-bar + (gnus-put-text-property beg end 'point-entered + 'gnus-tool-bar-update) + (gnus-put-text-property beg end 'point-left + 'gnus-tool-bar-update)) (goto-char end) unread)) @@ -719,6 +735,9 @@ articles in the topic and its subtopics." (not (gnus-topic-goto-missing-topic (caadr parent)))) (gnus-topic-display-missing-topic (caadr parent)))) (gnus-topic-goto-missing-topic topic) + ;; Skip past all groups in the topic we're in. + (while (gnus-group-group-name) + (forward-line 1)) (let* ((top (gnus-topic-find-topology topic)) (children (cddr top)) (type (cadr top)) @@ -752,7 +771,7 @@ articles in the topic and its subtopics." (not (gnus-topic-goto-topic (caaar tp)))) (pop tp)) (if tp - (forward-line 1) + (gnus-topic-forward-topic 1) (gnus-topic-goto-missing-topic (caadr top))))) nil)) @@ -840,8 +859,7 @@ articles in the topic and its subtopics." (pop topics))) ;; Go through all living groups and make sure that ;; they belong to some topic. - (let* ((tgroups (apply 'append (mapcar (lambda (entry) (cdr entry)) - gnus-topic-alist))) + (let* ((tgroups (apply 'append (mapcar 'cdr gnus-topic-alist))) (entry (last (assoc (caar gnus-topic-topology) gnus-topic-alist))) (newsrc (cdr gnus-newsrc-alist)) group) @@ -855,7 +873,7 @@ articles in the topic and its subtopics." (while (setq topic (pop alist)) (while (cdr topic) (if (and (cadr topic) - (gnus-gethash (cadr topic) gnus-newsrc-hashtb)) + (gnus-group-entry (cadr topic))) (setq topic (cdr topic)) (setcdr topic (cddr topic))))))) @@ -885,7 +903,7 @@ articles in the topic and its subtopics." (let ((topic-name (pop topic)) group filtered-topic) (while (setq group (pop topic)) - (when (and (or (gnus-gethash group gnus-active-hashtb) + (when (and (or (gnus-active group) (gnus-info-method (gnus-get-info group))) (not (gnus-gethash group gnus-killed-hashtb))) (push group filtered-topic))) @@ -1134,10 +1152,7 @@ articles in the topic and its subtopics." (when (gnus-visual-p 'topic-menu 'menu) (gnus-topic-make-menu-bar)) (gnus-set-format 'topic t) - (gnus-add-minor-mode 'gnus-topic-mode " Topic" - gnus-topic-mode-map nil (lambda (&rest junk) - (interactive) - (gnus-topic-mode nil t))) + (add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map) (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic) (set (make-local-variable 'gnus-group-prepare-function) 'gnus-group-prepare-topics) @@ -1176,7 +1191,10 @@ articles in the topic and its subtopics." No article is selected automatically. If the group is opened, just switch the summary buffer. If ALL is non-nil, already read articles become readable. -If ALL is a number, fetch this number of articles. + +If ALL is a positive number, fetch this number of the latest +articles in the group. If ALL is a negative number, fetch this +number of the earliest articles in the group. If performed over a topic line, toggle folding the topic." (interactive "P") @@ -1228,10 +1246,15 @@ Also see `gnus-group-catchup'." (defun gnus-topic-read-group (&optional all no-article group) "Read news in this newsgroup. If the prefix argument ALL is non-nil, already read articles become -readable. IF ALL is a number, fetch this number of articles. If the -optional argument NO-ARTICLE is non-nil, no article will be -auto-selected upon group entry. If GROUP is non-nil, fetch that -group. +readable. + +If ALL is a positive number, fetch this number of the latest +articles in the group. If ALL is a negative number, fetch this +number of the earliest articles in the group. + +If the optional argument NO-ARTICLE is non-nil, no article will +be auto-selected upon group entry. If GROUP is non-nil, fetch +that group. If performed over a topic line, toggle folding the topic." (interactive "P") @@ -1292,15 +1315,13 @@ If COPYP, copy the groups instead." entry) (if (and (not groups) (not copyp) start-topic) (gnus-topic-move start-topic topic) - (mapcar - (lambda (g) - (gnus-group-remove-mark g use-marked) - (when (and - (setq entry (assoc (gnus-current-topic) gnus-topic-alist)) - (not copyp)) - (setcdr entry (gnus-delete-first g (cdr entry)))) - (nconc topicl (list g))) - groups) + (dolist (g groups) + (gnus-group-remove-mark g use-marked) + (when (and + (setq entry (assoc (gnus-current-topic) gnus-topic-alist)) + (not copyp)) + (setcdr entry (gnus-delete-first g (cdr entry)))) + (nconc topicl (list g))) (gnus-topic-enter-dribble) (if start-group (gnus-group-goto-group start-group) @@ -1313,7 +1334,7 @@ If COPYP, copy the groups instead." (let ((use-marked (and (not n) (not (gnus-region-active-p)) gnus-group-marked t)) (groups (gnus-group-process-prefix n))) - (mapcar + (mapc (lambda (group) (gnus-group-remove-mark group use-marked) (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist)) @@ -1730,9 +1751,7 @@ If REVERSE, reverse the sorting order." (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) - (setq to-top (cdr to-top))) - (setcdr to-top (list current-top)) + (setcdr (last to-top) (list current-top)) (gnus-topic-enter-dribble) (gnus-group-list-groups) (gnus-topic-goto-topic current))) @@ -1759,4 +1778,5 @@ If REVERSE, reverse the sorting order." (provide 'gnus-topic) +;; arch-tag: bf176856-f30c-40f0-ae77-e41529a1134c ;;; gnus-topic.el ends here