cgit.sxemacs.org Git - gnus/blob - lisp/gnus-topic.el

   1 ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers
   2 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Ilja Weis <kult@uni-paderborn.de>
   6 ;;      Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; Keywords: news
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 (eval-when-compile (require 'cl))
  31
  32 (require 'gnus)
  33 (require 'gnus-group)
  34 (require 'gnus-start)
  35 (require 'gnus-util)
  36
  37 (defgroup gnus-topic nil
  38   "Group topics."
  39   :group 'gnus-group)
  40
  41 (defvar gnus-topic-mode nil
  42   "Minor mode for Gnus group buffers.")
  43
  44 (defcustom gnus-topic-mode-hook nil
  45   "Hook run in topic mode buffers."
  46   :type 'hook
  47   :group 'gnus-topic)
  48
  49 (when (featurep 'xemacs)
  50   (add-hook 'gnus-topic-mode-hook 'gnus-xmas-topic-menu-add))
  51
  52 (defcustom gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n"
  53   "Format of topic lines.
  54 It works along the same lines as a normal formatting string,
  55 with some simple extensions.
  56
  57 %i  Indentation based on topic level.
  58 %n  Topic name.
  59 %v  Nothing if the topic is visible, \"...\" otherwise.
  60 %g  Number of groups in the topic.
  61 %a  Number of unread articles in the groups in the topic.
  62 %A  Number of unread articles in the groups in the topic and its subtopics.
  63
  64 General format specifiers can also be used.
  65 See Info node `(gnus)Formatting Variables'."
  66   :link '(custom-manual "(gnus)Formatting Variables")
  67   :type 'string
  68   :group 'gnus-topic)
  69
  70 (defcustom gnus-topic-indent-level 2
  71   "*How much each subtopic should be indented."
  72   :type 'integer
  73   :group 'gnus-topic)
  74
  75 (defcustom gnus-topic-display-empty-topics t
  76   "*If non-nil, display the topic lines even of topics that have no unread articles."
  77   :type 'boolean
  78   :group 'gnus-topic)
  79
  80 ;; Internal variables.
  81
  82 (defvar gnus-topic-active-topology nil)
  83 (defvar gnus-topic-active-alist nil)
  84 (defvar gnus-topic-unreads nil)
  85
  86 (defvar gnus-topology-checked-p nil
  87   "Whether the topology has been checked in this session.")
  88
  89 (defvar gnus-topic-killed-topics nil)
  90 (defvar gnus-topic-inhibit-change-level nil)
  91
  92 (defconst gnus-topic-line-format-alist
  93   `((?n name ?s)
  94     (?v visible ?s)
  95     (?i indentation ?s)
  96     (?g number-of-groups ?d)
  97     (?a (gnus-topic-articles-in-topic entries) ?d)
  98     (?A total-number-of-articles ?d)
  99     (?l level ?d)))
 100
 101 (defvar gnus-topic-line-format-spec nil)
 102
 103 ;;; Utility functions
 104
 105 (defun gnus-group-topic-name ()
 106   "The name of the topic on the current line."
 107   (let ((topic (get-text-property (gnus-point-at-bol) 'gnus-topic)))
 108     (and topic (symbol-name topic))))
 109
 110 (defun gnus-group-topic-level ()
 111   "The level of the topic on the current line."
 112   (get-text-property (gnus-point-at-bol) 'gnus-topic-level))
 113
 114 (defun gnus-group-topic-unread ()
 115   "The number of unread articles in topic on the current line."
 116   (get-text-property (gnus-point-at-bol) 'gnus-topic-unread))
 117
 118 (defun gnus-topic-unread (topic)
 119   "Return the number of unread articles in TOPIC."
 120   (or (cdr (assoc topic gnus-topic-unreads))
 121       0))
 122
 123 (defun gnus-group-topic-p ()
 124   "Return non-nil if the current line is a topic."
 125   (gnus-group-topic-name))
 126
 127 (defun gnus-topic-visible-p ()
 128   "Return non-nil if the current topic is visible."
 129   (get-text-property (gnus-point-at-bol) 'gnus-topic-visible))
 130
 131 (defun gnus-topic-articles-in-topic (entries)
 132   (let ((total 0)
 133         number)
 134     (while entries
 135       (when (numberp (setq number (car (pop entries))))
 136         (incf total number)))
 137     total))
 138
 139 (defun gnus-group-topic (group)
 140   "Return the topic GROUP is a member of."
 141   (let ((alist gnus-topic-alist)
 142         out)
 143     (while alist
 144       (when (member group (cdar alist))
 145         (setq out (caar alist)
 146               alist nil))
 147       (setq alist (cdr alist)))
 148     out))
 149
 150 (defun gnus-group-parent-topic (group)
 151   "Return the topic GROUP is member of by looking at the group buffer."
 152   (save-excursion
 153     (set-buffer gnus-group-buffer)
 154     (if (gnus-group-goto-group group)
 155         (gnus-current-topic)
 156       (gnus-group-topic group))))
 157
 158 (defun gnus-topic-goto-topic (topic)
 159   (when topic
 160     (gnus-goto-char (text-property-any (point-min) (point-max)
 161                                        'gnus-topic (intern topic)))))
 162
 163 (defun gnus-topic-jump-to-topic (topic)
 164   "Go to TOPIC."
 165   (interactive
 166    (list (completing-read "Go to topic: "
 167                           (mapcar 'list (gnus-topic-list))
 168                           nil t)))
 169   (dolist (topic (gnus-current-topics topic))
 170     (gnus-topic-goto-topic topic)
 171     (gnus-topic-fold t))
 172   (gnus-topic-goto-topic topic))
 173
 174 (defun gnus-current-topic ()
 175   "Return the name of the current topic."
 176   (let ((result
 177          (or (get-text-property (point) 'gnus-topic)
 178              (save-excursion
 179                (and (gnus-goto-char (previous-single-property-change
 180                                      (point) 'gnus-topic))
 181                     (get-text-property (max (1- (point)) (point-min))
 182                                        'gnus-topic))))))
 183     (when result
 184       (symbol-name result))))
 185
 186 (defun gnus-current-topics (&optional topic)
 187   "Return a list of all current topics, lowest in hierarchy first.
 188 If TOPIC, start with that topic."
 189   (let ((topic (or topic (gnus-current-topic)))
 190         topics)
 191     (while topic
 192       (push topic topics)
 193       (setq topic (gnus-topic-parent-topic topic)))
 194     (nreverse topics)))
 195
 196 (defun gnus-group-active-topic-p ()
 197   "Say whether the current topic comes from the active topics."
 198   (save-excursion
 199     (beginning-of-line)
 200     (get-text-property (point) 'gnus-active)))
 201
 202 (defun gnus-topic-find-groups (topic &optional level all lowest recursive)
 203   "Return entries for all visible groups in TOPIC.
 204 If RECURSIVE is t, return groups in its subtopics too."
 205   (let ((groups (cdr (assoc topic gnus-topic-alist)))
 206         info clevel unread group params visible-groups entry active)
 207     (setq lowest (or lowest 1))
 208     (setq level (or level gnus-level-unsubscribed))
 209     ;; We go through the newsrc to look for matches.
 210     (while groups
 211       (when (setq group (pop groups))
 212         (setq entry (gnus-gethash group gnus-newsrc-hashtb)
 213               info (nth 2 entry)
 214               params (gnus-info-params info)
 215               active (gnus-active group)
 216               unread (or (car entry)
 217                          (and (not (equal group "dummy.group"))
 218                               active
 219                               (- (1+ (cdr active)) (car active))))
 220               clevel (or (gnus-info-level info)
 221                          (if (member group gnus-zombie-list)
 222                              gnus-level-zombie gnus-level-killed))))
 223       (and
 224        info                             ; nil means that the group is dead.
 225        (<= clevel level)
 226        (>= clevel lowest)               ; Is inside the level we want.
 227        (or all
 228            (if (or (eq unread t)
 229                    (eq unread nil))
 230                gnus-group-list-inactive-groups
 231              (> unread 0))
 232            (and gnus-list-groups-with-ticked-articles
 233                 (cdr (assq 'tick (gnus-info-marks info))))
 234            ;; Has right readedness.
 235            ;; Check for permanent visibility.
 236            (and gnus-permanently-visible-groups
 237                 (string-match gnus-permanently-visible-groups group))
 238            (memq 'visible params)
 239            (cdr (assq 'visible params)))
 240        ;; Add this group to the list of visible groups.
 241        (push (or entry group) visible-groups)))
 242     (setq visible-groups (nreverse visible-groups))
 243     (when recursive
 244       (if (eq recursive t)
 245           (setq recursive (cdr (gnus-topic-find-topology topic))))
 246       (mapcar (lambda (topic-topology)
 247                 (setq visible-groups
 248                       (nconc visible-groups
 249                              (gnus-topic-find-groups
 250                               (caar topic-topology)
 251                               level all lowest topic-topology))))
 252               (cdr recursive)))
 253     visible-groups))
 254
 255 (defun gnus-topic-goto-previous-topic (n)
 256   "Go to the N'th previous topic."
 257   (interactive "p")
 258   (gnus-topic-goto-next-topic (- n)))
 259
 260 (defun gnus-topic-goto-next-topic (n)
 261   "Go to the N'th next topic."
 262   (interactive "p")
 263   (let ((backward (< n 0))
 264         (n (abs n))
 265         (topic (gnus-current-topic)))
 266     (while (and (> n 0)
 267                 (setq topic
 268                       (if backward
 269                           (gnus-topic-previous-topic topic)
 270                         (gnus-topic-next-topic topic))))
 271       (gnus-topic-goto-topic topic)
 272      &