Mercurial > hg > xemacs-beta
comparison lisp/gnus/gnus-topic.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:45:50 +0200 |
| parents | |
| children | ac2d302a0011 |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:376386a54a3c |
|---|---|
| 1 ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers | |
| 2 ;; Copyright (C) 1995,96 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 the | |
| 22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 23 ;; Boston, MA 02111-1307, USA. | |
| 24 | |
| 25 ;;; Commentary: | |
| 26 | |
| 27 ;;; Code: | |
| 28 | |
| 29 (require 'gnus) | |
| 30 (eval-when-compile (require 'cl)) | |
| 31 | |
| 32 (defvar gnus-topic-mode nil | |
| 33 "Minor mode for Gnus group buffers.") | |
| 34 | |
| 35 (defvar gnus-topic-mode-hook nil | |
| 36 "Hook run in topic mode buffers.") | |
| 37 | |
| 38 (defvar gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n" | |
| 39 "Format of topic lines. | |
| 40 It works along the same lines as a normal formatting string, | |
| 41 with some simple extensions. | |
| 42 | |
| 43 %i Indentation based on topic level. | |
| 44 %n Topic name. | |
| 45 %v Nothing if the topic is visible, \"...\" otherwise. | |
| 46 %g Number of groups in the topic. | |
| 47 %a Number of unread articles in the groups in the topic. | |
| 48 %A Number of unread articles in the groups in the topic and its subtopics. | |
| 49 ") | |
| 50 | |
| 51 (defvar gnus-topic-indent-level 2 | |
| 52 "*How much each subtopic should be indented.") | |
| 53 | |
| 54 ;; Internal variables. | |
| 55 | |
| 56 (defvar gnus-topic-active-topology nil) | |
| 57 (defvar gnus-topic-active-alist nil) | |
| 58 | |
| 59 (defvar gnus-topology-checked-p nil | |
| 60 "Whether the topology has been checked in this session.") | |
| 61 | |
| 62 (defvar gnus-topic-killed-topics nil) | |
| 63 (defvar gnus-topic-inhibit-change-level nil) | |
| 64 (defvar gnus-topic-tallied-groups nil) | |
| 65 | |
| 66 (defconst gnus-topic-line-format-alist | |
| 67 `((?n name ?s) | |
| 68 (?v visible ?s) | |
| 69 (?i indentation ?s) | |
| 70 (?g number-of-groups ?d) | |
| 71 (?a (gnus-topic-articles-in-topic entries) ?d) | |
| 72 (?A total-number-of-articles ?d) | |
| 73 (?l level ?d))) | |
| 74 | |
| 75 (defvar gnus-topic-line-format-spec nil) | |
| 76 | |
| 77 ;; Functions. | |
| 78 | |
| 79 (defun gnus-group-topic-name () | |
| 80 "The name of the topic on the current line." | |
| 81 (let ((topic (get-text-property (gnus-point-at-bol) 'gnus-topic))) | |
| 82 (and topic (symbol-name topic)))) | |
| 83 | |
| 84 (defun gnus-group-topic-level () | |
| 85 "The level of the topic on the current line." | |
| 86 (get-text-property (gnus-point-at-bol) 'gnus-topic-level)) | |
| 87 | |
| 88 (defun gnus-group-topic-unread () | |
| 89 "The number of unread articles in topic on the current line." | |
| 90 (get-text-property (gnus-point-at-bol) 'gnus-topic-unread)) | |
| 91 | |
| 92 (defun gnus-topic-unread (topic) | |
| 93 "Return the number of unread articles in TOPIC." | |
| 94 (or (save-excursion | |
| 95 (and (gnus-topic-goto-topic topic) | |
| 96 (gnus-group-topic-unread))) | |
| 97 0)) | |
| 98 | |
| 99 (defun gnus-topic-init-alist () | |
| 100 "Initialize the topic structures." | |
| 101 (setq gnus-topic-topology | |
| 102 (cons (list "Gnus" 'visible) | |
| 103 (mapcar (lambda (topic) | |
| 104 (list (list (car topic) 'visible))) | |
| 105 '(("misc"))))) | |
| 106 (setq gnus-topic-alist | |
| 107 (list (cons "misc" | |
| 108 (mapcar (lambda (info) (gnus-info-group info)) | |
| 109 (cdr gnus-newsrc-alist))) | |
| 110 (list "Gnus"))) | |
| 111 (gnus-topic-enter-dribble)) | |
| 112 | |
| 113 (defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic topic-level) | |
| 114 "List all newsgroups with unread articles of level LEVEL or lower, and | |
| 115 use the `gnus-group-topics' to sort the groups. | |
| 116 If ALL is non-nil, list groups that have no unread articles. | |
| 117 If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." | |
| 118 (set-buffer gnus-group-buffer) | |
| 119 (let ((buffer-read-only nil) | |
| 120 (lowest (or lowest 1))) | |
| 121 | |
| 122 (setq gnus-topic-tallied-groups nil) | |
| 123 | |
| 124 (when (or (not gnus-topic-alist) | |
| 125 (not gnus-topology-checked-p)) | |
| 126 (gnus-topic-check-topology)) | |
| 127 | |
| 128 (unless list-topic | |
| 129 (erase-buffer)) | |
| 130 | |
| 131 ;; List dead groups? | |
| 132 (when (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie)) | |
| 133 (gnus-group-prepare-flat-list-dead | |
| 134 (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) | |
| 135 gnus-level-zombie ?Z | |
| 136 regexp)) | |
| 137 | |
| 138 (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)) | |
| 139 (gnus-group-prepare-flat-list-dead | |
| 140 (setq gnus-killed-list (sort gnus-killed-list 'string<)) | |
| 141 gnus-level-killed ?K | |
| 142 regexp)) | |
| 143 | |
| 144 ;; Use topics. | |
| 145 (when (< lowest gnus-level-zombie) | |
| 146 (if list-topic | |
| 147 (let ((top (gnus-topic-find-topology list-topic))) | |
| 148 (gnus-topic-prepare-topic (cdr top) (car top) | |
| 149 (or topic-level level) all)) | |
| 150 (gnus-topic-prepare-topic gnus-topic-topology 0 | |
| 151 (or topic-level level) all)))) | |
| 152 | |
| 153 (gnus-group-set-mode-line) | |
| 154 (setq gnus-group-list-mode (cons level all)) | |
| 155 (run-hooks 'gnus-group-prepare-hook)) | |
| 156 | |
| 157 (defun gnus-topic-prepare-topic (topicl level &optional list-level all silent) | |
| 158 "Insert TOPIC into the group buffer. | |
| 159 If SILENT, don't insert anything. Return the number of unread | |
| 160 articles in the topic and its subtopics." | |
| 161 (let* ((type (pop topicl)) | |
| 162 (entries (gnus-topic-find-groups (car type) list-level all)) | |
| 163 (visiblep (and (eq (nth 1 type) 'visible) (not silent))) | |
| 164 (gnus-group-indentation | |
| 165 (make-string (* gnus-topic-indent-level level) ? )) | |
| 166 (beg (progn (beginning-of-line) (point))) | |
| 167 (topicl (reverse topicl)) | |
| 168 (all-entries entries) | |
| 169 (unread 0) | |
| 170 (topic (car type)) | |
| 171 info entry end active) | |
| 172 ;; Insert any sub-topics. | |
| 173 (while topicl | |
| 174 (incf unread | |
| 175 (gnus-topic-prepare-topic | |
| 176 (pop topicl) (1+ level) list-level all | |
| 177 (not visiblep)))) | |
| 178 (setq end (point)) | |
| 179 (goto-char beg) | |
| 180 ;; Insert all the groups that belong in this topic. | |
| 181 (while (setq entry (pop entries)) | |
| 182 (when visiblep | |
| 183 (if (stringp entry) | |
| 184 ;; Dead groups. | |
| 185 (gnus-group-insert-group-line | |
| 186 entry (if (member entry gnus-zombie-list) 8 9) | |
| 187 nil (- (1+ (cdr (setq active (gnus-active entry)))) | |
| 188 (car active)) nil) | |
| 189 ;; Living groups. | |
| 190 (when (setq info (nth 2 entry)) | |
| 191 (gnus-group-insert-group-line | |
| 192 (gnus-info-group info) | |
| 193 (gnus-info-level info) (gnus-info-marks info) | |
| 194 (car entry) (gnus-info-method info))))) | |
| 195 (when (and (listp entry) | |
| 196 (numberp (car entry)) | |
| 197 (not (member (gnus-info-group (setq info (nth 2 entry))) | |
| 198 gnus-topic-tallied-groups))) | |
| 199 (push (gnus-info-group info) gnus-topic-tallied-groups) | |
| 200 (incf unread (car entry)))) | |
| 201 (goto-char beg) | |
| 202 ;; Insert the topic line. | |
| 203 (unless silent | |
| 204 (gnus-extent-start-open (point)) | |
| 205 (gnus-topic-insert-topic-line | |
| 206 (car type) visiblep | |
| 207 (not (eq (nth 2 type) 'hidden)) | |
| 208 level all-entries unread)) | |
| 209 (goto-char end) | |
| 210 unread)) | |
| 211 | |
| 212 (defun gnus-topic-find-groups (topic &optional level all) | |
| 213 "Return entries for all visible groups in TOPIC." | |
| 214 (let ((groups (cdr (assoc topic gnus-topic-alist))) | |
| 215 info clevel unread group lowest params visible-groups entry active) | |
| 216 (setq lowest (or lowest 1)) | |
| 217 (setq level (or level 7)) | |
| 218 ;; We go through the newsrc to look for matches. | |
| 219 (while groups | |
| 220 (setq entry (gnus-gethash (setq group (pop groups)) gnus-newsrc-hashtb) | |
| 221 info (nth 2 entry) | |
| 222 params (gnus-info-params info) | |
| 223 active (gnus-active group) | |
| 224 unread (or (car entry) | |
| 225 (and (not (equal group "dummy.group")) | |
| 226 active | |
| 227 (- (1+ (cdr active)) (car active)))) | |
| 228 clevel (or (gnus-info-level info) | |
| 229 (if (member group gnus-zombie-list) 8 9))) | |
| 230 (and | |
| 231 unread ; nil means that the group is dead. | |
| 232 (<= clevel level) | |
| 233 (>= clevel lowest) ; Is inside the level we want. | |
| 234 (or all | |
| 235 (if (eq unread t) | |
| 236 gnus-group-list-inactive-groups | |
| 237 (> unread 0)) | |
| 238 (and gnus-list-groups-with-ticked-articles | |
| 239 (cdr (assq 'tick (gnus-info-marks info)))) | |
| 240 ; Has right readedness. | |
| 241 ;; Check for permanent visibility. | |
| 242 (and gnus-permanently-visible-groups | |
| 243 (string-match gnus-permanently-visible-groups group)) | |
| 244 (memq 'visible params) | |
| 245 (cdr (assq 'visible params))) | |
| 246 ;; Add this group to the list of visible groups. | |
| 247 (push (or entry group) visible-groups))) | |
| 248 (nreverse visible-groups))) | |
| 249 | |
| 250 (defun gnus-topic-remove-topic (&optional insert total-remove hide in-level) | |
| 251 "Remove the current topic." | |
| 252 (let ((topic (gnus-group-topic-name)) | |
| 253 (level (gnus-group-topic-level)) | |
| 254 (beg (progn (beginning-of-line) (point))) | |
| 255 buffer-read-only) | |
| 256 (when topic | |
| 257 (while (and (zerop (forward-line 1)) | |
| 258 (> (or (gnus-group-topic-level) (1+ level)) level))) | |
| 259 (delete-region beg (point)) | |
| 260 (setcar (cdadr (gnus-topic-find-topology topic)) | |
| 261 (if insert 'visible 'invisible)) | |
| 262 (when hide | |
| 263 (setcdr (cdadr (gnus-topic-find-topology topic)) | |
| 264 (list hide))) | |
| 265 (unless total-remove | |
| 266 (gnus-topic-insert-topic topic in-level))))) | |
| 267 | |
| 268 (defun gnus-topic-insert-topic (topic &optional level) | |
| 269 "Insert TOPIC." | |
| 270 (gnus-group-prepare-topics | |
| 271 (car gnus-group-list-mode) (cdr gnus-group-list-mode) | |
| 272 nil nil topic level)) | |
| 273 | |
| 274 (defun gnus-topic-fold (&optional insert) | |
| 275 "Remove/insert the current topic." | |
| 276 (let ((topic (gnus-group-topic-name))) | |
| 277 (when topic | |
| 278 (save-excursion | |
| 279 (if (not (gnus-group-active-topic-p)) | |
| 280 (gnus-topic-remove-topic | |
| 281 (or insert (not (gnus-topic-visible-p)))) | |
| 282 (let ((gnus-topic-topology gnus-topic-active-topology) | |
| 283 (gnus-topic-alist gnus-topic-active-alist) | |
| 284 (gnus-group-list-mode (cons 5 t))) | |
| 285 (gnus-topic-remove-topic | |
| 286 (or insert (not (gnus-topic-visible-p))) nil nil 9))))))) | |
| 287 | |
| 288 (defun gnus-group-topic-p () | |
| 289 "Return non-nil if the current line is a topic." | |
| 290 (gnus-group-topic-name)) | |
| 291 | |
| 292 (defun gnus-topic-visible-p () | |
| 293 "Return non-nil if the current topic is visible." | |
| 294 (get-text-property (gnus-point-at-bol) 'gnus-topic-visible)) | |
| 295 | |
| 296 (defun gnus-topic-insert-topic-line (name visiblep shownp level entries | |
| 297 &optional unread) | |
| 298 (let* ((visible (if visiblep "" "...")) | |
| 299 (indentation (make-string (* gnus-topic-indent-level level) ? )) | |
| 300 (total-number-of-articles unread) | |
| 301 (number-of-groups (length entries)) | |
| 302 (active-topic (eq gnus-topic-alist gnus-topic-active-alist))) | |
| 303 (beginning-of-line) | |
| 304 ;; Insert the text. | |
| 305 (gnus-add-text-properties | |
| 306 (point) | |
| 307 (prog1 (1+ (point)) | |
| 308 (eval gnus-topic-line-format-spec) | |
| 309 (gnus-topic-remove-excess-properties)1) | |
| 310 (list 'gnus-topic (intern name) | |
| 311 'gnus-topic-level level | |
| 312 'gnus-topic-unread unread | |
| 313 'gnus-active active-topic | |
| 314 'gnus-topic-visible visiblep)))) | |
| 315 | |
| 316 (defun gnus-topic-previous-topic (topic) | |
| 317 "Return the previous topic on the same level as TOPIC." | |
| 318 (let ((top (cddr (gnus-topic-find-topology | |
| 319 (gnus-topic-parent-topic topic))))) | |
| 320 (unless (equal topic (caaar top)) | |
| 321 (while (and top (not (equal (caaadr top) topic))) | |
| 322 (setq top (cdr top))) | |
| 323 (caaar top)))) | |
| 324 | |
| 325 (defun gnus-topic-parent-topic (topic &optional topology) | |
| 326 "Return the parent of TOPIC." | |
| 327 (unless topology | |
| 328 (setq topology gnus-topic-topology)) | |
| 329 (let ((parent (car (pop topology))) | |
| 330 result found) | |
| 331 (while (and topology | |
| 332 (not (setq found (equal (caaar topology) topic))) | |
| 333 (not (setq result (gnus-topic-parent-topic topic | |
| 334 (car topology))))) | |
| 335 (setq topology (cdr topology))) | |
| 336 (or result (and found parent)))) | |
| 337 | |
| 338 (defun gnus-topic-next-topic (topic &optional previous) | |
| 339 "Return the next sibling of TOPIC." | |
| 340 (let ((topology gnus-topic-topology) | |
| 341 (parentt (cddr (gnus-topic-find-topology | |
| 342 (gnus-topic-parent-topic topic)))) | |
| 343 prev) | |
| 344 (while (and parentt | |
| 345 (not (equal (caaar parentt) topic))) | |
| 346 (setq prev (caaar parentt) | |
| 347 parentt (cdr parentt))) | |
| 348 (if previous | |
| 349 prev | |
| 350 (caaadr parentt)))) | |
| 351 | |
| 352 (defun gnus-topic-find-topology (topic &optional topology level remove) | |
| 353 "Return the topology of TOPIC." | |
| 354 (unless topology | |
| 355 (setq topology gnus-topic-topology) | |
| 356 (setq level 0)) | |
| 357 (let ((top topology) | |
| 358 result) | |
| 359 (if (equal (caar topology) topic) | |
| 360 (progn | |
| 361 (when remove | |
| 362 (delq topology remove)) | |
| 363 (cons level topology)) | |
| 364 (setq topology (cdr topology)) | |
| 365 (while (and topology | |
| 366 (not (setq result (gnus-topic-find-topology | |
| 367 topic (car topology) (1+ level) | |
| 368 (and remove top))))) | |
| 369 (setq topology (cdr topology))) | |
| 370 result))) | |
| 371 | |
| 372 (gnus-add-shutdown 'gnus-topic-close 'gnus) | |
| 373 | |
| 374 (defun gnus-topic-close () | |
| 375 (setq gnus-topic-active-topology nil | |
| 376 gnus-topic-active-alist nil | |
| 377 gnus-topic-killed-topics nil | |
| 378 gnus-topic-tallied-groups nil | |
| 379 gnus-topology-checked-p nil)) | |
| 380 | |
| 381 (defun gnus-topic-check-topology () | |
| 382 ;; The first time we set the topology to whatever we have | |
| 383 ;; gotten here, which can be rather random. | |
| 384 (unless gnus-topic-alist | |
| 385 (gnus-topic-init-alist)) | |
| 386 | |
| 387 (setq gnus-topology-checked-p t) | |
| 388 (let ((topics (gnus-topic-list)) | |
| 389 (alist gnus-topic-alist) | |
| 390 changed) | |
| 391 (while alist | |
| 392 (unless (member (caar alist) topics) | |
| 393 (nconc gnus-topic-topology | |
| 394 (list (list (list (caar alist) 'visible)))) | |
| 395 (setq changed t)) | |
| 396 (setq alist (cdr alist))) | |
| 397 (when changed | |
| 398 (gnus-topic-enter-dribble))) | |
| 399 (let* ((tgroups (apply 'append (mapcar (lambda (entry) (cdr entry)) | |
| 400 gnus-topic-alist))) | |
| 401 (entry (assoc (caar gnus-topic-topology) gnus-topic-alist)) | |
| 402 (newsrc gnus-newsrc-alist) | |
| 403 group) | |
| 404 (while newsrc | |
| 405 (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups) | |
| 406 (setcdr entry (cons group (cdr entry))))))) | |
| 407 | |
| 408 (defvar gnus-tmp-topics nil) | |
| 409 (defun gnus-topic-list (&optional topology) | |
| 410 (unless topology | |
| 411 (setq topology gnus-topic-topology | |
| 412 gnus-tmp-topics nil)) | |
| 413 (push (caar topology) gnus-tmp-topics) | |
| 414 (mapcar 'gnus-topic-list (cdr topology)) | |
| 415 gnus-tmp-topics) | |
| 416 | |
| 417 (defun gnus-topic-enter-dribble () | |
| 418 (gnus-dribble-enter | |
| 419 (format "(setq gnus-topic-topology '%S)" gnus-topic-topology))) | |
| 420 | |
| 421 (defun gnus-topic-articles-in-topic (entries) | |
| 422 (let ((total 0) | |
| 423 number) | |
| 424 (while entries | |
| 425 (when (numberp (setq number (car (pop entries)))) | |
| 426 (incf total number))) | |
| 427 total)) | |
| 428 | |
| 429 (defun gnus-group-topic (group) | |
| 430 "Return the topic GROUP is a member of." | |
| 431 (let ((alist gnus-topic-alist) | |
| 432 out) | |
| 433 (while alist | |
| 434 (when (member group (cdar alist)) | |
| 435 (setq out (caar alist) | |
| 436 alist nil)) | |
| 437 (setq alist (cdr alist))) | |
| 438 out)) | |
| 439 | |
| 440 (defun gnus-topic-goto-topic (topic) | |
| 441 "Go to TOPIC." | |
| 442 (when topic | |
| 443 (gnus-goto-char (text-property-any (point-min) (point-max) | |
| 444 'gnus-topic (intern topic))))) | |
| 445 | |
| 446 (defun gnus-group-parent-topic () | |
| 447 "Return the name of the current topic." | |
| 448 (let ((result | |
| 449 (or (get-text-property (point) 'gnus-topic) | |
| 450 (save-excursion | |
| 451 (and (gnus-goto-char (previous-single-property-change | |
| 452 (point) 'gnus-topic)) | |
| 453 (get-text-property (max (1- (point)) (point-min)) | |
| 454 'gnus-topic)))))) | |
| 455 (when result | |
| 456 (symbol-name result)))) | |
| 457 | |
| 458 (defun gnus-topic-update-topic () | |
| 459 "Update all parent topics to the current group." | |
| 460 (when (and (eq major-mode 'gnus-group-mode) | |
| 461 gnus-topic-mode) | |
| 462 (let ((group (gnus-group-group-name)) | |
| 463 (buffer-read-only nil)) | |
| 464 (when (and group (gnus-get-info group) | |
| 465 (gnus-topic-goto-topic (gnus-group-parent-topic))) | |
| 466 (gnus-topic-update-topic-line (gnus-group-topic-name)) | |
| 467 (gnus-group-goto-group group) | |
| 468 (gnus-group-position-point))))) | |
| 469 | |
| 470 (defun gnus-topic-goto-missing-group (group) | |
| 471 "Place point where GROUP is supposed to be inserted." | |
| 472 (let* ((topic (gnus-group-topic group)) | |
| 473 (groups (cdr (assoc topic gnus-topic-alist))) | |
| 474 (g (cdr (member group groups))) | |
| 475 (unfound t)) | |
| 476 (while (and g unfound) | |
| 477 (when (gnus-group-goto-group (pop g)) | |
| 478 (beginning-of-line) | |
| 479 (setq unfound nil))) | |
| 480 (when unfound | |
| 481 (setq g (cdr (member group (reverse groups)))) | |
| 482 (while (and g unfound) | |
| 483 (when (gnus-group-goto-group (pop g)) | |
| 484 (forward-line 1) | |
| 485 (setq unfound nil))) | |
| 486 (when unfound | |
| 487 (gnus-topic-goto-topic topic) | |
| 488 (forward-line 1))))) | |
| 489 | |
| 490 (defun gnus-topic-update-topic-line (topic-name &optional reads) | |
| 491 (let* ((top (gnus-topic-find-topology topic-name)) | |
| 492 (type (cadr top)) | |
| 493 (children (cddr top)) | |
| 494 (entries (gnus-topic-find-groups | |
| 495 (car type) (car gnus-group-list-mode) | |
| 496 (cdr gnus-group-list-mode))) | |
| 497 (parent (gnus-topic-parent-topic topic-name)) | |
| 498 (all-entries entries) | |
| 499 (unread 0) | |
| 500 old-unread entry) | |
| 501 (when (gnus-topic-goto-topic (car type)) | |
| 502 ;; Tally all the groups that belong in this topic. | |
| 503 (if reads | |
| 504 (setq unread (- (gnus-group-topic-unread) reads)) | |
| 505 (while children | |
| 506 (incf unread (gnus-topic-unread (caar (pop children))))) | |
| 507 (while (setq entry (pop entries)) | |
| 508 (when (numberp (car entry)) | |
| 509 (incf unread (car entry))))) | |
| 510 (setq old-unread (gnus-group-topic-unread)) | |
| 511 ;; Insert the topic line. | |
| 512 (gnus-topic-insert-topic-line | |
| 513 (car type) (gnus-topic-visible-p) | |
| 514 (not (eq (nth 2 type) 'hidden)) | |
| 515 (gnus-group-topic-level) all-entries unread) | |
| 516 (gnus-delete-line)) | |
| 517 (when parent | |
| 518 (forward-line -1) | |
| 519 (gnus-topic-update-topic-line | |
| 520 parent (- old-unread (gnus-group-topic-unread)))) | |
| 521 unread)) | |
| 522 | |
| 523 (defun gnus-topic-grok-active (&optional force) | |
| 524 "Parse all active groups and create topic structures for them." | |
| 525 ;; First we make sure that we have really read the active file. | |
| 526 (when (or force | |
| 527 (not gnus-topic-active-alist)) | |
| 528 (let (groups) | |
| 529 ;; Get a list of all groups available. | |
| 530 (mapatoms (lambda (g) (when (symbol-value g) | |
| 531 (push (symbol-name g) groups))) | |
| 532 gnus-active-hashtb) | |
| 533 (setq groups (sort groups 'string<)) | |
| 534 ;; Init the variables. | |
| 535 (setq gnus-topic-active-topology (list (list "" 'visible))) | |
| 536 (setq gnus-topic-active-alist nil) | |
| 537 ;; Descend the top-level hierarchy. | |
| 538 (gnus-topic-grok-active-1 gnus-topic-active-topology groups) | |
| 539 ;; Set the top-level topic names to something nice. | |
| 540 (setcar (car gnus-topic-active-topology) "Gnus active") | |
| 541 (setcar (car gnus-topic-active-alist) "Gnus active")))) | |
| 542 | |
| 543 (defun gnus-topic-grok-active-1 (topology groups) | |
| 544 (let* ((name (caar topology)) | |
| 545 (prefix (concat "^" (regexp-quote name))) | |
| 546 tgroups ntopology group) | |
| 547 (while (and groups | |
| 548 (string-match prefix (setq group (car groups)))) | |
| 549 (if (not (string-match "\\." group (match-end 0))) | |
| 550 ;; There are no further hierarchies here, so we just | |
| 551 ;; enter this group into the list belonging to this | |
| 552 ;; topic. | |
| 553 (push (pop groups) tgroups) | |
| 554 ;; New sub-hierarchy, so we add it to the topology. | |
| 555 (nconc topology (list (setq ntopology | |
| 556 (list (list (substring | |
| 557 group 0 (match-end 0)) | |
| 558 'invisible))))) | |
| 559 ;; Descend the hierarchy. | |
| 560 (setq groups (gnus-topic-grok-active-1 ntopology groups)))) | |
| 561 ;; We remove the trailing "." from the topic name. | |
| 562 (setq name | |
| 563 (if (string-match "\\.$" name) | |
| 564 (substring name 0 (match-beginning 0)) | |
| 565 name)) | |
| 566 ;; Add this topic and its groups to the topic alist. | |
| 567 (push (cons name (nreverse tgroups)) gnus-topic-active-alist) | |
| 568 (setcar (car topology) name) | |
| 569 ;; We return the rest of the groups that didn't belong | |
| 570 ;; to this topic. | |
| 571 groups)) | |
| 572 | |
| 573 (defun gnus-group-active-topic-p () | |
| 574 "Return whether the current active comes from the active topics." | |
| 575 (save-excursion | |
| 576 (beginning-of-line) | |
| 577 (get-text-property (point) 'gnus-active))) | |
| 578 | |
| 579 ;;; Topic mode, commands and keymap. | |
| 580 | |
| 581 (defvar gnus-topic-mode-map nil) | |
| 582 (defvar gnus-group-topic-map nil) | |
| 583 | |
| 584 (unless gnus-topic-mode-map | |
| 585 (setq gnus-topic-mode-map (make-sparse-keymap)) | |
| 586 | |
| 587 ;; Override certain group mode keys. | |
| 588 (gnus-define-keys | |
| 589 gnus-topic-mode-map | |
| 590 "=" gnus-topic-select-group | |
| 591 "\r" gnus-topic-select-group | |
| 592 " " gnus-topic-read-group | |
| 593 "\C-k" gnus-topic-kill-group | |
| 594 "\C-y" gnus-topic-yank-group | |
| 595 "\M-g" gnus-topic-get-new-news-this-topic | |
| 596 "AT" gnus-topic-list-active | |
| 597 gnus-mouse-2 gnus-mouse-pick-topic) | |
| 598 | |
| 599 ;; Define a new submap. | |
| 600 (gnus-define-keys | |
| 601 (gnus-group-topic-map "T" gnus-group-mode-map) | |
| 602 "#" gnus-topic-mark-topic | |
| 603 "\M-#" gnus-topic-unmark-topic | |
| 604 "n" gnus-topic-create-topic | |
| 605 "m" gnus-topic-move-group | |
| 606 "D" gnus-topic-remove-group | |
| 607 "c" gnus-topic-copy-group | |
| 608 "h" gnus-topic-hide-topic | |
| 609 "s" gnus-topic-show-topic | |
| 610 "M" gnus-topic-move-matching | |
| 611 "C" gnus-topic-copy-matching | |
| 612 "\C-i" gnus-topic-indent | |
| 613 [tab] gnus-topic-indent | |
| 614 "r" gnus-topic-rename | |
| 615 "\177" gnus-topic-delete)) | |
| 616 | |
| 617 (defun gnus-topic-make-menu-bar () | |
| 618 (unless (boundp 'gnus-topic-menu) | |
| 619 (easy-menu-define | |
| 620 gnus-topic-menu gnus-topic-mode-map "" | |
| 621 '("Topics" | |
| 622 ["Toggle topics" gnus-topic-mode t] | |
| 623 ("Groups" | |
| 624 ["Copy" gnus-topic-copy-group t] | |
| 625 ["Move" gnus-topic-move-group t] | |
| 626 ["Remove" gnus-topic-remove-group t] | |
| 627 ["Copy matching" gnus-topic-copy-matching t] | |
| 628 ["Move matching" gnus-topic-move-matching t]) | |
| 629 ("Topics" | |
| 630 ["Show" gnus-topic-show-topic t] | |
| 631 ["Hide" gnus-topic-hide-topic t] | |
| 632 ["Delete" gnus-topic-delete t] | |
| 633 ["Rename" gnus-topic-rename t] | |
| 634 ["Create" gnus-topic-create-topic t] | |
| 635 ["Mark" gnus-topic-mark-topic t] | |
| 636 ["Indent" gnus-topic-indent t]) | |
| 637 ["List active" gnus-topic-list-active t])))) | |
| 638 | |
| 639 (defun gnus-topic-mode (&optional arg redisplay) | |
| 640 "Minor mode for topicsifying Gnus group buffers." | |
| 641 (interactive (list current-prefix-arg t)) | |
| 642 (when (eq major-mode 'gnus-group-mode) | |
| 643 (make-local-variable 'gnus-topic-mode) | |
| 644 (setq gnus-topic-mode | |
| 645 (if (null arg) (not gnus-topic-mode) | |
| 646 (> (prefix-numeric-value arg) 0))) | |
| 647 ;; Infest Gnus with topics. | |
| 648 (when gnus-topic-mode | |
| 649 (when (and menu-bar-mode | |
| 650 (gnus-visual-p 'topic-menu 'menu)) | |
| 651 (gnus-topic-make-menu-bar)) | |
| 652 (setq gnus-topic-line-format-spec | |
| 653 (gnus-parse-format gnus-topic-line-format | |
| 654 gnus-topic-line-format-alist t)) | |
| 655 (unless (assq 'gnus-topic-mode minor-mode-alist) | |
| 656 (push '(gnus-topic-mode " Topic") minor-mode-alist)) | |
| 657 (unless (assq 'gnus-topic-mode minor-mode-map-alist) | |
| 658 (push (cons 'gnus-topic-mode gnus-topic-mode-map) | |
| 659 minor-mode-map-alist)) | |
| 660 (add-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) | |
| 661 (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic) | |
| 662 (add-hook 'gnus-group-update-group-hook 'gnus-topic-update-topic) | |
| 663 (make-local-variable 'gnus-group-prepare-function) | |
| 664 (setq gnus-group-prepare-function 'gnus-group-prepare-topics) | |
| 665 (make-local-variable 'gnus-group-goto-next-group-function) | |
| 666 (setq gnus-group-goto-next-group-function | |
| 667 'gnus-topic-goto-next-group) | |
| 668 (setq gnus-group-change-level-function 'gnus-topic-change-level) | |
| 669 (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group) | |
| 670 (make-local-variable 'gnus-group-indentation-function) | |
| 671 (setq gnus-group-indentation-function | |
| 672 'gnus-topic-group-indentation) | |
| 673 (setq gnus-topology-checked-p nil) | |
| 674 ;; We check the topology. | |
| 675 (when gnus-newsrc-alist | |
| 676 (gnus-topic-check-topology)) | |
| 677 (run-hooks 'gnus-topic-mode-hook)) | |
| 678 ;; Remove topic infestation. | |
| 679 (unless gnus-topic-mode | |
| 680 (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) | |
| 681 (remove-hook 'gnus-group-change-level-function | |
| 682 'gnus-topic-change-level) | |
| 683 (setq gnus-group-prepare-function 'gnus-group-prepare-flat)) | |
| 684 (when redisplay | |
| 685 (gnus-group-list-groups)))) | |
| 686 | |
| 687 (defun gnus-topic-select-group (&optional all) | |
| 688 "Select this newsgroup. | |
| 689 No article is selected automatically. | |
| 690 If ALL is non-nil, already read articles become readable. | |
| 691 If ALL is a number, fetch this number of articles." | |
| 692 (interactive "P") | |
| 693 (if (gnus-group-topic-p) | |
| 694 (let ((gnus-group-list-mode | |
| 695 (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode))) | |
| 696 (gnus-topic-fold all)) | |
| 697 (gnus-group-select-group all))) | |
| 698 | |
| 699 (defun gnus-mouse-pick-topic (e) | |
| 700 "Select the group or topic under the mouse pointer." | |
| 701 (interactive "e") | |
| 702 (mouse-set-point e) | |
| 703 (gnus-topic-read-group nil)) | |
| 704 | |
| 705 (defun gnus-topic-read-group (&optional all no-article group) | |
| 706 "Read news in this newsgroup. | |
| 707 If the prefix argument ALL is non-nil, already read articles become | |
| 708 readable. IF ALL is a number, fetch this number of articles. If the | |
| 709 optional argument NO-ARTICLE is non-nil, no article will be | |
| 710 auto-selected upon group entry. If GROUP is non-nil, fetch that | |
| 711 group." | |
| 712 (interactive "P") | |
| 713 (if (gnus-group-topic-p) | |
| 714 (let ((gnus-group-list-mode | |
| 715 (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode))) | |
| 716 (gnus-topic-fold all)) | |
| 717 (gnus-group-read-group all no-article group))) | |
| 718 | |
| 719 (defun gnus-topic-create-topic (topic parent &optional previous full-topic) | |
| 720 (interactive | |
| 721 (list | |
| 722 (read-string "New topic: ") | |
| 723 (gnus-group-parent-topic))) | |
| 724 ;; Check whether this topic already exists. | |
| 725 (when (gnus-topic-find-topology topic) | |
| 726 (error "Topic aleady exists")) | |
| 727 (unless parent | |
| 728 (setq parent (caar gnus-topic-topology))) | |
| 729 (let ((top (cdr (gnus-topic-find-topology parent))) | |
| 730 (full-topic (or full-topic `((,topic visible))))) | |
| 731 (unless top | |
| 732 (error "No such parent topic: %s" parent)) | |
| 733 (if previous | |
| 734 (progn | |
| 735 (while (and (cdr top) | |
| 736 (not (equal (caaadr top) previous))) | |
| 737 (setq top (cdr top))) | |
| 738 (setcdr top (cons full-topic (cdr top)))) | |
| 739 (nconc top (list full-topic))) | |
| 740 (unless (assoc topic gnus-topic-alist) | |
| 741 (push (list topic) gnus-topic-alist))) | |
| 742 (gnus-topic-enter-dribble) | |
| 743 (gnus-group-list-groups) | |
| 744 (gnus-topic-goto-topic topic)) | |
| 745 | |
| 746 (defun gnus-topic-move-group (n topic &optional copyp) | |
| 747 "Move the next N groups to TOPIC. | |
| 748 If COPYP, copy the groups instead." | |
| 749 (interactive | |
| 750 (list current-prefix-arg | |
| 751 (completing-read "Move to topic: " gnus-topic-alist nil t))) | |
| 752 (let ((groups (gnus-group-process-prefix n)) | |
| 753 (topicl (assoc topic gnus-topic-alist)) | |
| 754 entry) | |
| 755 (mapcar (lambda (g) | |
| 756 (gnus-group-remove-mark g) | |
| 757 (when (and | |
| 758 (setq entry (assoc (gnus-group-parent-topic) | |
| 759 gnus-topic-alist)) | |
| 760 (not copyp)) | |
| 761 (setcdr entry (gnus-delete-first g (cdr entry)))) | |
| 762 (nconc topicl (list g))) | |
| 763 groups) | |
| 764 (gnus-group-position-point)) | |
| 765 (gnus-topic-enter-dribble) | |
| 766 (gnus-group-list-groups)) | |
| 767 | |
| 768 (defun gnus-topic-remove-group () | |
| 769 "Remove the current group from the topic." | |
| 770 (interactive) | |
| 771 (let ((topicl (assoc (gnus-group-parent-topic) gnus-topic-alist)) | |
| 772 (group (gnus-group-group-name)) | |
| 773 (buffer-read-only nil)) | |
| 774 (when (and topicl group) | |
| 775 (gnus-delete-line) | |
| 776 (gnus-delete-first group topicl)) | |
| 777 (gnus-group-position-point))) | |
| 778 | |
| 779 (defun gnus-topic-copy-group (n topic) | |
| 780 "Copy the current group to a topic." | |
| 781 (interactive | |
| 782 (list current-prefix-arg | |
| 783 (completing-read "Copy to topic: " gnus-topic-alist nil t))) | |
| 784 (gnus-topic-move-group n topic t)) | |
| 785 | |
| 786 (defun gnus-topic-group-indentation () | |
| 787 (make-string | |
| 788 (* gnus-topic-indent-level | |
| 789 (or (save-excursion | |
| 790 (gnus-topic-goto-topic (gnus-group-parent-topic)) | |
| 791 (gnus-group-topic-level)) 0)) ? )) | |
| 792 | |
| 793 (defun gnus-topic-change-level (group level oldlevel) | |
| 794 "Run when changing levels to enter/remove groups from topics." | |
| 795 (save-excursion | |
| 796 (set-buffer gnus-group-buffer) | |
| 797 (when (and gnus-topic-mode | |
| 798 gnus-topic-alist | |
| 799 (not gnus-topic-inhibit-change-level)) | |
| 800 ;; Remove the group from the topics. | |
| 801 (when (and (< oldlevel gnus-level-zombie) | |
| 802 (>= level gnus-level-zombie)) | |
| 803 (let (alist) | |
| 804 (forward-line -1) | |
| 805 (when (setq alist (assoc (gnus-group-parent-topic) gnus-topic-alist)) | |
| 806 (setcdr alist (gnus-delete-first group (cdr alist)))))) | |
| 807 ;; If the group is subscribed. then we enter it into the topics. | |
| 808 (when (and (< level gnus-level-zombie) | |
| 809 (>= oldlevel gnus-level-zombie)) | |
| 810 (let* ((prev (gnus-group-group-name)) | |
| 811 (gnus-topic-inhibit-change-level t) | |
| 812 (gnus-group-indentation | |
| 813 (make-string | |
| 814 (* gnus-topic-indent-level | |
| 815 (or (save-excursion | |
| 816 (gnus-topic-goto-topic (gnus-group-parent-topic)) | |
| 817 (gnus-group-topic-level)) 0)) ? )) | |
| 818 (yanked (list group)) | |
| 819 alist talist end) | |
| 820 ;; Then we enter the yanked groups into the topics they belong | |
| 821 ;; to. | |
| 822 (when (setq alist (assoc (save-excursion | |
| 823 (forward-line -1) | |
| 824 (or | |
| 825 (gnus-group-parent-topic) | |
| 826 (caar gnus-topic-topology))) | |
| 827 gnus-topic-alist)) | |
| 828 (setq talist alist) | |
| 829 (when (stringp yanked) | |
| 830 (setq yanked (list yanked))) | |
| 831 (if (not prev) | |
| 832 (nconc alist yanked) | |
| 833 (if (not (cdr alist)) | |
| 834 (setcdr alist (nconc yanked (cdr alist))) | |
| 835 (while (and (not end) (cdr alist)) | |
| 836 (when (equal (cadr alist) prev) | |
| 837 (setcdr alist (nconc yanked (cdr alist))) | |
| 838 (setq end t)) | |
| 839 (setq alist (cdr alist))) | |
| 840 (unless end | |
| 841 (nconc talist yanked)))))) | |
| 842 (gnus-topic-update-topic))))) | |
| 843 | |
| 844 (defun gnus-topic-goto-next-group (group props) | |
| 845 "Go to group or the next group after group." | |
| 846 (if (null group) | |
| 847 (gnus-topic-goto-topic (symbol-name (cadr (memq 'gnus-topic props)))) | |
| 848 (if (gnus-group-goto-group group) | |
| 849 t | |
| 850 ;; The group is no longer visible. | |
| 851 (let* ((list (assoc (gnus-group-parent-topic) gnus-topic-alist)) | |
| 852 (after (cdr (member group (cdr list))))) | |
| 853 ;; First try to put point on a group after the current one. | |
| 854 (while (and after | |
| 855 (not (gnus-group-goto-group (car after)))) | |
| 856 (setq after (cdr after))) | |
| 857 ;; Then try to put point on a group before point. | |
| 858 (unless after | |
| 859 (setq after (cdr (member group (reverse (cdr list))))) | |
| 860 (while (and after | |
| 861 (not (gnus-group-goto-group (car after)))) | |
| 862 (setq after (cdr after)))) | |
| 863 ;; Finally, just put point on the topic. | |
| 864 (unless after | |
| 865 (gnus-topic-goto-topic (car list)) | |
| 866 (setq after nil)) | |
| 867 t)))) | |
| 868 | |
| 869 (defun gnus-topic-kill-group (&optional n discard) | |
| 870 "Kill the next N groups." | |
| 871 (interactive "P") | |
| 872 (if (gnus-group-topic-p) | |
| 873 (let ((topic (gnus-group-topic-name))) | |
| 874 (gnus-topic-remove-topic nil t) | |
| 875 (push (gnus-topic-find-topology topic nil nil gnus-topic-topology) | |
| 876 gnus-topic-killed-topics)) | |
| 877 (gnus-group-kill-group n discard) | |
| 878 (gnus-topic-update-topic))) | |
| 879 | |
| 880 (defun gnus-topic-yank-group (&optional arg) | |
| 881 "Yank the last topic." | |
| 882 (interactive "p") | |
| 883 (if gnus-topic-killed-topics | |
| 884 (let ((previous | |
| 885 (or (gnus-group-topic-name) | |
| 886 (gnus-topic-next-topic (gnus-group-parent-topic)))) | |
| 887 (item (cdr (pop gnus-topic-killed-topics)))) | |
| 888 (gnus-topic-create-topic | |
| 889 (caar item) (gnus-topic-parent-topic previous) previous | |
| 890 item) | |
| 891 (gnus-topic-goto-topic (caar item))) | |
| 892 (let* ((prev (gnus-group-group-name)) | |
| 893 (gnus-topic-inhibit-change-level t) | |
| 894 (gnus-group-indentation | |
| 895 (make-string | |
| 896 (* gnus-topic-indent-level | |
| 897 (or (save-excursion | |
| 898 (gnus-topic-goto-topic (gnus-group-parent-topic)) | |
| 899 (gnus-group-topic-level)) 0)) ? )) | |
| 900 yanked alist) | |
| 901 ;; We first yank the groups the normal way... | |
| 902 (setq yanked (gnus-group-yank-group arg)) | |
| 903 ;; Then we enter the yanked groups into the topics they belong | |
| 904 ;; to. | |
| 905 (setq alist (assoc (save-excursion | |
| 906 (forward-line -1) | |
| 907 (gnus-group-parent-topic)) | |
| 908 gnus-topic-alist)) | |
| 909 (when (stringp yanked) | |
| 910 (setq yanked (list yanked))) | |
| 911 (if (not prev) | |
| 912 (nconc alist yanked) | |
| 913 (if (not (cdr alist)) | |
| 914 (setcdr alist (nconc yanked (cdr alist))) | |
| 915 (while (cdr alist) | |
| 916 (when (equal (cadr alist) prev) | |
| 917 (setcdr alist (nconc yanked (cdr alist))) | |
| 918 (setq alist nil)) | |
| 919 (setq alist (cdr alist)))))) | |
| 920 (gnus-topic-update-topic))) | |
| 921 | |
| 922 (defun gnus-topic-hide-topic () | |
| 923 "Hide all subtopics under the current topic." | |
| 924 (interactive) | |
| 925 (when (gnus-group-parent-topic) | |
| 926 (gnus-topic-goto-topic (gnus-group-parent-topic)) | |
| 927 (gnus-topic-remove-topic nil nil 'hidden))) | |
| 928 | |
| 929 (defun gnus-topic-show-topic () | |
| 930 "Show the hidden topic." | |
| 931 (interactive) | |
| 932 (when (gnus-group-topic-p) | |
| 933 (gnus-topic-remove-topic t nil 'shown))) | |
| 934 | |
| 935 (defun gnus-topic-mark-topic (topic &optional unmark) | |
| 936 "Mark all groups in the topic with the process mark." | |
| 937 (interactive (list (gnus-group-parent-topic))) | |
| 938 (save-excursion | |
| 939 (let ((groups (gnus-topic-find-groups topic 9 t))) | |
| 940 (while groups | |
| 941 (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) | |
| 942 (gnus-info-group (nth 2 (pop groups)))))))) | |
| 943 | |
| 944 (defun gnus-topic-unmark-topic (topic &optional unmark) | |
| 945 "Remove the process mark from all groups in the topic." | |
| 946 (interactive (list (gnus-group-parent-topic))) | |
| 947 (gnus-topic-mark-topic topic t)) | |
| 948 | |
| 949 (defun gnus-topic-get-new-news-this-topic (&optional n) | |
| 950 "Check for new news in the current topic." | |
| 951 (interactive "P") | |
| 952 (if (not (gnus-group-topic-p)) | |
| 953 (gnus-group-get-new-news-this-group n) | |
| 954 (gnus-topic-mark-topic (gnus-group-topic-name)) | |
| 955 (gnus-group-get-new-news-this-group))) | |
| 956 | |
| 957 (defun gnus-topic-move-matching (regexp topic &optional copyp) | |
| 958 "Move all groups that match REGEXP to some topic." | |
| 959 (interactive | |
| 960 (let (topic) | |
| 961 (nreverse | |
| 962 (list | |
| 963 (setq topic (completing-read "Move to topic: " gnus-topic-alist nil t)) | |
| 964 (read-string (format "Move to %s (regexp): " topic)))))) | |
| 965 (gnus-group-mark-regexp regexp) | |
| 966 (gnus-topic-move-group nil topic copyp)) | |
| 967 | |
| 968 (defun gnus-topic-copy-matching (regexp topic &optional copyp) | |
| 969 "Copy all groups that match REGEXP to some topic." | |
| 970 (interactive | |
| 971 (let (topic) | |
| 972 (nreverse | |
| 973 (list | |
| 974 (setq topic (completing-read "Copy to topic: " gnus-topic-alist nil t)) | |
| 975 (read-string (format "Copy to %s (regexp): " topic)))))) | |
| 976 (gnus-topic-move-matching regexp topic t)) | |
| 977 | |
| 978 (defun gnus-topic-delete (topic) | |
| 979 "Delete a topic." | |
| 980 (interactive (list (gnus-group-topic-name))) | |
| 981 (unless topic | |
| 982 (error "No topic to be deleted")) | |
| 983 (let ((entry (assoc topic gnus-topic-alist)) | |
| 984 (buffer-read-only nil)) | |
| 985 (when (cdr entry) | |
| 986 (error "Topic not empty")) | |
| 987 ;; Delete if visible. | |
| 988 (when (gnus-topic-goto-topic topic) | |
| 989 (gnus-delete-line)) | |
| 990 ;; Remove from alist. | |
| 991 (setq gnus-topic-alist (delq entry gnus-topic-alist)) | |
| 992 ;; Remove from topology. | |
| 993 (gnus-topic-find-topology topic nil nil 'delete))) | |
| 994 | |
| 995 (defun gnus-topic-rename (old-name new-name) | |
| 996 "Rename a topic." | |
| 997 (interactive | |
| 998 (let ((topic (gnus-group-parent-topic))) | |
| 999 (list topic | |
| 1000 (read-string (format "Rename %s to: " topic))))) | |
| 1001 (let ((top (gnus-topic-find-topology old-name)) | |
| 1002 (entry (assoc old-name gnus-topic-alist))) | |
| 1003 (when top | |
| 1004 (setcar (cadr top) new-name)) | |
| 1005 (when entry | |
| 1006 (setcar entry new-name)) | |
| 1007 (gnus-group-list-groups))) | |
| 1008 | |
| 1009 (defun gnus-topic-indent (&optional unindent) | |
| 1010 "Indent a topic -- make it a sub-topic of the previous topic. | |
| 1011 If UNINDENT, remove an indentation." | |
| 1012 (interactive "P") | |
| 1013 (if unindent | |
| 1014 (gnus-topic-unindent) | |
| 1015 (let* ((topic (gnus-group-parent-topic)) | |
| 1016 (parent (gnus-topic-previous-topic topic))) | |
| 1017 (unless parent | |
| 1018 (error "Nothing to indent %s into" topic)) | |
| 1019 (when topic | |
| 1020 (gnus-topic-goto-topic topic) | |
| 1021 (gnus-topic-kill-group) | |
| 1022 (gnus-topic-create-topic | |
| 1023 topic parent nil (cdr (pop gnus-topic-killed-topics))) | |
| 1024 (or (gnus-topic-goto-topic topic) | |
| 1025 (gnus-topic-goto-topic parent)))))) | |
| 1026 | |
| 1027 (defun gnus-topic-unindent () | |
| 1028 "Unindent a topic." | |
| 1029 (interactive) | |
| 1030 (let* ((topic (gnus-group-parent-topic)) | |
| 1031 (parent (gnus-topic-parent-topic topic)) | |
| 1032 (grandparent (gnus-topic-parent-topic parent))) | |
| 1033 (unless grandparent | |
| 1034 (error "Nothing to indent %s into" topic)) | |
| 1035 (when topic | |
| 1036 (gnus-topic-goto-topic topic) | |
| 1037 (gnus-topic-kill-group) | |
| 1038 (gnus-topic-create-topic | |
| 1039 topic grandparent (gnus-topic-next-topic parent) | |
| 1040 (cdr (pop gnus-topic-killed-topics))) | |
| 1041 (gnus-topic-goto-topic topic)))) | |
| 1042 | |
| 1043 (defun gnus-topic-list-active (&optional force) | |
| 1044 "List all groups that Gnus knows about in a topicsified fashion. | |
| 1045 If FORCE, always re-read the active file." | |
| 1046 (interactive "P") | |
| 1047 (when force | |
| 1048 (gnus-get-killed-groups)) | |
| 1049 (gnus-topic-grok-active force) | |
| 1050 (let ((gnus-topic-topology gnus-topic-active-topology) | |
| 1051 (gnus-topic-alist gnus-topic-active-alist) | |
| 1052 gnus-killed-list gnus-zombie-list) | |
| 1053 (gnus-group-list-groups 9 nil 1))) | |
| 1054 | |
| 1055 (provide 'gnus-topic) | |
| 1056 | |
| 1057 ;;; gnus-topic.el ends here |