Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-topic.el @ 30:ec9a17fef872 r19-15b98

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b98
author cvs
date Mon, 13 Aug 2007 08:52:29 +0200
parents 4103f0995bd7
children e04119814345
comparison
equal deleted inserted replaced
29:7976500f47f9 30:ec9a17fef872
197 (and (not (equal group "dummy.group")) 197 (and (not (equal group "dummy.group"))
198 active 198 active
199 (- (1+ (cdr active)) (car active)))) 199 (- (1+ (cdr active)) (car active))))
200 clevel (or (gnus-info-level info) 200 clevel (or (gnus-info-level info)
201 (if (member group gnus-zombie-list) 8 9)))) 201 (if (member group gnus-zombie-list) 8 9))))
202 (and 202 (and
203 unread ; nil means that the group is dead. 203 unread ; nil means that the group is dead.
204 (<= clevel level) 204 (<= clevel level)
205 (>= clevel lowest) ; Is inside the level we want. 205 (>= clevel lowest) ; Is inside the level we want.
206 (or all 206 (or all
207 (if (eq unread t) 207 (if (eq unread t)
234 (setq topology gnus-topic-topology)) 234 (setq topology gnus-topic-topology))
235 (let ((parent (car (pop topology))) 235 (let ((parent (car (pop topology)))
236 result found) 236 result found)
237 (while (and topology 237 (while (and topology
238 (not (setq found (equal (caaar topology) topic))) 238 (not (setq found (equal (caaar topology) topic)))
239 (not (setq result (gnus-topic-parent-topic topic 239 (not (setq result (gnus-topic-parent-topic topic
240 (car topology))))) 240 (car topology)))))
241 (setq topology (cdr topology))) 241 (setq topology (cdr topology)))
242 (or result (and found parent)))) 242 (or result (and found parent))))
243 243
244 (defun gnus-topic-next-topic (topic &optional previous) 244 (defun gnus-topic-next-topic (topic &optional previous)
245 "Return the next sibling of TOPIC." 245 "Return the next sibling of TOPIC."
246 (let ((parentt (cddr (gnus-topic-find-topology 246 (let ((parentt (cddr (gnus-topic-find-topology
247 (gnus-topic-parent-topic topic)))) 247 (gnus-topic-parent-topic topic))))
248 prev) 248 prev)
249 (while (and parentt 249 (while (and parentt
250 (not (equal (caaar parentt) topic))) 250 (not (equal (caaar parentt) topic)))
251 (setq prev (caaar parentt) 251 (setq prev (caaar parentt)
276 276
277 (defvar gnus-tmp-topics nil) 277 (defvar gnus-tmp-topics nil)
278 (defun gnus-topic-list (&optional topology) 278 (defun gnus-topic-list (&optional topology)
279 "Return a list of all topics in the topology." 279 "Return a list of all topics in the topology."
280 (unless topology 280 (unless topology
281 (setq topology gnus-topic-topology 281 (setq topology gnus-topic-topology
282 gnus-tmp-topics nil)) 282 gnus-tmp-topics nil))
283 (push (caar topology) gnus-tmp-topics) 283 (push (caar topology) gnus-tmp-topics)
284 (mapcar 'gnus-topic-list (cdr topology)) 284 (mapcar 'gnus-topic-list (cdr topology))
285 gnus-tmp-topics) 285 gnus-tmp-topics)
286 286
352 352
353 (when (or (not gnus-topic-alist) 353 (when (or (not gnus-topic-alist)
354 (not gnus-topology-checked-p)) 354 (not gnus-topology-checked-p))
355 (gnus-topic-check-topology)) 355 (gnus-topic-check-topology))
356 356
357 (unless list-topic 357 (unless list-topic
358 (erase-buffer)) 358 (erase-buffer))
359 359
360 ;; List dead groups? 360 ;; List dead groups?
361 (when (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie)) 361 (when (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie))
362 (gnus-group-prepare-flat-list-dead 362 (gnus-group-prepare-flat-list-dead
363 (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) 363 (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
364 gnus-level-zombie ?Z 364 gnus-level-zombie ?Z
365 regexp)) 365 regexp))
366 366
367 (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)) 367 (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed))
368 (gnus-group-prepare-flat-list-dead 368 (gnus-group-prepare-flat-list-dead
369 (setq gnus-killed-list (sort gnus-killed-list 'string<)) 369 (setq gnus-killed-list (sort gnus-killed-list 'string<))
370 gnus-level-killed ?K 370 gnus-level-killed ?K
371 regexp)) 371 regexp))
372 372
373 ;; Use topics. 373 ;; Use topics.
377 (let ((top (gnus-topic-find-topology list-topic))) 377 (let ((top (gnus-topic-find-topology list-topic)))
378 (gnus-topic-prepare-topic (cdr top) (car top) 378 (gnus-topic-prepare-topic (cdr top) (car top)
379 (or topic-level level) all)) 379 (or topic-level level) all))
380 (gnus-topic-prepare-topic gnus-topic-topology 0 380 (gnus-topic-prepare-topic gnus-topic-topology 0
381 (or topic-level level) all))) 381 (or topic-level level) all)))
382 382
383 (gnus-group-set-mode-line) 383 (gnus-group-set-mode-line)
384 (setq gnus-group-list-mode (cons level all)) 384 (setq gnus-group-list-mode (cons level all))
385 (run-hooks 'gnus-group-prepare-hook)))) 385 (run-hooks 'gnus-group-prepare-hook))))
386 386
387 (defun gnus-topic-prepare-topic (topicl level &optional list-level all silent) 387 (defun gnus-topic-prepare-topic (topicl level &optional list-level all silent)
389 If SILENT, don't insert anything. Return the number of unread 389 If SILENT, don't insert anything. Return the number of unread
390 articles in the topic and its subtopics." 390 articles in the topic and its subtopics."
391 (let* ((type (pop topicl)) 391 (let* ((type (pop topicl))
392 (entries (gnus-topic-find-groups (car type) list-level all)) 392 (entries (gnus-topic-find-groups (car type) list-level all))
393 (visiblep (and (eq (nth 1 type) 'visible) (not silent))) 393 (visiblep (and (eq (nth 1 type) 'visible) (not silent)))
394 (gnus-group-indentation 394 (gnus-group-indentation
395 (make-string (* gnus-topic-indent-level level) ? )) 395 (make-string (* gnus-topic-indent-level level) ? ))
396 (beg (progn (beginning-of-line) (point))) 396 (beg (progn (beginning-of-line) (point)))
397 (topicl (reverse topicl)) 397 (topicl (reverse topicl))
398 (all-entries entries) 398 (all-entries entries)
399 (point-max (point-max)) 399 (point-max (point-max))
401 (topic (car type)) 401 (topic (car type))
402 info entry end active tick) 402 info entry end active tick)
403 ;; Insert any sub-topics. 403 ;; Insert any sub-topics.
404 (while topicl 404 (while topicl
405 (incf unread 405 (incf unread
406 (gnus-topic-prepare-topic 406 (gnus-topic-prepare-topic
407 (pop topicl) (1+ level) list-level all 407 (pop topicl) (1+ level) list-level all
408 (not visiblep)))) 408 (not visiblep))))
409 (setq end (point)) 409 (setq end (point))
410 (goto-char beg) 410 (goto-char beg)
411 ;; Insert all the groups that belong in this topic. 411 ;; Insert all the groups that belong in this topic.
412 (while (setq entry (pop entries)) 412 (while (setq entry (pop entries))
413 (when visiblep 413 (when visiblep
414 (if (stringp entry) 414 (if (stringp entry)
415 ;; Dead groups. 415 ;; Dead groups.
416 (gnus-group-insert-group-line 416 (gnus-group-insert-group-line
417 entry (if (member entry gnus-zombie-list) 8 9) 417 entry (if (member entry gnus-zombie-list) 8 9)
418 nil (- (1+ (cdr (setq active (gnus-active entry)))) 418 nil (- (1+ (cdr (setq active (gnus-active entry))))
419 (car active)) 419 (car active))
420 nil) 420 nil)
421 ;; Living groups. 421 ;; Living groups.
422 (when (setq info (nth 2 entry)) 422 (when (setq info (nth 2 entry))
423 (gnus-group-insert-group-line 423 (gnus-group-insert-group-line
424 (gnus-info-group info) 424 (gnus-info-group info)
425 (gnus-info-level info) (gnus-info-marks info) 425 (gnus-info-level info) (gnus-info-marks info)
426 (car entry) (gnus-info-method info))))) 426 (car entry) (gnus-info-method info)))))
427 (when (and (listp entry) 427 (when (and (listp entry)
428 (numberp (car entry)) 428 (numberp (car entry))
435 (goto-char beg) 435 (goto-char beg)
436 ;; Insert the topic line. 436 ;; Insert the topic line.
437 (when (and (not silent) 437 (when (and (not silent)
438 (or gnus-topic-display-empty-topics ;We want empty topics 438 (or gnus-topic-display-empty-topics ;We want empty topics
439 (not (zerop unread)) ;Non-empty 439 (not (zerop unread)) ;Non-empty
440 tick ;Ticked articles 440 tick ;Ticked articles
441 (/= point-max (point-max)))) ;Unactivated groups 441 (/= point-max (point-max)))) ;Unactivated groups
442 (gnus-extent-start-open (point)) 442 (gnus-extent-start-open (point))
443 (gnus-topic-insert-topic-line 443 (gnus-topic-insert-topic-line
444 (car type) visiblep 444 (car type) visiblep
445 (not (eq (nth 2 type) 'hidden)) 445 (not (eq (nth 2 type) 'hidden))
446 level all-entries unread)) 446 level all-entries unread))
447 (goto-char end) 447 (goto-char end)
448 unread)) 448 unread))
471 (delq (assoc topic gnus-topic-alist) gnus-topic-alist)) 471 (delq (assoc topic gnus-topic-alist) gnus-topic-alist))
472 (gnus-topic-insert-topic topic in-level))))) 472 (gnus-topic-insert-topic topic in-level)))))
473 473
474 (defun gnus-topic-insert-topic (topic &optional level) 474 (defun gnus-topic-insert-topic (topic &optional level)
475 "Insert TOPIC." 475 "Insert TOPIC."
476 (gnus-group-prepare-topics 476 (gnus-group-prepare-topics
477 (car gnus-group-list-mode) (cdr gnus-group-list-mode) 477 (car gnus-group-list-mode) (cdr gnus-group-list-mode)
478 nil nil topic level)) 478 nil nil topic level))
479 479
480 (defun gnus-topic-fold (&optional insert) 480 (defun gnus-topic-fold (&optional insert)
481 "Remove/insert the current topic." 481 "Remove/insert the current topic."
482 (let ((topic (gnus-group-topic-name))) 482 (let ((topic (gnus-group-topic-name)))
483 (when topic 483 (when topic
484 (save-excursion 484 (save-excursion
490 (gnus-group-list-mode (cons 5 t))) 490 (gnus-group-list-mode (cons 5 t)))
491 (gnus-topic-remove-topic 491 (gnus-topic-remove-topic
492 (or insert (not (gnus-topic-visible-p))) nil nil 9) 492 (or insert (not (gnus-topic-visible-p))) nil nil 9)
493 (gnus-topic-enter-dribble))))))) 493 (gnus-topic-enter-dribble)))))))
494 494
495 (defun gnus-topic-insert-topic-line (name visiblep shownp level entries 495 (defun gnus-topic-insert-topic-line (name visiblep shownp level entries
496 &optional unread) 496 &optional unread)
497 (let* ((visible (if visiblep "" "...")) 497 (let* ((visible (if visiblep "" "..."))
498 (indentation (make-string (* gnus-topic-indent-level level) ? )) 498 (indentation (make-string (* gnus-topic-indent-level level) ? ))
499 (total-number-of-articles unread) 499 (total-number-of-articles unread)
500 (number-of-groups (length entries)) 500 (number-of-groups (length entries))
501 (active-topic (eq gnus-topic-alist gnus-topic-active-alist))) 501 (active-topic (eq gnus-topic-alist gnus-topic-active-alist)))
502 (beginning-of-line) 502 (beginning-of-line)
503 ;; Insert the text. 503 ;; Insert the text.
504 (gnus-add-text-properties 504 (gnus-add-text-properties
505 (point) 505 (point)
506 (prog1 (1+ (point)) 506 (prog1 (1+ (point))
507 (eval gnus-topic-line-format-spec) 507 (eval gnus-topic-line-format-spec)
508 (gnus-topic-remove-excess-properties)1) 508 (gnus-topic-remove-excess-properties)1)
509 (list 'gnus-topic (intern name) 509 (list 'gnus-topic (intern name)
532 "Update all parent topics to the current group." 532 "Update all parent topics to the current group."
533 (when (and (eq major-mode 'gnus-group-mode) 533 (when (and (eq major-mode 'gnus-group-mode)
534 gnus-topic-mode) 534 gnus-topic-mode)
535 (let ((group (gnus-group-group-name)) 535 (let ((group (gnus-group-group-name))
536 (buffer-read-only nil)) 536 (buffer-read-only nil))
537 (when (and group 537 (when (and group
538 (gnus-get-info group) 538 (gnus-get-info group)
539 (gnus-topic-goto-topic (gnus-current-topic))) 539 (gnus-topic-goto-topic (gnus-current-topic)))
540 (gnus-topic-update-topic-line (gnus-group-topic-name)) 540 (gnus-topic-update-topic-line (gnus-group-topic-name))
541 (gnus-group-goto-group group) 541 (gnus-group-goto-group group)
542 (gnus-group-position-point))))) 542 (gnus-group-position-point)))))
563 563
564 (defun gnus-topic-update-topic-line (topic-name &optional reads) 564 (defun gnus-topic-update-topic-line (topic-name &optional reads)
565 (let* ((top (gnus-topic-find-topology topic-name)) 565 (let* ((top (gnus-topic-find-topology topic-name))
566 (type (cadr top)) 566 (type (cadr top))
567 (children (cddr top)) 567 (children (cddr top))
568 (entries (gnus-topic-find-groups 568 (entries (gnus-topic-find-groups
569 (car type) (car gnus-group-list-mode) 569 (car type) (car gnus-group-list-mode)
570 (cdr gnus-group-list-mode))) 570 (cdr gnus-group-list-mode)))
571 (parent (gnus-topic-parent-topic topic-name)) 571 (parent (gnus-topic-parent-topic topic-name))
572 (all-entries entries) 572 (all-entries entries)
573 (unread 0) 573 (unread 0)
581 (while (setq entry (pop entries)) 581 (while (setq entry (pop entries))
582 (when (numberp (car entry)) 582 (when (numberp (car entry))
583 (incf unread (car entry))))) 583 (incf unread (car entry)))))
584 (setq old-unread (gnus-group-topic-unread)) 584 (setq old-unread (gnus-group-topic-unread))
585 ;; Insert the topic line. 585 ;; Insert the topic line.
586 (gnus-topic-insert-topic-line 586 (gnus-topic-insert-topic-line
587 (car type) (gnus-topic-visible-p) 587 (car type) (gnus-topic-visible-p)
588 (not (eq (nth 2 type) 'hidden)) 588 (not (eq (nth 2 type) 'hidden))
589 (gnus-group-topic-level) all-entries unread) 589 (gnus-group-topic-level) all-entries unread)
590 (gnus-delete-line)) 590 (gnus-delete-line))
591 (when parent 591 (when parent
593 (gnus-topic-update-topic-line 593 (gnus-topic-update-topic-line
594 parent (- old-unread (gnus-group-topic-unread)))) 594 parent (- old-unread (gnus-group-topic-unread))))
595 unread)) 595 unread))
596 596
597 (defun gnus-topic-group-indentation () 597 (defun gnus-topic-group-indentation ()
598 (make-string 598 (make-string
599 (* gnus-topic-indent-level 599 (* gnus-topic-indent-level
600 (or (save-excursion 600 (or (save-excursion
601 (forward-line -1) 601 (forward-line -1)
602 (gnus-topic-goto-topic (gnus-current-topic)) 602 (gnus-topic-goto-topic (gnus-current-topic))
603 (gnus-group-topic-level)) 603 (gnus-group-topic-level))
695 695
696 (defun gnus-topic-change-level (group level oldlevel) 696 (defun gnus-topic-change-level (group level oldlevel)
697 "Run when changing levels to enter/remove groups from topics." 697 "Run when changing levels to enter/remove groups from topics."
698 (save-excursion 698 (save-excursion
699 (set-buffer gnus-group-buffer) 699 (set-buffer gnus-group-buffer)
700 (when (and gnus-topic-mode 700 (when (and gnus-topic-mode
701 gnus-topic-alist 701 gnus-topic-alist
702 (not gnus-topic-inhibit-change-level)) 702 (not gnus-topic-inhibit-change-level))
703 ;; Remove the group from the topics. 703 ;; Remove the group from the topics.
704 (when (and (< oldlevel gnus-level-zombie) 704 (when (and (< oldlevel gnus-level-zombie)
705 (>= level gnus-level-zombie)) 705 (>= level gnus-level-zombie))
711 (when (and (< level gnus-level-zombie) 711 (when (and (< level gnus-level-zombie)
712 (>= oldlevel gnus-level-zombie)) 712 (>= oldlevel gnus-level-zombie))
713 (let* ((prev (gnus-group-group-name)) 713 (let* ((prev (gnus-group-group-name))
714 (gnus-topic-inhibit-change-level t) 714 (gnus-topic-inhibit-change-level t)
715 (gnus-group-indentation 715 (gnus-group-indentation
716 (make-string 716 (make-string
717 (* gnus-topic-indent-level 717 (* gnus-topic-indent-level
718 (or (save-excursion 718 (or (save-excursion
719 (gnus-topic-goto-topic (gnus-current-topic)) 719 (gnus-topic-goto-topic (gnus-current-topic))
720 (gnus-group-topic-level)) 720 (gnus-group-topic-level))
721 0)) 721 0))
722 ? )) 722 ? ))
723 (yanked (list group)) 723 (yanked (list group))
724 alist talist end) 724 alist talist end)
725 ;; Then we enter the yanked groups into the topics they belong 725 ;; Then we enter the yanked groups into the topics they belong
726 ;; to. 726 ;; to.
727 (when (setq alist (assoc (save-excursion 727 (when (setq alist (assoc (save-excursion
728 (forward-line -1) 728 (forward-line -1)
729 (or 729 (or
730 (gnus-current-topic) 730 (gnus-current-topic)
731 (caar gnus-topic-topology))) 731 (caar gnus-topic-topology)))
762 (not (gnus-group-goto-group (car after)))) 762 (not (gnus-group-goto-group (car after))))
763 (setq after (cdr after))) 763 (setq after (cdr after)))
764 ;; Then try to put point on a group before point. 764 ;; Then try to put point on a group before point.
765 (unless after 765 (unless after
766 (setq after (cdr (member group (reverse (cdr list))))) 766 (setq after (cdr (member group (reverse (cdr list)))))
767 (while (and after 767 (while (and after
768 (not (gnus-group-goto-group (car after)))) 768 (not (gnus-group-goto-group (car after))))
769 (setq after (cdr after)))) 769 (setq after (cdr after))))
770 ;; Finally, just put point on the topic. 770 ;; Finally, just put point on the topic.
771 (if (not (car list)) 771 (if (not (car list))
772 (goto-char (point-min)) 772 (goto-char (point-min))
777 777
778 ;;; Topic-active functions 778 ;;; Topic-active functions
779 779
780 (defun gnus-topic-grok-active (&optional force) 780 (defun gnus-topic-grok-active (&optional force)
781 "Parse all active groups and create topic structures for them." 781 "Parse all active groups and create topic structures for them."
782 ;; First we make sure that we have really read the active file. 782 ;; First we make sure that we have really read the active file.
783 (when (or force 783 (when (or force
784 (not gnus-topic-active-alist)) 784 (not gnus-topic-active-alist))
785 (let (groups) 785 (let (groups)
786 ;; Get a list of all groups available. 786 ;; Get a list of all groups available.
787 (mapatoms (lambda (g) (when (symbol-value g) 787 (mapatoms (lambda (g) (when (symbol-value g)
807 ;; There are no further hierarchies here, so we just 807 ;; There are no further hierarchies here, so we just
808 ;; enter this group into the list belonging to this 808 ;; enter this group into the list belonging to this
809 ;; topic. 809 ;; topic.
810 (push (pop groups) tgroups) 810 (push (pop groups) tgroups)
811 ;; New sub-hierarchy, so we add it to the topology. 811 ;; New sub-hierarchy, so we add it to the topology.
812 (nconc topology (list (setq ntopology 812 (nconc topology (list (setq ntopology
813 (list (list (substring 813 (list (list (substring
814 group 0 (match-end 0)) 814 group 0 (match-end 0))
815 'invisible))))) 815 'invisible)))))
816 ;; Descend the hierarchy. 816 ;; Descend the hierarchy.
817 (setq groups (gnus-topic-grok-active-1 ntopology groups)))) 817 (setq groups (gnus-topic-grok-active-1 ntopology groups))))
818 ;; We remove the trailing "." from the topic name. 818 ;; We remove the trailing "." from the topic name.
900 (defun gnus-topic-mode (&optional arg redisplay) 900 (defun gnus-topic-mode (&optional arg redisplay)
901 "Minor mode for topicsifying Gnus group buffers." 901 "Minor mode for topicsifying Gnus group buffers."
902 (interactive (list current-prefix-arg t)) 902 (interactive (list current-prefix-arg t))
903 (when (eq major-mode 'gnus-group-mode) 903 (when (eq major-mode 'gnus-group-mode)
904 (make-local-variable 'gnus-topic-mode) 904 (make-local-variable 'gnus-topic-mode)
905 (setq gnus-topic-mode 905 (setq gnus-topic-mode
906 (if (null arg) (not gnus-topic-mode) 906 (if (null arg) (not gnus-topic-mode)
907 (> (prefix-numeric-value arg) 0))) 907 (> (prefix-numeric-value arg) 0)))
908 ;; Infest Gnus with topics. 908 ;; Infest Gnus with topics.
909 (when gnus-topic-mode 909 (when gnus-topic-mode
910 (when (gnus-visual-p 'topic-menu 'menu) 910 (when (gnus-visual-p 'topic-menu 'menu)
911 (gnus-topic-make-menu-bar)) 911 (gnus-topic-make-menu-bar))
912 (setq gnus-topic-line-format-spec 912 (setq gnus-topic-line-format-spec
913 (gnus-parse-format gnus-topic-line-format 913 (gnus-parse-format gnus-topic-line-format
914 gnus-topic-line-format-alist t)) 914 gnus-topic-line-format-alist t))
915 (unless (assq 'gnus-topic-mode minor-mode-alist) 915 (unless (assq 'gnus-topic-mode minor-mode-alist)
916 (push '(gnus-topic-mode " Topic") minor-mode-alist)) 916 (push '(gnus-topic-mode " Topic") minor-mode-alist))
917 (unless (assq 'gnus-topic-mode minor-mode-map-alist) 917 (unless (assq 'gnus-topic-mode minor-mode-map-alist)
918 (push (cons 'gnus-topic-mode gnus-topic-mode-map) 918 (push (cons 'gnus-topic-mode gnus-topic-mode-map)
941 (gnus-topic-check-topology)) 941 (gnus-topic-check-topology))
942 (run-hooks 'gnus-topic-mode-hook)) 942 (run-hooks 'gnus-topic-mode-hook))
943 ;; Remove topic infestation. 943 ;; Remove topic infestation.
944 (unless gnus-topic-mode 944 (unless gnus-topic-mode
945 (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) 945 (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic)
946 (remove-hook 'gnus-group-change-level-function 946 (remove-hook 'gnus-group-change-level-function
947 'gnus-topic-change-level) 947 'gnus-topic-change-level)
948 (remove-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist) 948 (remove-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist)
949 (setq gnus-group-prepare-function 'gnus-group-prepare-flat) 949 (setq gnus-group-prepare-function 'gnus-group-prepare-flat)
950 (setq gnus-group-sort-alist-function 'gnus-group-sort-flat)) 950 (setq gnus-group-sort-alist-function 'gnus-group-sort-flat))
951 (when redisplay 951 (when redisplay
952 (gnus-group-list-groups)))) 952 (gnus-group-list-groups))))
953 953
954 (defun gnus-topic-select-group (&optional all) 954 (defun gnus-topic-select-group (&optional all)
955 "Select this newsgroup. 955 "Select this newsgroup.
956 No article is selected automatically. 956 No article is selected automatically.
957 If ALL is non-nil, already read articles become readable. 957 If ALL is non-nil, already read articles become readable.
958 If ALL is a number, fetch this number of articles. 958 If ALL is a number, fetch this number of articles.
959 959
960 If performed over a topic line, toggle folding the topic." 960 If performed over a topic line, toggle folding the topic."
961 (interactive "P") 961 (interactive "P")
962 (if (gnus-group-topic-p) 962 (if (gnus-group-topic-p)
963 (let ((gnus-group-list-mode 963 (let ((gnus-group-list-mode
964 (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode))) 964 (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
965 (gnus-topic-fold all)) 965 (gnus-topic-fold all))
966 (gnus-group-select-group all))) 966 (gnus-group-select-group all)))
967 967
968 (defun gnus-mouse-pick-topic (e) 968 (defun gnus-mouse-pick-topic (e)
980 group. 980 group.
981 981
982 If performed over a topic line, toggle folding the topic." 982 If performed over a topic line, toggle folding the topic."
983 (interactive "P") 983 (interactive "P")
984 (if (gnus-group-topic-p) 984 (if (gnus-group-topic-p)
985 (let ((gnus-group-list-mode 985 (let ((gnus-group-list-mode
986 (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode))) 986 (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
987 (gnus-topic-fold all)) 987 (gnus-topic-fold all))
988 (gnus-group-read-group all no-article group))) 988 (gnus-group-read-group all no-article group)))
989 989
990 (defun gnus-topic-create-topic (topic parent &optional previous full-topic) 990 (defun gnus-topic-create-topic (topic parent &optional previous full-topic)
991 (interactive 991 (interactive
992 (list 992 (list
993 (read-string "New topic: ") 993 (read-string "New topic: ")
994 (gnus-current-topic))) 994 (gnus-current-topic)))
995 ;; Check whether this topic already exists. 995 ;; Check whether this topic already exists.
996 (when (gnus-topic-find-topology topic) 996 (when (gnus-topic-find-topology topic)
1023 (let ((groups (gnus-group-process-prefix n)) 1023 (let ((groups (gnus-group-process-prefix n))
1024 (topicl (assoc topic gnus-topic-alist)) 1024 (topicl (assoc topic gnus-topic-alist))
1025 (start-group (progn (forward-line 1) (gnus-group-group-name))) 1025 (start-group (progn (forward-line 1) (gnus-group-group-name)))
1026 (start-topic (gnus-group-topic-name)) 1026 (start-topic (gnus-group-topic-name))
1027 entry) 1027 entry)
1028 (mapcar 1028 (mapcar
1029 (lambda (g) 1029 (lambda (g)
1030 (gnus-group-remove-mark g) 1030 (gnus-group-remove-mark g)
1031 (when (and 1031 (when (and
1032 (setq entry (assoc (gnus-current-topic) gnus-topic-alist)) 1032 (setq entry (assoc (gnus-current-topic) gnus-topic-alist))
1033 (not copyp)) 1033 (not copyp))
1041 (gnus-group-list-groups))) 1041 (gnus-group-list-groups)))
1042 1042
1043 (defun gnus-topic-remove-group (&optional arg) 1043 (defun gnus-topic-remove-group (&optional arg)
1044 "Remove the current group from the topic." 1044 "Remove the current group from the topic."
1045 (interactive "P") 1045 (interactive "P")
1046 (gnus-group-iterate arg 1046 (gnus-group-iterate arg
1047 (lambda (group) 1047 (lambda (group)
1048 (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist)) 1048 (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist))
1049 (buffer-read-only nil)) 1049 (buffer-read-only nil))
1050 (when (and topicl group) 1050 (when (and topicl group)
1051 (gnus-delete-line) 1051 (gnus-delete-line)
1063 (defun gnus-topic-kill-group (&optional n discard) 1063 (defun gnus-topic-kill-group (&optional n discard)
1064 "Kill the next N groups." 1064 "Kill the next N groups."
1065 (interactive "P") 1065 (interactive "P")
1066 (if (gnus-group-topic-p) 1066 (if (gnus-group-topic-p)
1067 (let ((topic (gnus-group-topic-name))) 1067 (let ((topic (gnus-group-topic-name)))
1068 (push (cons 1068 (push (cons
1069 (gnus-topic-find-topology topic) 1069 (gnus-topic-find-topology topic)
1070 (assoc topic gnus-topic-alist)) 1070 (assoc topic gnus-topic-alist))
1071 gnus-topic-killed-topics) 1071 gnus-topic-killed-topics)
1072 (gnus-topic-remove-topic nil t) 1072 (gnus-topic-remove-topic nil t)
1073 (gnus-topic-find-topology topic nil nil gnus-topic-topology) 1073 (gnus-topic-find-topology topic nil nil gnus-topic-topology)
1074 (gnus-topic-enter-dribble)) 1074 (gnus-topic-enter-dribble))
1075 (gnus-group-kill-group n discard) 1075 (gnus-group-kill-group n discard)
1076 (gnus-topic-update-topic))) 1076 (gnus-topic-update-topic)))
1077 1077
1078 (defun gnus-topic-yank-group (&optional arg) 1078 (defun gnus-topic-yank-group (&optional arg)
1079 "Yank the last topic." 1079 "Yank the last topic."
1080 (interactive "p") 1080 (interactive "p")
1081 (if gnus-topic-killed-topics 1081 (if gnus-topic-killed-topics
1082 (let* ((previous 1082 (let* ((previous
1083 (or (gnus-group-topic-name) 1083 (or (gnus-group-topic-name)
1084 (gnus-topic-next-topic (gnus-current-topic)))) 1084 (gnus-topic-next-topic (gnus-current-topic))))
1085 (data (pop gnus-topic-killed-topics)) 1085 (data (pop gnus-topic-killed-topics))
1086 (alist (cdr data)) 1086 (alist (cdr data))
1087 (item (cdar data))) 1087 (item (cdar data)))
1092 (gnus-topic-enter-dribble) 1092 (gnus-topic-enter-dribble)
1093 (gnus-topic-goto-topic (caar item))) 1093 (gnus-topic-goto-topic (caar item)))
1094 (let* ((prev (gnus-group-group-name)) 1094 (let* ((prev (gnus-group-group-name))
1095 (gnus-topic-inhibit-change-level t) 1095 (gnus-topic-inhibit-change-level t)
1096 (gnus-group-indentation 1096 (gnus-group-indentation
1097 (make-string 1097 (make-string
1098 (* gnus-topic-indent-level 1098 (* gnus-topic-indent-level
1099 (or (save-excursion 1099 (or (save-excursion
1100 (gnus-topic-goto-topic (gnus-current-topic)) 1100 (gnus-topic-goto-topic (gnus-current-topic))
1101 (gnus-group-topic-level)) 1101 (gnus-group-topic-level))
1102 0)) 1102 0))
1103 ? )) 1103 ? ))
1104 yanked alist) 1104 yanked alist)
1105 ;; We first yank the groups the normal way... 1105 ;; We first yank the groups the normal way...
1106 (setq yanked (gnus-group-yank-group arg)) 1106 (setq yanked (gnus-group-yank-group arg))
1107 ;; Then we enter the yanked groups into the topics they belong 1107 ;; Then we enter the yanked groups into the topics they belong
1108 ;; to. 1108 ;; to.
1109 (setq alist (assoc (save-excursion 1109 (setq alist (assoc (save-excursion
1110 (forward-line -1) 1110 (forward-line -1)
1111 (gnus-current-topic)) 1111 (gnus-current-topic))
1112 gnus-topic-alist)) 1112 gnus-topic-alist))
1113 (when (stringp yanked) 1113 (when (stringp yanked)
1208 (read-string (format "Rename %s to: " topic))))) 1208 (read-string (format "Rename %s to: " topic)))))
1209 (let ((top (gnus-topic-find-topology old-name)) 1209 (let ((top (gnus-topic-find-topology old-name))
1210 (entry (assoc old-name gnus-topic-alist))) 1210 (entry (assoc old-name gnus-topic-alist)))
1211 (when top 1211 (when top
1212 (setcar (cadr top) new-name)) 1212 (setcar (cadr top) new-name))
1213 (when entry 1213 (when entry
1214 (setcar entry new-name)) 1214 (setcar entry new-name))
1215 (forward-line -1) 1215 (forward-line -1)
1216 (gnus-dribble-touch) 1216 (gnus-dribble-touch)
1217 (gnus-group-list-groups))) 1217 (gnus-group-list-groups)))
1218 1218