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