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

   1 ;;; gnus-topic.el --- a folding group mode for Gnus
   2 ;; Copyright (C) 1995 Free Software Foundation, Inc.
   3
   4 ;; Author: Ilja Weis <kult@uni-paderborn.de>
   5 ;;      Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   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
  22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (require 'gnus)
  29 (eval-when-compile (require 'cl))
  30
  31 (defvar gnus-group-topic-face 'bold
  32   "*Face used to highlight topic headers.")
  33
  34 (defvar gnus-group-topics '(("no" "^no" nil) ("misc" "." nil))
  35   "*Alist of newsgroup topics.
  36 This alist has entries of the form
  37
  38    (TOPIC REGEXP SHOW)
  39
  40 where TOPIC is the name of the topic a group is put in if it matches
  41 REGEXP.  A group can only be in one topic at a time.
  42
  43 If SHOW is nil, newsgroups will be inserted according to
  44 `gnus-group-topic-topics-only', otherwise that variable is ignored and
  45 the groups are always shown if SHOW is true or never if SHOW is a
  46 number.")
  47
  48 (defvar gnus-topic-names nil
  49   "A list of all topic names.")
  50
  51 (defvar gnus-topic-names nil
  52   "A list of all topic names.")
  53
  54 (defvar gnus-group-topic-topics-only nil
  55   "*If non-nil, only the topics will be shown when typing `l' or `L'.")
  56
  57 (defvar gnus-topic-unique t
  58   "*If non-nil, each group will only belong to one topic.")
  59
  60 ;; Internal variables.
  61
  62 (defvar gnus-topics-not-listed nil)
  63
  64 ;; Functions.
  65
  66 (defun gnus-group-topic-name ()
  67   "The name of the topic on the current line."
  68   (get-text-property (gnus-point-at-bol) 'gnus-topic))
  69
  70 (defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic)
  71   "List all newsgroups with unread articles of level LEVEL or lower, and
  72 use the `gnus-group-topics' to sort the groups.
  73 If ALL is non-nil, list groups that have no unread articles.
  74 If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
  75   (set-buffer gnus-group-buffer)
  76   (let ((buffer-read-only nil)
  77         (lowest (or lowest 1))
  78         tlist info)
  79
  80     (unless list-topic
  81       (erase-buffer))
  82
  83     ;; List dead groups?
  84     (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie)
  85          (gnus-group-prepare-flat-list-dead
  86           (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
  87           gnus-level-zombie ?Z
  88           regexp))
  89
  90     (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)
  91          (gnus-group-prepare-flat-list-dead
  92           (setq gnus-killed-list (sort gnus-killed-list 'string<))
  93           gnus-level-killed ?K
  94           regexp))
  95
  96     ;; Use topics.
  97     (if (< lowest gnus-level-zombie)
  98         (let ((topics (gnus-topic-find-groups list-topic level all))
  99               topic how)
 100           (setq gnus-topic-names topics)
 101           (while topics
 102             (setq topic (car (car topics))
 103                   tlist (cdr (car topics))
 104                   how (nth 2 (assoc topic gnus-group-topics))
 105                   topics (cdr topics))
 106
 107             ;; Insert the topic.
 108             (unless list-topic
 109               (add-text-properties
 110                (point)
 111                (progn
 112                  (insert topic "\n")
 113                  (1- (point)))
 114                (list 'mouse-face gnus-mouse-face
 115                      'face gnus-group-topic-face
 116                      'gnus-topic topic)))
 117
 118             ;; We insert the groups for the topics we want to have.
 119             (if (and (or (and (not how) (not gnus-group-topic-topics-only))
 120                          (and how (not (numberp how))))
 121                      (not (member topic gnus-topics-not-listed)))
 122                 ;; We want to list this topic.
 123                 (progn
 124                   (setq gnus-topics-not-listed
 125                         (delete topic gnus-topics-not-listed))
 126                   (setq tlist (nreverse tlist))
 127                   (while tlist
 128                     (setq info (car tlist))
 129                     (gnus-group-insert-group-line
 130                      nil (gnus-info-group info)
 131                      (gnus-info-level info) (gnus-info-marks info)
 132                      (car (gnus-gethash (gnus-info-group info)
 133                                         gnus-newsrc-hashtb))
 134                      (gnus-info-method info))
 135                     (setq tlist (cdr tlist))))
 136               ;; This one is hiddent.
 137               (push topic gnus-topics-not-listed))))))
 138
 139   (gnus-group-set-mode-line)
 140   (setq gnus-group-list-mode (cons level all))
 141   (run-hooks 'gnus-group-prepare-hook))
 142
 143 (defun gnus-topic-find-groups (&optional topic level all)
 144   "Find all topics and all groups in all topics.
 145 If TOPIC, just find the groups in that topic."
 146   (let ((newsrc (cdr gnus-newsrc-alist))
 147         (topics (if topic
 148                     (list (list topic))
 149                   (mapcar (lambda (e) (list (car e)))
 150                           gnus-group-topics)))
 151         (topic-alist (if topic (list (assoc topic gnus-group-topics))
 152                        gnus-group-topics))
 153         info clevel unread group w lowest gtopic)
 154     (setq lowest (or lowest 1))
 155     (setq all (or all nil))
 156     (setq level (or level 7))
 157     ;; We go through the newsrc to look for matches.
 158     (while newsrc
 159       (setq info (car newsrc)
 160             group (gnus-info-group info)
 161             newsrc (cdr newsrc)
 162             unread (car (gnus-gethash group gnus-newsrc-hashtb)))
 163       (and
 164        unread                           ; nil means that the group is dead.
 165        (<= (setq clevel (gnus-info-level info)) level)
 166        (>= clevel lowest)               ; Is inside the level we want.
 167        (or all
 168            (eq unread t)
 169            (> unread 0)
 170            (cdr (assq 'tick (gnus-info-marks info)))) ; Has right readedness.
 171        (progn
 172          ;; So we find out what topic this group belongs to.  First we
 173          ;; check the group parameters.
 174          (setq gtopic (cdr (assq 'topic (gnus-info-params info))))
 175          ;; On match, we add it.
 176          (and (stringp gtopic)
 177               (or (not topic)
 178                   (string= gtopic topic))
 179               (if (setq e (assoc gtopic topics))
 180                   (setcdr e (cons info (cdr e)))
 181                 (setq topics (cons (list gtopic info) topics))))
 182          ;; We look through the topic alist for further matches, if
 183          ;; needed.
 184          (if (or (not gnus-topic-unique) (not (stringp gtopic)))
 185              (let ((ts topic-alist))
 186                (while ts
 187                  (if (string-match (nth 1 (car ts)) group)
 188                      (progn
 189                        (setcdr (setq e (assoc (car (car ts)) topics))
 190                                (cons info (cdr e)))
 191                        (and gnus-topic-unique (setq ts nil))))
 192                  (setq ts (cdr ts))))))))
 193     topics))
 194
 195 (defun gnus-topic-remove-topic ()
 196   "Remove the current topic."
 197   (let ((topic (gnus-group-topic-name))
 198         buffer-read-only)
 199     (when topic
 200       (setq gnus-topics-not-listed (cons topic gnus-topics-not-listed))
 201       (forward-line 1)
 202       (unless (gnus-group-topic-name)
 203         (delete-region (point)
 204                        (or (next-single-property-change (point) 'gnus-topic)
 205                            (point-max)))))))
 206
 207 (defun gnus-topic-insert-topic (topic)
 208   "Insert TOPIC."
 209   (setq gnus-topics-not-listed (delete topic gnus-topics-not-listed))
 210   (gnus-group-prepare-topics
 211    (car gnus-group-list-mode) (cdr gnus-group-list-mode)
 212    nil nil topic))
 213
 214 (defun gnus-topic-fold ()
 215   "Remove/insert the current topic."
 216   (let ((topic (gnus-group-topic-name)))
 217     (when topic
 218       (save-excursion
 219         (if (not (member topic gnus-topics-not-listed))
 220             ;; If the topic is visible, we remove it.
 221             (gnus-topic-remove-topic)
 222           ;; If not, we insert it.
 223           (forward-line 1)
 224           (gnus-topic-insert-topic topic))))))
 225
 226 ;; Written by "jeff (j.d.) sparkes" <jsparkes@bnr.ca>.
 227 (defun gnus-group-add-to-topic (n topic)
 228   "Add the current group to a topic."
 229   (interactive
 230    (list current-prefix-arg
 231          (completing-read "Add to topic: " gnus-topic-names)))
 232   (let ((groups (gnus-group-process-prefix n)))
 233     (mapcar (lambda (g)
 234               (gnus-group-remove-mark g)
 235               (gnus-group-add-parameter g (cons 'topic topic)))
 236             groups)
 237     (gnus-group-position-point)))
 238
 239 (defun gnus-topic-toggle-topic ()
 240   "Toggle between a flat group buffer and a topic display."
 241   (interactive)
 242   (if (eq gnus-group-prepare-function 'gnus-group-prepare-topics)
 243       (setq gnus-group-prepare-function 'gnus-group-prepare-flat)
 244     (setq gnus-group-prepare-function 'gnus-group-prepare-topics))
 245   (gnus-group-list-groups))
 246
 247 ;;; gnus-topic.el ends here