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)
  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     (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))
  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 ()
 130   (let ((newsrc (cdr gnus-newsrc-alist))
 131         (topics (mapcar (lambda (e) (list (car e)))
 132                         gnus-group-topics))
 133         info clevel unread group w lowest level all gtopic)
 134     (setq lowest (or lowest 1))
 135     ;; We go through the newsrc to look for matches.
 136     (while newsrc
 137       (setq info (car newsrc)
 138             group (car info)
 139             newsrc (cdr newsrc)
 140             unread (car (gnus-gethash group gnus-newsrc-hashtb)))
 141       (and
 142        unread                           ; nil means that the group is dead.
 143        (<= (setq clevel (car (cdr info))) level)
 144        (>= clevel lowest)               ; Is inside the level we want.
 145        (or all
 146            (eq unread t)
 147            (> unread 0)
 148            (cdr (assq 'tick (nth 3 info)))) ; Has right readedness.
 149        (progn
 150          ;; So we find out what topic this group belongs to.  First we
 151          ;; check the group parameters.
 152          (setq gtopic (cdr (assq 'topic (nth 5 info))))
 153          ;; On match, we add it.
 154          (and (stringp gtopic)
 155               (if (setq e (assoc gtopic topics))
 156                   (setcdr e (cons info (cdr e)))
 157                 (setq topics (cons (list gtopic info) topics))))
 158          ;; We look through the topic alist for further matches, if
 159          ;; needed.
 160          (if (or (not gnus-topic-unique) (not (stringp gtopic)))
 161              (let ((ts gnus-group-topics))
 162                (while ts
 163                  (if (string-match (nth 1 (car ts)) group)
 164                      (progn
 165                        (setcdr (setq e (assoc (car (car ts)) topics))
 166                                (cons info (cdr e)))
 167                        (and gnus-topic-unique (setq ts nil))))
 168                  (setq ts (cdr ts))))))))
 169     topics))
 170
 171 (defun gnus-topic-remove-topic ()
 172   (let ((topic (gnus-group-topic-name))
 173         buffer-read-only)
 174     (setq gnus-topics-not-listed (cons topic gnus-topics-not-listed))
 175     (forward-line 1)
 176     (delete-region (point)
 177                    (or (next-single-property-change (point) 'gnus-topic)
 178                        (point-max)))))
 179
 180 (defun gnus-topic-fold ()
 181   (let ((topic (gnus-group-topic-name)))
 182     (save-excursion
 183       (if (not (member topic gnus-topics-not-listed))
 184           (gnus-topic-remove-topic)
 185         (forward-line 1)
 186         (gnus-topic-insert-topic
 187          topic (gnus-group-default-level)
 188          (cdr gnus-group-list-mode))))))
 189
 190 ;;; gnus-topic.el ends here