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