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
  30 (defvar gnus-group-topic-face 'bold
  31   "*Face used to highlight topic headers.")
  32
  33 (defvar gnus-group-topics '(("no" "^no" nil) ("misc" "." nil))
  34   "*Alist of newsgroup topics.
  35 This alist has entries of the form
  36
  37    (TOPIC REGEXP SHOW)
  38
  39 where TOPIC is the name of the topic a group is put in if it matches
  40 REGEXP.  A group can only be in one topic at a time.
  41
  42 If SHOW is nil, newsgroups will be inserted according to
  43 `gnus-group-topic-topics-only', otherwise that variable is ignored and
  44 the groups are always shown if SHOW is true or never if SHOW is a
  45 number.")
  46
  47 (defvar gnus-group-topic-topics-only nil
  48   "*If non-nil, only the topics will be shown when typing `l' or `L'.")
  49
  50 (defvar gnus-topic-unique t
  51   "*If non-nil, each group will only belong to one topic.")
  52
  53 ;; Internal variables.
  54
  55 (defvar gnus-topics-not-listed nil)
  56
  57 ;; Functions.
  58
  59 (defun gnus-group-topic-name ()
  60   "The name of the topic on the current line."
  61   (get-text-property (gnus-point-at-bol) 'gnus-topic))
  62
  63 (defun gnus-group-prepare-topics (level &optional all lowest regexp topic)
  64   "List all newsgroups with unread articles of level LEVEL or lower, and
  65 use the `gnus-group-topics' to sort the groups.
  66 If ALL is non-nil, list groups that have no unread articles.
  67 If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
  68   (set-buffer gnus-group-buffer)
  69   (let ((buffer-read-only nil)
  70         (lowest (or lowest 1))
  71         tlist info)
  72
  73     (or topic (erase-buffer))
  74
  75     ;; List dead groups?
  76     (and (>= level 8) (<= lowest 8)
  77          (gnus-group-prepare-flat-list-dead
  78           (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) 8 ?Z
  79           regexp))
  80
  81     (and (>= level 9) (<= lowest 9)
  82          (gnus-group-prepare-flat-list-dead
  83           (setq gnus-killed-list (sort gnus-killed-list 'string<)) 9 ?K
  84           regexp))
  85
  86     ;; Use topics
  87     (if (< lowest 8)
  88         (let ((topics (gnus-topic-find-groups topic))
  89               topic how)
  90           (erase-buffer)
  91           (while topics
  92             (setq topic (car (car topics))
  93                   tlist (cdr (car topics))
  94                   how (nth 2 (assoc topic gnus-group-topics))
  95                   topics (cdr topics))
  96
  97             ;; Insert the topic.
  98             (add-text-properties
  99              (point)
 100              (progn
 101                (insert topic "\n")
 102                (point))
 103              (list 'mouse-face gnus-mouse-face
 104                    'face gnus-group-topic-face
 105                    'gnus-topic topic))
 106
 107             ;; We insert the groups for the topics we want to have.
 108             (if (and (or (and (not how) (not gnus-group-topic-topics-only))
 109                          (and how (not (numberp how))))
 110                      (not (member topic gnus-topics-not-listed)))
 111                 (progn
 112                   (setq gnus-topics-not-listed
 113                         (delete topic gnus-topics-not-listed))
 114                   (setq tlist (nreverse tlist))
 115                   (while tlist
 116                     (setq info (car tlist))
 117                     (gnus-group-insert-group-line
 118                      nil (car info) (car (cdr info)) (nth 3 info)
 119                      (car (gnus-gethash (car info) gnus-newsrc-hashtb))
 120                      (nth 4 info))
 121                     (setq tlist (cdr tlist))))
 122               (setq gnus-topics-not-listed
 123                     (cons topic gnus-topics-not-listed)))))))
 124
 125   (gnus-group-set-mode-line)
 126   (setq gnus-group-list-mode (cons level all))
 127   (run-hooks 'gnus-group-prepare-hook))
 128
 129 (defun gnus-topic-find-groups (&optional topic)
 130   "Find all topics and all groups in all topics.
 131 If TOPIC, just find the groups in that topic."
 132   (let ((newsrc (cdr gnus-newsrc-alist))
 133         (topics (mapcar (lambda (e) (list (car e)))
 134                         gnus-group-topics))
 135         (topic-alist (if topic (list (assoc topic gnus-group-topics))
 136                        gnus-group-topics))
 137         info clevel unread group w lowest level all gtopic)
 138     (setq lowest (or lowest 1))
 139     ;; We go through the newsrc to look for matches.
 140     (while newsrc
 141       (setq info (car newsrc)
 142             group (car info)
 143             newsrc (cdr newsrc)
 144             unread (car (gnus-gethash group gnus-newsrc-hashtb)))
 145       (and
 146        unread                           ; nil means that the group is dead.
 147        (<= (setq clevel (car (cdr info))) level)
 148        (>= clevel lowest)               ; Is inside the level we want.
 149        (or all
 150            (eq unread t)
 151            (> unread 0)
 152            (cdr (assq 'tick (nth 3 info)))) ; Has right readedness.
 153        (progn
 154          ;; So we find out what topic this group belongs to.  First we
 155          ;; check the group parameters.
 156          (setq gtopic (cdr (assq 'topic (nth 5 info))))
 157          ;; On match, we add it.
 158          (and (stringp gtopic)
 159               (or (not topic)
 160                   (string= gtopic topic))
 161               (if (setq e (assoc gtopic topics))
 162                   (setcdr e (cons info (cdr e)))
 163                 (setq topics (cons (list gtopic info) topics))))
 164          ;; We look through the topic alist for further matches, if
 165          ;; needed.
 166          (if (or (not gnus-topic-unique) (not (stringp gtopic)))
 167              (let ((ts topic-alist))
 168                (while ts
 169                  (if (string-match (nth 1 (car ts)) group)
 170                      (progn
 171                        (setcdr (setq e (assoc (car (car ts)) topics))
 172                                (cons info (cdr e)))
 173                        (and gnus-topic-unique (setq ts nil))))
 174                  (setq ts (cdr ts))))))))
 175     topics))
 176
 177 (defun gnus-topic-remove-topic ()
 178   "Remove the current topic."
 179   (let ((topic (gnus-group-topic-name))
 180         buffer-read-only)
 181     (if (not topic)
 182         ()
 183       (setq gnus-topics-not-listed (cons topic gnus-topics-not-listed))
 184       (forward-line 1)
 185       (delete-region (point)
 186                      (or (next-single-property-change (point) 'gnus-topic)
 187                          (point-max))))))
 188
 189 (defun gnus-topic-insert-topic (topic)
 190   "Insert TOPIC."
 191   (gnus-group-prepare-topics
 192   (car gnus-group-list-mode) (cdr gnus-group-list-mode)
 193   nil nil topic))
 194
 195 (defun gnus-topic-fold ()
 196   "Remove/insert the current topic."
 197   (let ((topic (gnus-group-topic-name)))
 198     (if (not topic)
 199         ()                              ; Nothing to do.
 200       (save-excursion
 201         (if (not (member topic gnus-topics-not-listed))
 202             ;; If the topic is visible, we remove it.
 203             (gnus-topic-remove-topic)
 204           ;; If not, we insert it.
 205           (forward-line 1)
 206           (gnus-topic-insert-topic topic))))))
 207
 208 ;;; gnus-topic.el ends here