Fix previous commit.

[gnus] / lisp / gnus-topic.el

diff --git a/lisp/gnus-topic.el b/lisp/gnus-topic.el
index 719e466..b600fac 100644 (file)
--- a/lisp/gnus-topic.el
+++ b/lisp/gnus-topic.el
@@ -1,16 +1,18 @@
 ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers
 ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers

-;; Copyright (C) 1995,96,97 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 <kult@uni-paderborn.de>
 
 ;; Author: Ilja Weis <kult@uni-paderborn.de>

-;;     Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;;     Lars Magne Ingebrigtsen <larsi@gnus.org>

 ;; Keywords: news
 
 ;; This file is part of GNU Emacs.
 
 ;; Keywords: news
 
 ;; 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
 ;; 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
 
 ;; GNU Emacs is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of


@@ -18,9 +20,7 @@
 ;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License
 ;; 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 <http://www.gnu.org/licenses/>.

 
 ;;; Commentary:
 
 
 ;;; Commentary:
 


@@ -31,6 +31,7 @@
 (require 'gnus)
 (require 'gnus-group)
 (require 'gnus-start)
 (require 'gnus)
 (require 'gnus-group)
 (require 'gnus-start)

+(require 'gnus-util)

 
 (defgroup gnus-topic nil
   "Group topics."
 
 (defgroup gnus-topic nil
   "Group topics."


@@ -44,6 +45,9 @@
   :type 'hook
   :group 'gnus-topic)
 
   :type 'hook
   :group 'gnus-topic)
 

+(when (featurep 'xemacs)
+  (add-hook 'gnus-topic-mode-hook 'gnus-xmas-topic-menu-add))
+

 (defcustom gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n"
   "Format of topic lines.
 It works along the same lines as a normal formatting string,
 (defcustom gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n"
   "Format of topic lines.
 It works along the same lines as a normal formatting string,


@@ -55,7 +59,10 @@ with some simple extensions.
 %g  Number of groups in the topic.
 %a  Number of unread articles in the groups in the topic.
 %A  Number of unread articles in the groups in the topic and its subtopics.
 %g  Number of groups in the topic.
 %a  Number of unread articles in the groups in the topic.
 %A  Number of unread articles in the groups in the topic and its subtopics.

-"
+
+General format specifiers can also be used.
+See Info node `(gnus)Formatting Variables'."
+  :link '(custom-manual "(gnus)Formatting Variables")

   :type 'string
   :group 'gnus-topic)
 
   :type 'string
   :group 'gnus-topic)
 


@@ -73,6 +80,7 @@ with some simple extensions.
 
 (defvar gnus-topic-active-topology nil)
 (defvar gnus-topic-active-alist nil)
 
 (defvar gnus-topic-active-topology nil)
 (defvar gnus-topic-active-alist nil)

+(defvar gnus-topic-unreads nil)

 
 (defvar gnus-topology-checked-p nil
   "Whether the topology has been checked in this session.")
 
 (defvar gnus-topology-checked-p nil
   "Whether the topology has been checked in this session.")


@@ -95,22 +103,20 @@ with some simple extensions.
 
 (defun gnus-group-topic-name ()
   "The name of the topic on the current line."
 
 (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."
     (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."
 
 (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."
 
 (defun gnus-topic-unread (topic)
   "Return the number of unread articles in TOPIC."

-  (or (save-excursion
-       (and (gnus-topic-goto-topic topic)
-            (gnus-group-topic-unread)))
+  (or (cdr (assoc topic gnus-topic-unreads))

       0))
 
 (defun gnus-group-topic-p ()
       0))
 
 (defun gnus-group-topic-p ()


@@ -119,7 +125,7 @@ with some simple extensions.
 
 (defun gnus-topic-visible-p ()
   "Return non-nil if the current topic is visible."
 
 (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)
 
 (defun gnus-topic-articles-in-topic (entries)
   (let ((total 0)


@@ -142,18 +148,27 @@ with some simple extensions.
 
 (defun gnus-group-parent-topic (group)
   "Return the topic GROUP is member of by looking at the group buffer."
 
 (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))))
 
 (defun gnus-topic-goto-topic (topic)
     (if (gnus-group-goto-group group)
        (gnus-current-topic)
       (gnus-group-topic group))))
 
 (defun gnus-topic-goto-topic (topic)

-  "Go to TOPIC."

   (when topic
     (gnus-goto-char (text-property-any (point-min) (point-max)
                                       'gnus-topic (intern topic)))))
 
   (when topic
     (gnus-goto-char (text-property-any (point-min) (point-max)
                                       'gnus-topic (intern topic)))))
 

+(defun gnus-topic-jump-to-topic (topic)
+  "Go to TOPIC."
+  (interactive
+   (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 ()
   "Return the name of the current topic."
   (let ((result
 (defun gnus-current-topic ()
   "Return the name of the current topic."
   (let ((result


@@ -166,9 +181,10 @@ with some simple extensions.
     (when result
       (symbol-name result))))
 
     (when result
       (symbol-name result))))
 

-(defun gnus-current-topics ()
-  "Return a list of all current topics, lowest in hierarchy first."
-  (let ((topic (gnus-current-topic))
+(defun gnus-current-topics (&optional topic)
+  "Return a list of all current topics, lowest in hierarchy first.
+If TOPIC, start with that topic."
+  (let ((topic (or topic (gnus-current-topic)))

        topics)
     (while topic
       (push topic topics)
        topics)
     (while topic
       (push topic topics)


@@ -177,20 +193,19 @@ with some simple extensions.
 
 (defun gnus-group-active-topic-p ()
   "Say whether the current topic comes from the active topics."
 
 (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)
-  "Return entries for all visible groups in TOPIC."
+(defun gnus-topic-find-groups (topic &optional level all lowest recursive)
+  "Return entries for all visible groups in TOPIC.
+If RECURSIVE is t, return groups in its subtopics too."

   (let ((groups (cdr (assoc topic gnus-topic-alist)))
   (let ((groups (cdr (assoc topic gnus-topic-alist)))

-        info clevel unread group params visible-groups entry active)
+       info clevel unread group params visible-groups entry active)

     (setq lowest (or lowest 1))
     (setq lowest (or lowest 1))

-    (setq level (or level 7))
+    (setq level (or level gnus-level-unsubscribed))

     ;; We go through the newsrc to look for matches.
     (while groups
       (when (setq group (pop groups))
     ;; 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)
              info (nth 2 entry)
              params (gnus-info-params info)
              active (gnus-active group)


@@ -199,18 +214,20 @@ with some simple extensions.
                              active
                              (- (1+ (cdr active)) (car active))))
              clevel (or (gnus-info-level info)
                              active
                              (- (1+ (cdr active)) (car active))))
              clevel (or (gnus-info-level info)

-                        (if (member group gnus-zombie-list) 8 9))))
+                        (if (member group gnus-zombie-list)
+                            gnus-level-zombie gnus-level-killed))))

       (and
       (and

-       unread                          ; nil means that the group is dead.
+       info                            ; nil means that the group is dead.

        (<= clevel level)
        (>= clevel lowest)              ; Is inside the level we want.
        (or all
        (<= clevel level)
        (>= clevel lowest)              ; Is inside the level we want.
        (or all

-          (if (eq unread t)
+          (if (or (eq unread t)
+                  (eq unread nil))

               gnus-group-list-inactive-groups
             (> unread 0))
           (and gnus-list-groups-with-ticked-articles
                (cdr (assq 'tick (gnus-info-marks info))))
               gnus-group-list-inactive-groups
             (> 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))
           ;; Check for permanent visibility.
           (and gnus-permanently-visible-groups
                (string-match gnus-permanently-visible-groups group))


@@ -218,7 +235,39 @@ with some simple extensions.
           (cdr (assq 'visible params)))
        ;; Add this group to the list of visible groups.
        (push (or entry group) visible-groups)))
           (cdr (assq 'visible params)))
        ;; Add this group to the list of visible groups.
        (push (or entry group) visible-groups)))

-    (nreverse visible-groups)))
+    (setq visible-groups (nreverse visible-groups))
+    (when recursive
+      (if (eq recursive t)
+         (setq recursive (cdr (gnus-topic-find-topology topic))))
+      (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)
+  "Go to the N'th previous topic."
+  (interactive "p")
+  (gnus-topic-goto-next-topic (- n)))
+
+(defun gnus-topic-goto-next-topic (n)
+  "Go to the N'th next topic."
+  (interactive "p")
+  (let ((backward (< n 0))
+       (n (abs n))
+       (topic (gnus-current-topic)))
+    (while (and (> n 0)
+               (setq topic
+                     (if backward
+                         (gnus-topic-previous-topic topic)
+                       (gnus-topic-next-topic topic))))
+      (gnus-topic-goto-topic topic)
+      (setq n (1- n)))
+    (when (/= 0 n)
+      (gnus-message 7 "No more topics"))
+    n))

 
 (defun gnus-topic-previous-topic (topic)
   "Return the previous topic on the same level as TOPIC."
 
 (defun gnus-topic-previous-topic (topic)
   "Return the previous topic on the same level as TOPIC."


@@ -296,7 +345,7 @@ with some simple extensions.
     (setq topology gnus-topic-topology
          gnus-tmp-topics nil))
   (push (caar topology) gnus-tmp-topics)
     (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
   gnus-tmp-topics)
 
 ;;; Topic parameter jazz


@@ -323,28 +372,52 @@ with some simple extensions.
      (format "(gnus-topic-set-parameters %S '%S)" topic parameters))))
 
 (defun gnus-group-topic-parameters (group)
      (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."
-  (let ((params-list (list (gnus-group-get-parameter group)))
-       topics params param out)
+  "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
     (save-excursion

-      (gnus-group-goto-group group)
-      (setq topics (gnus-current-topics))
-      (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))
-      ;; Now we have all the parameters, so we go through them
-      ;; and do inheritance in the obvious way.
+      (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.
+    (let (posting-style)

       (while (setq params (pop params-list))
        (while (setq param (pop params))
          (when (atom param)
            (setq param (cons param t)))
       (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.
-         (setq out (delq (assq (car param) out) out))
-         (push param out)))
-      ;; Return the resulting parameter list.
-      out)))
+         (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))

 
 ;;; General utility functions
 
 
 ;;; General utility functions
 


@@ -354,14 +427,21 @@ with some simple extensions.
 
 ;;; Generating group buffers
 
 
 ;;; Generating group buffers
 

-(defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic topic-level)
-  "List all newsgroups with unread articles of level LEVEL or lower, and
-use the `gnus-group-topics' to sort the groups.
-If ALL is non-nil, list groups that have no unread articles.
+(defun gnus-group-prepare-topics (level &optional predicate lowest
+                                       regexp list-topic topic-level)
+  "List all newsgroups with unread articles of level LEVEL or lower.
+Use the `gnus-group-topics' to sort the groups.
+If PREDICTE is a function, list groups that the function returns non-nil;
+if it is t, list groups that have no unread articles.

 If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
   (set-buffer gnus-group-buffer)
   (let ((buffer-read-only nil)
 If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
   (set-buffer gnus-group-buffer)
   (let ((buffer-read-only nil)

-        (lowest (or lowest 1)))
+       (lowest (or lowest 1))
+       (not-in-list
+        (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))
 
     (when (or (not gnus-topic-alist)
              (not gnus-topology-checked-p))


@@ -371,42 +451,63 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
       (erase-buffer))
 
     ;; List dead groups?
       (erase-buffer))
 
     ;; List dead groups?

-    (when (and (>= level gnus-level-zombie)
-              (<= lowest gnus-level-zombie))
+    (when (or gnus-group-listed-groups
+             (and (>= level gnus-level-zombie)
+                  (<= lowest gnus-level-zombie)))

       (gnus-group-prepare-flat-list-dead
        (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
        gnus-level-zombie ?Z
        regexp))
 
       (gnus-group-prepare-flat-list-dead
        (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
        gnus-level-zombie ?Z
        regexp))
 

-    (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed))
+    (when (or gnus-group-listed-groups
+              (and (>= level gnus-level-killed)
+                   (<= lowest gnus-level-killed)))

       (gnus-group-prepare-flat-list-dead
        (setq gnus-killed-list (sort gnus-killed-list 'string<))
       (gnus-group-prepare-flat-list-dead
        (setq gnus-killed-list (sort gnus-killed-list 'string<))

-       gnus-level-killed ?K
-       regexp))
+       gnus-level-killed ?K regexp)
+      (when not-in-list
+       (unless gnus-killed-hashtb
+         (gnus-make-hashtable-from-killed))
+       (gnus-group-prepare-flat-list-dead
+        (gnus-remove-if (lambda (group)
+                          (or (gnus-group-entry group)
+                              (gnus-gethash group gnus-killed-hashtb)))
+                        not-in-list)
+        gnus-level-killed ?K regexp)))

 
     ;; Use topics.
     (prog1
 
     ;; Use topics.
     (prog1

-       (when (< lowest gnus-level-zombie)
+       (when (or (< lowest gnus-level-zombie)
+                 gnus-group-listed-groups)

          (if list-topic
              (let ((top (gnus-topic-find-topology list-topic)))
                (gnus-topic-prepare-topic (cdr top) (car top)
          (if list-topic
              (let ((top (gnus-topic-find-topology list-topic)))
                (gnus-topic-prepare-topic (cdr top) (car top)

-                                         (or topic-level level) all
-                                         nil lowest))
+                                         (or topic-level level) predicate
+                                         nil lowest regexp))

            (gnus-topic-prepare-topic gnus-topic-topology 0
            (gnus-topic-prepare-topic gnus-topic-topology 0

-                                     (or topic-level level) all
-                                     nil lowest)))
-
+                                     (or topic-level level) predicate
+                                     nil lowest regexp)))

       (gnus-group-set-mode-line)
       (gnus-group-set-mode-line)

-      (setq gnus-group-list-mode (cons level all))
-      (run-hooks 'gnus-group-prepare-hook))))
+      (setq gnus-group-list-mode (cons level predicate))
+      (gnus-run-hooks 'gnus-group-prepare-hook))))

 
 

-(defun gnus-topic-prepare-topic (topicl level &optional list-level all silent
-                                       lowest)
+(defun gnus-topic-prepare-topic (topicl level &optional list-level
+                                       predicate silent
+                                       lowest regexp)

   "Insert TOPIC into the group buffer.
 If SILENT, don't insert anything.  Return the number of unread
 articles in the topic and its subtopics."
   (let* ((type (pop topicl))
   "Insert TOPIC into the group buffer.
 If SILENT, don't insert anything.  Return the number of unread
 articles in the topic and its subtopics."
   (let* ((type (pop topicl))

-        (entries (gnus-topic-find-groups (car type) list-level all lowest))
+        (entries (gnus-topic-find-groups
+                  (car type)
+                  (if gnus-group-listed-groups
+                      gnus-level-killed
+                    list-level)
+                  (or predicate gnus-group-listed-groups
+                      (cdr (assq 'visible
+                                 (gnus-topic-hierarchical-parameters
+                                  (car type)))))
+                  (if gnus-group-listed-groups 0 lowest)))

         (visiblep (and (eq (nth 1 type) 'visible) (not silent)))
         (gnus-group-indentation
          (make-string (* gnus-topic-indent-level level) ? ))
         (visiblep (and (eq (nth 1 type) 'visible) (not silent)))
         (gnus-group-indentation
          (make-string (* gnus-topic-indent-level level) ? ))


@@ -421,31 +522,61 @@ articles in the topic and its subtopics."
     (while topicl
       (incf unread
            (gnus-topic-prepare-topic
     (while topicl
       (incf unread
            (gnus-topic-prepare-topic

-            (pop topicl) (1+ level) list-level all
-            (not visiblep) lowest)))
+            (pop topicl