X-Git-Url: https://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-topic.el;h=efa543f68d68fb8acb187cbc317bdd96f2b0f4b9;hp=eea18ef072166b431c225679b6b5120f7e95fb0c;hb=279d0ae06b909d067ce7f4a756a7872087adf667;hpb=f1b536cc94586375ec2bd5fb7395b2f053c4ce71 diff --git a/lisp/gnus-topic.el b/lisp/gnus-topic.el index eea18ef07..efa543f68 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) @@ -149,8 +148,7 @@ See Info node `(gnus)Formatting Variables'." (defun gnus-group-parent-topic (group) "Return the topic GROUP is member of by looking at the group buffer." - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (if (gnus-group-goto-group group) (gnus-current-topic) (gnus-group-topic group)))) @@ -163,12 +161,12 @@ See Info node `(gnus)Formatting Variables'." (defun gnus-topic-jump-to-topic (topic) "Go to TOPIC." (interactive - (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)) + (list (gnus-completing-read "Go to topic" (gnus-topic-list) 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 +193,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 +205,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 +239,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 +345,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 +372,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 +441,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 +470,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 +590,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 +732,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 +768,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 +856,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 +870,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 +900,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))) @@ -894,8 +909,7 @@ articles in the topic and its subtopics." (defun gnus-topic-change-level (group level oldlevel &optional previous) "Run when changing levels to enter/remove groups from topics." - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (let ((buffer-read-only nil)) (unless gnus-topic-inhibit-change-level (gnus-group-goto-group (or (car (nth 2 previous)) group)) @@ -927,8 +941,8 @@ articles in the topic and its subtopics." ? )) (yanked (list group)) alist talist end) - ;; Then we enter the yanked groups into the topics they belong - ;; to. + ;; Then we enter the yanked groups into the topics + ;; they belong to. (when (setq alist (assoc (save-excursion (forward-line -1) (or @@ -1122,6 +1136,7 @@ articles in the topic and its subtopics." (defun gnus-topic-mode (&optional arg redisplay) "Minor mode for topicsifying Gnus group buffers." + ;; FIXME: Use define-minor-mode. (interactive (list current-prefix-arg t)) (when (eq major-mode 'gnus-group-mode) (make-local-variable 'gnus-topic-mode) @@ -1134,10 +1149,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) @@ -1153,7 +1165,7 @@ articles in the topic and its subtopics." 'gnus-group-sort-topic) (setq gnus-group-change-level-function 'gnus-topic-change-level) (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group) - (make-local-hook 'gnus-check-bogus-groups-hook) + (gnus-make-local-hook 'gnus-check-bogus-groups-hook) (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist nil 'local) (setq gnus-topology-checked-p nil) @@ -1176,10 +1188,15 @@ 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") + (when (and (eobp) (not (gnus-group-group-name))) + (forward-line -1)) (if (gnus-group-topic-p) (let ((gnus-group-list-mode (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode))) @@ -1226,10 +1243,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") @@ -1279,8 +1301,8 @@ When used interactively, PARENT will be the topic under point." If COPYP, copy the groups instead." (interactive (list current-prefix-arg - (gnus-completing-read "Move to topic" gnus-topic-alist nil t - 'gnus-topic-history))) + (gnus-completing-read "Move to topic" (mapcar 'car gnus-topic-alist) t + nil 'gnus-topic-history))) (let ((use-marked (and (not n) (not (gnus-region-active-p)) gnus-group-marked t)) (groups (gnus-group-process-prefix n)) @@ -1290,15 +1312,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) @@ -1311,7 +1331,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)) @@ -1328,7 +1348,8 @@ If COPYP, copy the groups instead." "Copy the current group to a topic." (interactive (list current-prefix-arg - (completing-read "Copy to topic: " gnus-topic-alist nil t))) + (gnus-completing-read + "Copy to topic" (mapcar 'car gnus-topic-alist) t))) (gnus-topic-move-group n topic t)) (defun gnus-topic-kill-group (&optional n discard) @@ -1421,7 +1442,8 @@ If PERMANENT, make it stay shown in subsequent sessions as well." (gnus-topic-remove-topic t nil) (let ((topic (gnus-topic-find-topology - (completing-read "Show topic: " gnus-topic-alist nil t)))) + (gnus-completing-read "Show topic" + (mapcar 'car gnus-topic-alist) t)))) (setcar (cddr (cadr topic)) nil) (setcar (cdr (cadr topic)) 'visible) (gnus-group-list-groups))))) @@ -1469,7 +1491,8 @@ If NON-RECURSIVE (which is the prefix) is t, don't unmark its subtopics." (let (topic) (nreverse (list - (setq topic (completing-read "Move to topic: " gnus-topic-alist nil t)) + (setq topic (gnus-completing-read "Move to topic" + (mapcar 'car gnus-topic-alist) t)) (read-string (format "Move to %s (regexp): " topic)))))) (gnus-group-mark-regexp regexp) (gnus-topic-move-group nil topic copyp)) @@ -1480,7 +1503,8 @@ If NON-RECURSIVE (which is the prefix) is t, don't unmark its subtopics." (let (topic) (nreverse (list - (setq topic (completing-read "Copy to topic: " gnus-topic-alist nil t)) + (setq topic (gnus-completing-read "Copy to topic" + (mapcar 'car gnus-topic-alist) t)) (read-string (format "Copy to %s (regexp): " topic)))))) (gnus-topic-move-matching regexp topic t)) @@ -1701,8 +1725,9 @@ If REVERSE, sort in reverse order." "Sort topics in TOPIC alphabetically by topic name. If REVERSE, reverse the sorting order." (interactive - (list (completing-read "Sort topics in : " gnus-topic-alist nil t - (gnus-current-topic)) + (list (gnus-completing-read "Sort topics in" + (mapcar 'car gnus-topic-alist) t + (gnus-current-topic)) current-prefix-arg)) (let ((topic-topology (or (and topic (cdr (gnus-topic-find-topology topic))) gnus-topic-topology))) @@ -1716,7 +1741,7 @@ If REVERSE, reverse the sorting order." (interactive (list (gnus-group-topic-name) - (completing-read "Move to topic: " gnus-topic-alist nil t))) + (gnus-completing-read "Move to topic" (mapcar 'car gnus-topic-alist) t))) (unless (and current to) (error "Can't find topic")) (let ((current-top (cdr (gnus-topic-find-topology current))) @@ -1728,9 +1753,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)))