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

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