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