annotate lisp/gnus-topic.el @ 21616:b0387f13fc0a

(ange-ftp-tmp-name-template) [windows-nt]: Look for common temp directories. (ange-ftp-parse-netrc-group): Skip carriage returns. (ange-ftp-expand-file-name): Handle files with drive letters. (ange-ftp-write-region): Don't treat as unix. (ange-ftp-insert-file-contents): Determine file type by transfer mode. (ange-ftp-copy-file-internal): Don't treat as unix. (ange-ftp-file-name-all-completions): Handle Windows filenames. (file-name-handler-alist) [windows-nt]: Add patterns for name with drive letters. (ange-ftp-dired-call-process, ange-ftp-call-chmod): Use dired-chmod-program. (ange-ftp-disable-netrc-security-check) [windows-nt]: Disable by default. (ange-ftp-real-expand-file-name-actual): New function.

申鐃緒申     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 <[e-mail]>
申鐃緒申     5 ;;	Lars Magne Ingebrigtsen <[e-mail]>
申鐃緒申     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