Mercurial > hg > xemacs-beta
comparison lisp/gnus/gnus-topic.el @ 98:0d2f883870bc r20-1b1
Import from CVS: tag r20-1b1
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 09:13:56 +0200 |
| parents | 131b0175ea99 |
| children | 4be1180a9e89 |
comparison
equal
deleted
inserted
replaced
| 97:498bf5da1c90 | 98:0d2f883870bc |
|---|---|
| 1 ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers | 1 ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers |
| 2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc. | 2 ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. |
| 3 | 3 |
| 4 ;; Author: Ilja Weis <kult@uni-paderborn.de> | 4 ;; Author: Ilja Weis <kult@uni-paderborn.de> |
| 5 ;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> | 5 ;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> |
| 6 ;; Keywords: news | 6 ;; Keywords: news |
| 7 | 7 |
| 25 ;;; Commentary: | 25 ;;; Commentary: |
| 26 | 26 |
| 27 ;;; Code: | 27 ;;; Code: |
| 28 | 28 |
| 29 (require 'gnus) | 29 (require 'gnus) |
| 30 (eval-when-compile (require 'cl)) | 30 (require 'gnus-group) |
| 31 (require 'gnus-start) | |
| 32 | |
| 33 (defgroup gnus-topic nil | |
| 34 "Group topics." | |
| 35 :group 'gnus-group) | |
| 31 | 36 |
| 32 (defvar gnus-topic-mode nil | 37 (defvar gnus-topic-mode nil |
| 33 "Minor mode for Gnus group buffers.") | 38 "Minor mode for Gnus group buffers.") |
| 34 | 39 |
| 35 (defvar gnus-topic-mode-hook nil | 40 (defcustom gnus-topic-mode-hook nil |
| 36 "Hook run in topic mode buffers.") | 41 "Hook run in topic mode buffers." |
| 37 | 42 :type 'hook |
| 38 (defvar gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n" | 43 :group 'gnus-topic) |
| 44 | |
| 45 (defcustom gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n" | |
| 39 "Format of topic lines. | 46 "Format of topic lines. |
| 40 It works along the same lines as a normal formatting string, | 47 It works along the same lines as a normal formatting string, |
| 41 with some simple extensions. | 48 with some simple extensions. |
| 42 | 49 |
| 43 %i Indentation based on topic level. | 50 %i Indentation based on topic level. |
| 44 %n Topic name. | 51 %n Topic name. |
| 45 %v Nothing if the topic is visible, \"...\" otherwise. | 52 %v Nothing if the topic is visible, \"...\" otherwise. |
| 46 %g Number of groups in the topic. | 53 %g Number of groups in the topic. |
| 47 %a Number of unread articles in the groups in the topic. | 54 %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. | 55 %A Number of unread articles in the groups in the topic and its subtopics. |
| 49 ") | 56 " |
| 50 | 57 :type 'string |
| 51 (defvar gnus-topic-indent-level 2 | 58 :group 'gnus-topic) |
| 52 "*How much each subtopic should be indented.") | 59 |
| 60 (defcustom gnus-topic-indent-level 2 | |
| 61 "*How much each subtopic should be indented." | |
| 62 :type 'integer | |
| 63 :group 'gnus-topic) | |
| 64 | |
| 65 (defcustom gnus-topic-display-empty-topics t | |
| 66 "*If non-nil, display the topic lines even of topics that have no unread articles." | |
| 67 :type 'boolean | |
| 68 :group 'gnus-topic) | |
| 53 | 69 |
| 54 ;; Internal variables. | 70 ;; Internal variables. |
| 55 | 71 |
| 56 (defvar gnus-topic-active-topology nil) | 72 (defvar gnus-topic-active-topology nil) |
| 57 (defvar gnus-topic-active-alist nil) | 73 (defvar gnus-topic-active-alist nil) |
| 72 (?A total-number-of-articles ?d) | 88 (?A total-number-of-articles ?d) |
| 73 (?l level ?d))) | 89 (?l level ?d))) |
| 74 | 90 |
| 75 (defvar gnus-topic-line-format-spec nil) | 91 (defvar gnus-topic-line-format-spec nil) |
| 76 | 92 |
| 77 ;; Functions. | 93 ;;; Utility functions |
| 78 | 94 |
| 79 (defun gnus-group-topic-name () | 95 (defun gnus-group-topic-name () |
| 80 "The name of the topic on the current line." | 96 "The name of the topic on the current line." |
| 81 (let ((topic (get-text-property (gnus-point-at-bol) 'gnus-topic))) | 97 (let ((topic (get-text-property (gnus-point-at-bol) 'gnus-topic))) |
| 82 (and topic (symbol-name topic)))) | 98 (and topic (symbol-name topic)))) |
| 94 (or (save-excursion | 110 (or (save-excursion |
| 95 (and (gnus-topic-goto-topic topic) | 111 (and (gnus-topic-goto-topic topic) |
| 96 (gnus-group-topic-unread))) | 112 (gnus-group-topic-unread))) |
| 97 0)) | 113 0)) |
| 98 | 114 |
| 99 (defun gnus-topic-init-alist () | 115 (defun gnus-group-topic-p () |
| 100 "Initialize the topic structures." | 116 "Return non-nil if the current line is a topic." |
| 101 (setq gnus-topic-topology | 117 (gnus-group-topic-name)) |
| 102 (cons (list "Gnus" 'visible) | 118 |
| 103 (mapcar (lambda (topic) | 119 (defun gnus-topic-visible-p () |
| 104 (list (list (car topic) 'visible))) | 120 "Return non-nil if the current topic is visible." |
| 105 '(("misc"))))) | 121 (get-text-property (gnus-point-at-bol) 'gnus-topic-visible)) |
| 106 (setq gnus-topic-alist | 122 |
| 107 (list (cons "misc" | 123 (defun gnus-topic-articles-in-topic (entries) |
| 108 (mapcar (lambda (info) (gnus-info-group info)) | 124 (let ((total 0) |
| 109 (cdr gnus-newsrc-alist))) | 125 number) |
| 110 (list "Gnus"))) | 126 (while entries |
| 111 (gnus-topic-enter-dribble)) | 127 (when (numberp (setq number (car (pop entries)))) |
| 112 | 128 (incf total number))) |
| 113 (defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic topic-level) | 129 total)) |
| 114 "List all newsgroups with unread articles of level LEVEL or lower, and | 130 |
| 115 use the `gnus-group-topics' to sort the groups. | 131 (defun gnus-group-topic (group) |
| 116 If ALL is non-nil, list groups that have no unread articles. | 132 "Return the topic GROUP is a member of." |
| 117 If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." | 133 (let ((alist gnus-topic-alist) |
| 118 (set-buffer gnus-group-buffer) | 134 out) |
| 119 (let ((buffer-read-only nil) | 135 (while alist |
| 120 (lowest (or lowest 1))) | 136 (when (member group (cdar alist)) |
| 121 | 137 (setq out (caar alist) |
| 122 (setq gnus-topic-tallied-groups nil) | 138 alist nil)) |
| 123 | 139 (setq alist (cdr alist))) |
| 124 (when (or (not gnus-topic-alist) | 140 out)) |
| 125 (not gnus-topology-checked-p)) | 141 |
| 126 (gnus-topic-check-topology)) | 142 (defun gnus-group-parent-topic (group) |
| 127 | 143 "Return the topic GROUP is member of by looking at the group buffer." |
| 128 (unless list-topic | 144 (save-excursion |
| 129 (erase-buffer)) | 145 (set-buffer gnus-group-buffer) |
| 130 | 146 (if (gnus-group-goto-group group) |
| 131 ;; List dead groups? | 147 (gnus-current-topic) |
| 132 (when (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie)) | 148 (gnus-group-topic group)))) |
| 133 (gnus-group-prepare-flat-list-dead | 149 |
| 134 (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) | 150 (defun gnus-topic-goto-topic (topic) |
| 135 gnus-level-zombie ?Z | 151 "Go to TOPIC." |
| 136 regexp)) | 152 (when topic |
| 137 | 153 (gnus-goto-char (text-property-any (point-min) (point-max) |
| 138 (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)) | 154 'gnus-topic (intern topic))))) |
| 139 (gnus-group-prepare-flat-list-dead | 155 |
| 140 (setq gnus-killed-list (sort gnus-killed-list 'string<)) | 156 (defun gnus-current-topic () |
| 141 gnus-level-killed ?K | 157 "Return the name of the current topic." |
| 142 regexp)) | 158 (let ((result |
| 143 | 159 (or (get-text-property (point) 'gnus-topic) |
| 144 ;; Use topics. | 160 (save-excursion |
| 145 (when (< lowest gnus-level-zombie) | 161 (and (gnus-goto-char (previous-single-property-change |
| 146 (if list-topic | 162 (point) 'gnus-topic)) |
| 147 (let ((top (gnus-topic-find-topology list-topic))) | 163 (get-text-property (max (1- (point)) (point-min)) |
| 148 (gnus-topic-prepare-topic (cdr top) (car top) | 164 'gnus-topic)))))) |
| 149 (or topic-level level) all)) | 165 (when result |
| 150 (gnus-topic-prepare-topic gnus-topic-topology 0 | 166 (symbol-name result)))) |
| 151 (or topic-level level) all)))) | 167 |
| 152 | 168 (defun gnus-current-topics () |
| 153 (gnus-group-set-mode-line) | 169 "Return a list of all current topics, lowest in hierarchy first." |
| 154 (setq gnus-group-list-mode (cons level all)) | 170 (let ((topic (gnus-current-topic)) |
| 155 (run-hooks 'gnus-group-prepare-hook)) | 171 topics) |
| 156 | 172 (while topic |
| 157 (defun gnus-topic-prepare-topic (topicl level &optional list-level all silent) | 173 (push topic topics) |
| 158 "Insert TOPIC into the group buffer. | 174 (setq topic (gnus-topic-parent-topic topic))) |
| 159 If SILENT, don't insert anything. Return the number of unread | 175 (nreverse topics))) |
| 160 articles in the topic and its subtopics." | 176 |
| 161 (let* ((type (pop topicl)) | 177 (defun gnus-group-active-topic-p () |
| 162 (entries (gnus-topic-find-groups (car type) list-level all)) | 178 "Say whether the current topic comes from the active topics." |
| 163 (visiblep (and (eq (nth 1 type) 'visible) (not silent))) | 179 (save-excursion |
| 164 (gnus-group-indentation | 180 (beginning-of-line) |
| 165 (make-string (* gnus-topic-indent-level level) ? )) | 181 (get-text-property (point) 'gnus-active))) |
| 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 | 182 |
| 212 (defun gnus-topic-find-groups (topic &optional level all) | 183 (defun gnus-topic-find-groups (topic &optional level all) |
| 213 "Return entries for all visible groups in TOPIC." | 184 "Return entries for all visible groups in TOPIC." |
| 214 (let ((groups (cdr (assoc topic gnus-topic-alist))) | 185 (let ((groups (cdr (assoc topic gnus-topic-alist))) |
| 215 info clevel unread group lowest params visible-groups entry active) | 186 info clevel unread group lowest params visible-groups entry active) |
| 216 (setq lowest (or lowest 1)) | 187 (setq lowest (or lowest 1)) |
| 217 (setq level (or level 7)) | 188 (setq level (or level 7)) |
| 218 ;; We go through the newsrc to look for matches. | 189 ;; We go through the newsrc to look for matches. |
| 219 (while groups | 190 (while groups |
| 220 (setq entry (gnus-gethash (setq group (pop groups)) gnus-newsrc-hashtb) | 191 (when (setq group (pop groups)) |
| 221 info (nth 2 entry) | 192 (setq entry (gnus-gethash group gnus-newsrc-hashtb) |
| 222 params (gnus-info-params info) | 193 info (nth 2 entry) |
| 223 active (gnus-active group) | 194 params (gnus-info-params info) |
| 224 unread (or (car entry) | 195 active (gnus-active group) |
| 225 (and (not (equal group "dummy.group")) | 196 unread (or (car entry) |
| 226 active | 197 (and (not (equal group "dummy.group")) |
| 227 (- (1+ (cdr active)) (car active)))) | 198 active |
| 228 clevel (or (gnus-info-level info) | 199 (- (1+ (cdr active)) (car active)))) |
| 229 (if (member group gnus-zombie-list) 8 9))) | 200 clevel (or (gnus-info-level info) |
| 201 (if (member group gnus-zombie-list) 8 9)))) | |
| 230 (and | 202 (and |
| 231 unread ; nil means that the group is dead. | 203 unread ; nil means that the group is dead. |
| 232 (<= clevel level) | 204 (<= clevel level) |
| 233 (>= clevel lowest) ; Is inside the level we want. | 205 (>= clevel lowest) ; Is inside the level we want. |
| 234 (or all | 206 (or all |
| 235 (if (eq unread t) | 207 (if (eq unread t) |
| 236 gnus-group-list-inactive-groups | 208 gnus-group-list-inactive-groups |
| 237 (> unread 0)) | 209 (> unread 0)) |
| 245 (cdr (assq 'visible params))) | 217 (cdr (assq 'visible params))) |
| 246 ;; Add this group to the list of visible groups. | 218 ;; Add this group to the list of visible groups. |
| 247 (push (or entry group) visible-groups))) | 219 (push (or entry group) visible-groups))) |
| 248 (nreverse visible-groups))) | 220 (nreverse visible-groups))) |
| 249 | 221 |
| 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) | 222 (defun gnus-topic-previous-topic (topic) |
| 317 "Return the previous topic on the same level as TOPIC." | 223 "Return the previous topic on the same level as TOPIC." |
| 318 (let ((top (cddr (gnus-topic-find-topology | 224 (let ((top (cddr (gnus-topic-find-topology |
| 319 (gnus-topic-parent-topic topic))))) | 225 (gnus-topic-parent-topic topic))))) |
| 320 (unless (equal topic (caaar top)) | 226 (unless (equal topic (caaar top)) |
| 335 (setq topology (cdr topology))) | 241 (setq topology (cdr topology))) |
| 336 (or result (and found parent)))) | 242 (or result (and found parent)))) |
| 337 | 243 |
| 338 (defun gnus-topic-next-topic (topic &optional previous) | 244 (defun gnus-topic-next-topic (topic &optional previous) |
| 339 "Return the next sibling of TOPIC." | 245 "Return the next sibling of TOPIC." |
| 340 (let ((topology gnus-topic-topology) | 246 (let ((parentt (cddr (gnus-topic-find-topology |
| 341 (parentt (cddr (gnus-topic-find-topology | |
| 342 (gnus-topic-parent-topic topic)))) | 247 (gnus-topic-parent-topic topic)))) |
| 343 prev) | 248 prev) |
| 344 (while (and parentt | 249 (while (and parentt |
| 345 (not (equal (caaar parentt) topic))) | 250 (not (equal (caaar parentt) topic))) |
| 346 (setq prev (caaar parentt) | 251 (setq prev (caaar parentt) |
| 367 topic (car topology) (1+ level) | 272 topic (car topology) (1+ level) |
| 368 (and remove top))))) | 273 (and remove top))))) |
| 369 (setq topology (cdr topology))) | 274 (setq topology (cdr topology))) |
| 370 result))) | 275 result))) |
| 371 | 276 |
| 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 | |
| 382 (defun gnus-topic-check-topology () | |
| 383 ;; The first time we set the topology to whatever we have | |
| 384 ;; gotten here, which can be rather random. | |
| 385 (unless gnus-topic-alist | |
| 386 (gnus-topic-init-alist)) | |
| 387 | |
| 388 (setq gnus-topology-checked-p t) | |
| 389 ;; Go through the topic alist and make sure that all topics | |
| 390 ;; are in the topic topology. | |
| 391 (let ((topics (gnus-topic-list)) | |
| 392 (alist gnus-topic-alist) | |
| 393 changed) | |
| 394 (while alist | |
| 395 (unless (member (caar alist) topics) | |
| 396 (nconc gnus-topic-topology | |
| 397 (list (list (list (caar alist) 'visible)))) | |
| 398 (setq changed t)) | |
| 399 (setq alist (cdr alist))) | |
| 400 (when changed | |
| 401 (gnus-topic-enter-dribble)) | |
| 402 ;; Conversely, go through the topology and make sure that all | |
| 403 ;; topologies have alists. | |
| 404 (while topics | |
| 405 (unless (assoc (car topics) gnus-topic-alist) | |
| 406 (push (list (car topics)) gnus-topic-alist)) | |
| 407 (pop topics))) | |
| 408 ;; Go through all living groups and make sure that | |
| 409 ;; they belong to some topic. | |
| 410 (let* ((tgroups (apply 'append (mapcar (lambda (entry) (cdr entry)) | |
| 411 gnus-topic-alist))) | |
| 412 (entry (assoc (caar gnus-topic-topology) gnus-topic-alist)) | |
| 413 (newsrc gnus-newsrc-alist) | |
| 414 group) | |
| 415 (while newsrc | |
| 416 (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups) | |
| 417 (setcdr entry (cons group (cdr entry)))))) | |
| 418 ;; Go through all topics and make sure they contain only living groups. | |
| 419 (let ((alist gnus-topic-alist) | |
| 420 topic) | |
| 421 (while (setq topic (pop alist)) | |
| 422 (while (cdr topic) | |
| 423 (if (gnus-gethash (cadr topic) gnus-newsrc-hashtb) | |
| 424 (setq topic (cdr topic)) | |
| 425 (setcdr topic (cddr topic))))))) | |
| 426 | |
| 427 (defvar gnus-tmp-topics nil) | 277 (defvar gnus-tmp-topics nil) |
| 428 (defun gnus-topic-list (&optional topology) | 278 (defun gnus-topic-list (&optional topology) |
| 279 "Return a list of all topics in the topology." | |
| 429 (unless topology | 280 (unless topology |
| 430 (setq topology gnus-topic-topology | 281 (setq topology gnus-topic-topology |
| 431 gnus-tmp-topics nil)) | 282 gnus-tmp-topics nil)) |
| 432 (push (caar topology) gnus-tmp-topics) | 283 (push (caar topology) gnus-tmp-topics) |
| 433 (mapcar 'gnus-topic-list (cdr topology)) | 284 (mapcar 'gnus-topic-list (cdr topology)) |
| 434 gnus-tmp-topics) | 285 gnus-tmp-topics) |
| 435 | 286 |
| 287 ;;; Topic parameter jazz | |
| 288 | |
| 289 (defun gnus-topic-parameters (topic) | |
| 290 "Return the parameters for TOPIC." | |
| 291 (let ((top (gnus-topic-find-topology topic))) | |
| 292 (when top | |
| 293 (nth 3 (cadr top))))) | |
| 294 | |
| 295 (defun gnus-topic-set-parameters (topic parameters) | |
| 296 "Set the topic parameters of TOPIC to PARAMETERS." | |
| 297 (let ((top (gnus-topic-find-topology topic))) | |
| 298 (unless top | |
| 299 (error "No such topic: %s" topic)) | |
| 300 ;; We may have to extend if there is no parameters here | |
| 301 ;; to begin with. | |
| 302 (unless (nthcdr 2 (cadr top)) | |
| 303 (nconc (cadr top) (list nil))) | |
| 304 (unless (nthcdr 3 (cadr top)) | |
| 305 (nconc (cadr top) (list nil))) | |
| 306 (setcar (nthcdr 3 (cadr top)) parameters) | |
| 307 (gnus-dribble-enter | |
| 308 (format "(gnus-topic-set-parameters %S '%S)" topic parameters)))) | |
| 309 | |
| 310 (defun gnus-group-topic-parameters (group) | |
| 311 "Compute the group parameters for GROUP taking into account inheritance from topics." | |
| 312 (let ((params-list (list (gnus-group-get-parameter group))) | |
| 313 topics params param out) | |
| 314 (save-excursion | |
| 315 (gnus-group-goto-group group) | |
| 316 (setq topics (gnus-current-topics)) | |
| 317 (while topics | |
| 318 (push (gnus-topic-parameters (pop topics)) params-list)) | |
| 319 ;; We probably have lots of nil elements here, so | |
| 320 ;; we remove them. Probably faster than doing this "properly". | |
| 321 (setq params-list (delq nil params-list)) | |
| 322 ;; Now we have all the parameters, so we go through them | |
| 323 ;; and do inheritance in the obvious way. | |
| 324 (while (setq params (pop params-list)) | |
| 325 (while (setq param (pop params)) | |
| 326 (when (atom param) | |
| 327 (setq param (cons param t))) | |
| 328 ;; Override any old versions of this param. | |
| 329 (setq out (delq (assq (car param) out) out)) | |
| 330 (push param out))) | |
| 331 ;; Return the resulting parameter list. | |
| 332 out))) | |
| 333 | |
| 334 ;;; General utility functions | |
| 335 | |
| 436 (defun gnus-topic-enter-dribble () | 336 (defun gnus-topic-enter-dribble () |
| 437 (gnus-dribble-enter | 337 (gnus-dribble-enter |
| 438 (format "(setq gnus-topic-topology '%S)" gnus-topic-topology))) | 338 (format "(setq gnus-topic-topology '%S)" gnus-topic-topology))) |
| 439 | 339 |
| 440 (defun gnus-topic-articles-in-topic (entries) | 340 ;;; Generating group buffers |
| 441 (let ((total 0) | 341 |
| 442 number) | 342 (defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic topic-level) |
| 443 (while entries | 343 "List all newsgroups with unread articles of level LEVEL or lower, and |
| 444 (when (numberp (setq number (car (pop entries)))) | 344 use the `gnus-group-topics' to sort the groups. |
| 445 (incf total number))) | 345 If ALL is non-nil, list groups that have no unread articles. |
| 446 total)) | 346 If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." |
| 447 | 347 (set-buffer gnus-group-buffer) |
| 448 (defun gnus-group-topic (group) | 348 (let ((buffer-read-only nil) |
| 449 "Return the topic GROUP is a member of." | 349 (lowest (or lowest 1))) |
| 450 (let ((alist gnus-topic-alist) | 350 |
| 451 out) | 351 (setq gnus-topic-tallied-groups nil) |
| 452 (while alist | 352 |
| 453 (when (member group (cdar alist)) | 353 (when (or (not gnus-topic-alist) |
| 454 (setq out (caar alist) | 354 (not gnus-topology-checked-p)) |
| 455 alist nil)) | 355 (gnus-topic-check-topology)) |
| 456 (setq alist (cdr alist))) | 356 |
| 457 out)) | 357 (unless list-topic |
| 458 | 358 (erase-buffer)) |
| 459 (defun gnus-topic-goto-topic (topic) | 359 |
| 460 "Go to TOPIC." | 360 ;; List dead groups? |
| 461 (when topic | 361 (when (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie)) |
| 462 (gnus-goto-char (text-property-any (point-min) (point-max) | 362 (gnus-group-prepare-flat-list-dead |
| 463 'gnus-topic (intern topic))))) | 363 (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) |
| 464 | 364 gnus-level-zombie ?Z |
| 465 (defun gnus-group-parent-topic () | 365 regexp)) |
| 466 "Return the name of the current topic." | 366 |
| 467 (let ((result | 367 (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)) |
| 468 (or (get-text-property (point) 'gnus-topic) | 368 (gnus-group-prepare-flat-list-dead |
| 469 (save-excursion | 369 (setq gnus-killed-list (sort gnus-killed-list 'string<)) |
| 470 (and (gnus-goto-char (previous-single-property-change | 370 gnus-level-killed ?K |
| 471 (point) 'gnus-topic)) | 371 regexp)) |
| 472 (get-text-property (max (1- (point)) (point-min)) | 372 |
| 473 'gnus-topic)))))) | 373 ;; Use topics. |
| 474 (when result | 374 (prog1 |
| 475 (symbol-name result)))) | 375 (when (< lowest gnus-level-zombie) |
| 376 (if list-topic | |
| 377 (let ((top (gnus-topic-find-topology list-topic))) | |
| 378 (gnus-topic-prepare-topic (cdr top) (car top) | |
| 379 (or topic-level level) all)) | |
| 380 (gnus-topic-prepare-topic gnus-topic-topology 0 | |
| 381 (or topic-level level) all))) | |
| 382 | |
| 383 (gnus-group-set-mode-line) | |
| 384 (setq gnus-group-list-mode (cons level all)) | |
| 385 (run-hooks 'gnus-group-prepare-hook)))) | |
| 386 | |
| 387 (defun gnus-topic-prepare-topic (topicl level &optional list-level all silent) | |
| 388 "Insert TOPIC into the group buffer. | |
| 389 If SILENT, don't insert anything. Return the number of unread | |
| 390 articles in the topic and its subtopics." | |
| 391 (let* ((type (pop topicl)) | |
| 392 (entries (gnus-topic-find-groups (car type) list-level all)) | |
| 393 (visiblep (and (eq (nth 1 type) 'visible) (not silent))) | |
| 394 (gnus-group-indentation | |
| 395 (make-string (* gnus-topic-indent-level level) ? )) | |
| 396 (beg (progn (beginning-of-line) (point))) | |
| 397 (topicl (reverse topicl)) | |
| 398 (all-entries entries) | |
| 399 (point-max (point-max)) | |
| 400 (unread 0) | |
| 401 (topic (car type)) | |
| 402 info entry end active tick) | |
| 403 ;; Insert any sub-topics. | |
| 404 (while topicl | |
| 405 (incf unread | |
| 406 (gnus-topic-prepare-topic | |
| 407 (pop topicl) (1+ level) list-level all | |
| 408 (not visiblep)))) | |
| 409 (setq end (point)) | |
| 410 (goto-char beg) | |
| 411 ;; Insert all the groups that belong in this topic. | |
| 412 (while (setq entry (pop entries)) | |
| 413 (when visiblep | |
| 414 (if (stringp entry) | |
| 415 ;; Dead groups. | |
| 416 (gnus-group-insert-group-line | |
| 417 entry (if (member entry gnus-zombie-list) 8 9) | |
| 418 nil (- (1+ (cdr (setq active (gnus-active entry)))) | |
| 419 (car active)) | |
| 420 nil) | |
| 421 ;; Living groups. | |
| 422 (when (setq info (nth 2 entry)) | |
| 423 (gnus-group-insert-group-line | |
| 424 (gnus-info-group info) | |
| 425 (gnus-info-level info) (gnus-info-marks info) | |
| 426 (car entry) (gnus-info-method info))))) | |
| 427 (when (and (listp entry) | |
| 428 (numberp (car entry)) | |
| 429 (not (member (gnus-info-group (setq info (nth 2 entry))) | |
| 430 gnus-topic-tallied-groups))) | |
| 431 (push (gnus-info-group info) gnus-topic-tallied-groups) | |
| 432 (incf unread (car entry))) | |
| 433 (when (and (listp entry) | |
| 434 (numberp (car entry))) | |
| 435 (setq tick t))) | |
| 436 (goto-char beg) | |
| 437 ;; Insert the topic line. | |
| 438 (when (and (not silent) | |
| 439 (or gnus-topic-display-empty-topics ;We want empty topics | |
| 440 (not (zerop unread)) ;Non-empty | |
| 441 tick ;Ticked articles | |
| 442 (/= point-max (point-max)))) ;Unactivated groups | |
| 443 (gnus-extent-start-open (point)) | |
| 444 (gnus-topic-insert-topic-line | |
| 445 (car type) visiblep | |
| 446 (not (eq (nth 2 type) 'hidden)) | |
| 447 level all-entries unread)) | |
| 448 (goto-char end) | |
| 449 unread)) | |
| 450 | |
| 451 (defun gnus-topic-remove-topic (&optional insert total-remove hide in-level) | |
| 452 "Remove the current topic." | |
| 453 (let ((topic (gnus-group-topic-name)) | |
| 454 (level (gnus-group-topic-level)) | |
| 455 (beg (progn (beginning-of-line) (point))) | |
| 456 buffer-read-only) | |
| 457 (when topic | |
| 458 (while (and (zerop (forward-line 1)) | |
| 459 (> (or (gnus-group-topic-level) (1+ level)) level))) | |
| 460 (delete-region beg (point)) | |
| 461 ;; Do the change in this rather odd manner because it has been | |
| 462 ;; reported that some topics share parts of some lists, for some | |
| 463 ;; reason. I have been unable to determine why this is the | |
| 464 ;; case, but this hack seems to take care of things. | |
| 465 (let ((data (cadr (gnus-topic-find-topology topic)))) | |
| 466 (setcdr data | |
| 467 (list (if insert 'visible 'invisible) | |
| 468 (if hide 'hide nil) | |
| 469 (cadddr data)))) | |
| 470 (if total-remove | |
| 471 (setq gnus-topic-alist | |
| 472 (delq (assoc topic gnus-topic-alist) gnus-topic-alist)) | |
| 473 (gnus-topic-insert-topic topic in-level))))) | |
| 474 | |
| 475 (defun gnus-topic-insert-topic (topic &optional level) | |
| 476 "Insert TOPIC." | |
| 477 (gnus-group-prepare-topics | |
| 478 (car gnus-group-list-mode) (cdr gnus-group-list-mode) | |
| 479 nil nil topic level)) | |
| 476 | 480 |
| 481 (defun gnus-topic-fold (&optional insert) | |
| 482 "Remove/insert the current topic." | |
| 483 (let ((topic (gnus-group-topic-name))) | |
| 484 (when topic | |
| 485 (save-excursion | |
| 486 (if (not (gnus-group-active-topic-p)) | |
| 487 (gnus-topic-remove-topic | |
| 488 (or insert (not (gnus-topic-visible-p)))) | |
| 489 (let ((gnus-topic-topology gnus-topic-active-topology) | |
| 490 (gnus-topic-alist gnus-topic-active-alist) | |
| 491 (gnus-group-list-mode (cons 5 t))) | |
| 492 (gnus-topic-remove-topic | |
| 493 (or insert (not (gnus-topic-visible-p))) nil nil 9))))))) | |
| 494 | |
| 495 (defun gnus-topic-insert-topic-line (name visiblep shownp level entries | |
| 496 &optional unread) | |
| 497 (let* ((visible (if visiblep "" "...")) | |
| 498 (indentation (make-string (* gnus-topic-indent-level level) ? )) | |
| 499 (total-number-of-articles unread) | |
| 500 (number-of-groups (length entries)) | |
| 501 (active-topic (eq gnus-topic-alist gnus-topic-active-alist))) | |
| 502 (beginning-of-line) | |
| 503 ;; Insert the text. | |
| 504 (gnus-add-text-properties | |
| 505 (point) | |
| 506 (prog1 (1+ (point)) | |
| 507 (eval gnus-topic-line-format-spec) | |
| 508 (gnus-topic-remove-excess-properties)1) | |
| 509 (list 'gnus-topic (intern name) | |
| 510 'gnus-topic-level level | |
| 511 'gnus-topic-unread unread | |
| 512 'gnus-active active-topic | |
| 513 'gnus-topic-visible visiblep)))) | |
| 514 | |
| 515 (defun gnus-topic-update-topics-containing-group (group) | |
| 516 "Update all topics that have GROUP as a member." | |
| 517 (when (and (eq major-mode 'gnus-group-mode) | |
| 518 gnus-topic-mode) | |
| 519 (save-excursion | |
| 520 (let ((alist gnus-topic-alist)) | |
| 521 ;; This is probably not entirely correct. If a topic | |
| 522 ;; isn't shown, then it's not updated. But the updating | |
| 523 ;; should be performed in any case, since the topic's | |
| 524 ;; parent should be updated. Pfft. | |
| 525 (while alist | |
| 526 (when (and (member group (cdar alist)) | |
| 527 (gnus-topic-goto-topic (caar alist))) | |
| 528 (gnus-topic-update-topic-line (caar alist))) | |
| 529 (pop alist)))))) | |
| 530 | |
| 477 (defun gnus-topic-update-topic () | 531 (defun gnus-topic-update-topic () |
| 478 "Update all parent topics to the current group." | 532 "Update all parent topics to the current group." |
| 479 (when (and (eq major-mode 'gnus-group-mode) | 533 (when (and (eq major-mode 'gnus-group-mode) |
| 480 gnus-topic-mode) | 534 gnus-topic-mode) |
| 481 (let ((group (gnus-group-group-name)) | 535 (let ((group (gnus-group-group-name)) |
| 482 (buffer-read-only nil)) | 536 (buffer-read-only nil)) |
| 483 (when (and group (gnus-get-info group) | 537 (when (and group |
| 484 (gnus-topic-goto-topic (gnus-group-parent-topic))) | 538 (gnus-get-info group) |
| 539 (gnus-topic-goto-topic (gnus-current-topic))) | |
| 485 (gnus-topic-update-topic-line (gnus-group-topic-name)) | 540 (gnus-topic-update-topic-line (gnus-group-topic-name)) |
| 486 (gnus-group-goto-group group) | 541 (gnus-group-goto-group group) |
| 487 (gnus-group-position-point))))) | 542 (gnus-group-position-point))))) |
| 488 | 543 |
| 489 (defun gnus-topic-goto-missing-group (group) | 544 (defun gnus-topic-goto-missing-group (group) |
| 490 "Place point where GROUP is supposed to be inserted." | 545 "Place point where GROUP is supposed to be inserted." |
| 491 (let* ((topic (gnus-group-topic group)) | 546 (let* ((topic (gnus-group-topic group)) |
| 492 (groups (cdr (assoc topic gnus-topic-alist))) | 547 (groups (cdr (assoc topic gnus-topic-alist))) |
| 493 (g (cdr (member group groups))) | 548 (g (cdr (member group groups))) |
| 494 (unfound t)) | 549 (unfound t)) |
| 495 (while (and g unfound) | 550 ;; Try to jump to a visible group. |
| 496 (when (gnus-group-goto-group (pop g)) | 551 (while (and g (not (gnus-group-goto-group (car g) t))) |
| 497 (beginning-of-line) | 552 (pop g)) |
| 498 (setq unfound nil))) | 553 ;; It wasn't visible, so we try to see where to insert it. |
| 499 (when unfound | 554 (when (not g) |
| 500 (setq g (cdr (member group (reverse groups)))) | 555 (setq g (cdr (member group (reverse groups)))) |
| 501 (while (and g unfound) | 556 (while (and g unfound) |
| 502 (when (gnus-group-goto-group (pop g)) | 557 (when (gnus-group-goto-group (pop g) t) |
| 503 (forward-line 1) | 558 (forward-line 1) |
| 504 (setq unfound nil))) | 559 (setq unfound nil))) |
| 505 (when unfound | 560 (when unfound |
| 506 (gnus-topic-goto-topic topic) | 561 (gnus-topic-goto-topic topic) |
| 507 (forward-line 1))))) | 562 (forward-line 1))))) |
| 537 (forward-line -1) | 592 (forward-line -1) |
| 538 (gnus-topic-update-topic-line | 593 (gnus-topic-update-topic-line |
| 539 parent (- old-unread (gnus-group-topic-unread)))) | 594 parent (- old-unread (gnus-group-topic-unread)))) |
| 540 unread)) | 595 unread)) |
| 541 | 596 |
| 597 (defun gnus-topic-group-indentation () | |
| 598 (make-string | |
| 599 (* gnus-topic-indent-level | |
| 600 (or (save-excursion | |
| 601 (forward-line -1) | |
| 602 (gnus-topic-goto-topic (gnus-current-topic)) | |
| 603 (gnus-group-topic-level)) | |
| 604 0)) | |
| 605 ? )) | |
| 606 | |
| 607 ;;; Initialization | |
| 608 | |
| 609 (gnus-add-shutdown 'gnus-topic-close 'gnus) | |
| 610 | |
| 611 (defun gnus-topic-close () | |
| 612 (setq gnus-topic-active-topology nil | |
| 613 gnus-topic-active-alist nil | |
| 614 gnus-topic-killed-topics nil | |
| 615 gnus-topic-tallied-groups nil | |
| 616 gnus-topology-checked-p nil)) | |
| 617 | |
| 618 (defun gnus-topic-check-topology () | |
| 619 ;; The first time we set the topology to whatever we have | |
| 620 ;; gotten here, which can be rather random. | |
| 621 (unless gnus-topic-alist | |
| 622 (gnus-topic-init-alist)) | |
| 623 | |
| 624 (setq gnus-topology-checked-p t) | |
| 625 ;; Go through the topic alist and make sure that all topics | |
| 626 ;; are in the topic topology. | |
| 627 (let ((topics (gnus-topic-list)) | |
| 628 (alist gnus-topic-alist) | |
| 629 changed) | |
| 630 (while alist | |
| 631 (unless (member (caar alist) topics) | |
| 632 (nconc gnus-topic-topology | |
| 633 (list (list (list (caar alist) 'visible)))) | |
| 634 (setq changed t)) | |
| 635 (setq alist (cdr alist))) | |
| 636 (when changed | |
| 637 (gnus-topic-enter-dribble)) | |
| 638 ;; Conversely, go through the topology and make sure that all | |
| 639 ;; topologies have alists. | |
| 640 (while topics | |
| 641 (unless (assoc (car topics) gnus-topic-alist) | |
| 642 (push (list (car topics)) gnus-topic-alist)) | |
| 643 (pop topics))) | |
| 644 ;; Go through all living groups and make sure that | |
| 645 ;; they belong to some topic. | |
| 646 (let* ((tgroups (apply 'append (mapcar (lambda (entry) (cdr entry)) | |
| 647 gnus-topic-alist))) | |
| 648 (entry (assoc (caar gnus-topic-topology) gnus-topic-alist)) | |
| 649 (newsrc (cdr gnus-newsrc-alist)) | |
| 650 group) | |
| 651 (while newsrc | |
| 652 (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups) | |
| 653 (setcdr entry (cons group (cdr entry)))))) | |
| 654 ;; Go through all topics and make sure they contain only living groups. | |
| 655 (let ((alist gnus-topic-alist) | |
| 656 topic) | |
| 657 (while (setq topic (pop alist)) | |
| 658 (while (cdr topic) | |
| 659 (if (gnus-gethash (cadr topic) gnus-newsrc-hashtb) | |
| 660 (setq topic (cdr topic)) | |
| 661 (setcdr topic (cddr topic))))))) | |
| 662 | |
| 663 (defun gnus-topic-init-alist () | |
| 664 "Initialize the topic structures." | |
| 665 (setq gnus-topic-topology | |
| 666 (cons (list "Gnus" 'visible) | |
| 667 (mapcar (lambda (topic) | |
| 668 (list (list (car topic) 'visible))) | |
| 669 '(("misc"))))) | |
| 670 (setq gnus-topic-alist | |
| 671 (list (cons "misc" | |
| 672 (mapcar (lambda (info) (gnus-info-group info)) | |
| 673 (cdr gnus-newsrc-alist))) | |
| 674 (list "Gnus"))) | |
| 675 (gnus-topic-enter-dribble)) | |
| 676 | |
| 677 ;;; Maintenance | |
| 678 | |
| 679 (defun gnus-topic-clean-alist () | |
| 680 "Remove bogus groups from the topic alist." | |
| 681 (let ((topic-alist gnus-topic-alist) | |
| 682 result topic) | |
| 683 (unless gnus-killed-hashtb | |
| 684 (gnus-make-hashtable-from-killed)) | |
| 685 (while (setq topic (pop topic-alist)) | |
| 686 (let ((topic-name (pop topic)) | |
| 687 group filtered-topic) | |
| 688 (while (setq group (pop topic)) | |
| 689 (when (and (or (gnus-gethash group gnus-active-hashtb) | |
| 690 (gnus-info-method (gnus-get-info group))) | |
| 691 (not (gnus-gethash group gnus-killed-hashtb))) | |
| 692 (push group filtered-topic))) | |
| 693 (push (cons topic-name (nreverse filtered-topic)) result))) | |
| 694 (setq gnus-topic-alist (nreverse result)))) | |
| 695 | |
| 696 (defun gnus-topic-change-level (group level oldlevel) | |
| 697 "Run when changing levels to enter/remove groups from topics." | |
| 698 (save-excursion | |
| 699 (set-buffer gnus-group-buffer) | |
| 700 (when (and gnus-topic-mode | |
| 701 gnus-topic-alist | |
| 702 (not gnus-topic-inhibit-change-level)) | |
| 703 ;; Remove the group from the topics. | |
| 704 (when (and (< oldlevel gnus-level-zombie) | |
| 705 (>= level gnus-level-zombie)) | |
| 706 (let (alist) | |
| 707 (forward-line -1) | |
| 708 (when (setq alist (assoc (gnus-current-topic) gnus-topic-alist)) | |
| 709 (setcdr alist (gnus-delete-first group (cdr alist)))))) | |
| 710 ;; If the group is subscribed we enter it into the topics. | |
| 711 (when (and (< level gnus-level-zombie) | |
| 712 (>= oldlevel gnus-level-zombie)) | |
| 713 (let* ((prev (gnus-group-group-name)) | |
| 714 (gnus-topic-inhibit-change-level t) | |
| 715 (gnus-group-indentation | |
| 716 (make-string | |
| 717 (* gnus-topic-indent-level | |
| 718 (or (save-excursion | |
| 719 (gnus-topic-goto-topic (gnus-current-topic)) | |
| 720 (gnus-group-topic-level)) | |
| 721 0)) | |
| 722 ? )) | |
| 723 (yanked (list group)) | |
| 724 alist talist end) | |
| 725 ;; Then we enter the yanked groups into the topics they belong | |
| 726 ;; to. | |
| 727 (when (setq alist (assoc (save-excursion | |
| 728 (forward-line -1) | |
| 729 (or | |
| 730 (gnus-current-topic) | |
| 731 (caar gnus-topic-topology))) | |
| 732 gnus-topic-alist)) | |
| 733 (setq talist alist) | |
| 734 (when (stringp yanked) | |
| 735 (setq yanked (list yanked))) | |
| 736 (if (not prev) | |
| 737 (nconc alist yanked) | |
| 738 (if (not (cdr alist)) | |
| 739 (setcdr alist (nconc yanked (cdr alist))) | |
| 740 (while (and (not end) (cdr alist)) | |
| 741 (when (equal (cadr alist) prev) | |
| 742 (setcdr alist (nconc yanked (cdr alist))) | |
| 743 (setq end t)) | |
| 744 (setq alist (cdr alist))) | |
| 745 (unless end | |
| 746 (nconc talist yanked)))))) | |
| 747 (gnus-topic-update-topic))))) | |
| 748 | |
| 749 (defun gnus-topic-goto-next-group (group props) | |
| 750 "Go to group or the next group after group." | |
| 751 (if (not group) | |
| 752 (if (not (memq 'gnus-topic props)) | |
| 753 (goto-char (point-max)) | |
| 754 (gnus-topic-goto-topic (symbol-name (cadr (memq 'gnus-topic props))))) | |
| 755 (if (gnus-group-goto-group group) | |
| 756 t | |
| 757 ;; The group is no longer visible. | |
| 758 (let* ((list (assoc (gnus-group-topic group) gnus-topic-alist)) | |
| 759 (after (cdr (member group (cdr list))))) | |
| 760 ;; First try to put point on a group after the current one. | |
| 761 (while (and after | |
| 762 (not (gnus-group-goto-group (car after)))) | |
| 763 (setq after (cdr after))) | |
| 764 ;; Then try to put point on a group before point. | |
| 765 (unless after | |
| 766 (setq after (cdr (member group (reverse (cdr list))))) | |
| 767 (while (and after | |
| 768 (not (gnus-group-goto-group (car after)))) | |
| 769 (setq after (cdr after)))) | |
| 770 ;; Finally, just put point on the topic. | |
| 771 (if (not (car list)) | |
| 772 (goto-char (point-min)) | |
| 773 (unless after | |
| 774 (gnus-topic-goto-topic (car list)) | |
| 775 (setq after nil))) | |
| 776 t)))) | |
| 777 | |
| 778 ;;; Topic-active functions | |
| 779 | |
| 542 (defun gnus-topic-grok-active (&optional force) | 780 (defun gnus-topic-grok-active (&optional force) |
| 543 "Parse all active groups and create topic structures for them." | 781 "Parse all active groups and create topic structures for them." |
| 544 ;; 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. |
| 545 (when (or force | 783 (when (or force |
| 546 (not gnus-topic-active-alist)) | 784 (not gnus-topic-active-alist)) |
| 587 (setcar (car topology) name) | 825 (setcar (car topology) name) |
| 588 ;; We return the rest of the groups that didn't belong | 826 ;; We return the rest of the groups that didn't belong |
| 589 ;; to this topic. | 827 ;; to this topic. |
| 590 groups)) | 828 groups)) |
| 591 | 829 |
| 592 (defun gnus-group-active-topic-p () | |
| 593 "Return whether the current active comes from the active topics." | |
| 594 (save-excursion | |
| 595 (beginning-of-line) | |
| 596 (get-text-property (point) 'gnus-active))) | |
| 597 | |
| 598 ;;; Topic mode, commands and keymap. | 830 ;;; Topic mode, commands and keymap. |
| 599 | 831 |
| 600 (defvar gnus-topic-mode-map nil) | 832 (defvar gnus-topic-mode-map nil) |
| 601 (defvar gnus-group-topic-map nil) | 833 (defvar gnus-group-topic-map nil) |
| 602 | 834 |
| 603 (unless gnus-topic-mode-map | 835 (unless gnus-topic-mode-map |
| 604 (setq gnus-topic-mode-map (make-sparse-keymap)) | 836 (setq gnus-topic-mode-map (make-sparse-keymap)) |
| 605 | 837 |
| 606 ;; Override certain group mode keys. | 838 ;; Override certain group mode keys. |
| 607 (gnus-define-keys | 839 (gnus-define-keys gnus-topic-mode-map |
| 608 gnus-topic-mode-map | 840 "=" gnus-topic-select-group |
| 609 "=" gnus-topic-select-group | 841 "\r" gnus-topic-select-group |
| 610 "\r" gnus-topic-select-group | 842 " " gnus-topic-read-group |
| 611 " " gnus-topic-read-group | 843 "\C-k" gnus-topic-kill-group |
| 612 "\C-k" gnus-topic-kill-group | 844 "\C-y" gnus-topic-yank-group |
| 613 "\C-y" gnus-topic-yank-group | 845 "\M-g" gnus-topic-get-new-news-this-topic |
| 614 "\M-g" gnus-topic-get-new-news-this-topic | 846 "AT" gnus-topic-list-active |
| 615 "AT" gnus-topic-list-active | 847 "Gp" gnus-topic-edit-parameters |
| 616 gnus-mouse-2 gnus-mouse-pick-topic) | 848 "#" gnus-topic-mark-topic |
| 849 "\M-#" gnus-topic-unmark-topic | |
| 850 gnus-mouse-2 gnus-mouse-pick-topic) | |
| 617 | 851 |
| 618 ;; Define a new submap. | 852 ;; Define a new submap. |
| 619 (gnus-define-keys | 853 (gnus-define-keys (gnus-group-topic-map "T" gnus-group-mode-map) |
| 620 (gnus-group-topic-map "T" gnus-group-mode-map) | 854 "#" gnus-topic-mark-topic |
| 621 "#" gnus-topic-mark-topic | 855 "\M-#" gnus-topic-unmark-topic |
| 622 "\M-#" gnus-topic-unmark-topic | 856 "n" gnus-topic-create-topic |
| 623 "n" gnus-topic-create-topic | 857 "m" gnus-topic-move-group |
| 624 "m" gnus-topic-move-group | 858 "D" gnus-topic-remove-group |
| 625 "D" gnus-topic-remove-group | 859 "c" gnus-topic-copy-group |
| 626 "c" gnus-topic-copy-group | 860 "h" gnus-topic-hide-topic |
| 627 "h" gnus-topic-hide-topic | 861 "s" gnus-topic-show-topic |
| 628 "s" gnus-topic-show-topic | 862 "M" gnus-topic-move-matching |
| 629 "M" gnus-topic-move-matching | 863 "C" gnus-topic-copy-matching |
| 630 "C" gnus-topic-copy-matching | 864 "\C-i" gnus-topic-indent |
| 631 "\C-i" gnus-topic-indent | 865 [tab] gnus-topic-indent |
| 632 [tab] gnus-topic-indent | 866 "r" gnus-topic-rename |
| 633 "r" gnus-topic-rename | 867 "\177" gnus-topic-delete) |
| 634 "\177" gnus-topic-delete)) | 868 |
| 869 (gnus-define-keys (gnus-topic-sort-map "S" gnus-group-topic-map) | |
| 870 "s" gnus-topic-sort-groups | |
| 871 "a" gnus-topic-sort-groups-by-alphabet | |
| 872 "u" gnus-topic-sort-groups-by-unread | |
| 873 "l" gnus-topic-sort-groups-by-level | |
| 874 "v" gnus-topic-sort-groups-by-score | |
| 875 "r" gnus-topic-sort-groups-by-rank | |
| 876 "m" gnus-topic-sort-groups-by-method)) | |
| 635 | 877 |
| 636 (defun gnus-topic-make-menu-bar () | 878 (defun gnus-topic-make-menu-bar () |
| 637 (unless (boundp 'gnus-topic-menu) | 879 (unless (boundp 'gnus-topic-menu) |
| 638 (easy-menu-define | 880 (easy-menu-define |
| 639 gnus-topic-menu gnus-topic-mode-map "" | 881 gnus-topic-menu gnus-topic-mode-map "" |
| 663 (setq gnus-topic-mode | 905 (setq gnus-topic-mode |
| 664 (if (null arg) (not gnus-topic-mode) | 906 (if (null arg) (not gnus-topic-mode) |
| 665 (> (prefix-numeric-value arg) 0))) | 907 (> (prefix-numeric-value arg) 0))) |
| 666 ;; Infest Gnus with topics. | 908 ;; Infest Gnus with topics. |
| 667 (when gnus-topic-mode | 909 (when gnus-topic-mode |
| 668 (when (and menu-bar-mode | 910 (when (gnus-visual-p 'topic-menu 'menu) |
| 669 (gnus-visual-p 'topic-menu 'menu)) | |
| 670 (gnus-topic-make-menu-bar)) | 911 (gnus-topic-make-menu-bar)) |
| 671 (setq gnus-topic-line-format-spec | 912 (setq gnus-topic-line-format-spec |
| 672 (gnus-parse-format gnus-topic-line-format | 913 (gnus-parse-format gnus-topic-line-format |
| 673 gnus-topic-line-format-alist t)) | 914 gnus-topic-line-format-alist t)) |
| 674 (unless (assq 'gnus-topic-mode minor-mode-alist) | 915 (unless (assq 'gnus-topic-mode minor-mode-alist) |
| 676 (unless (assq 'gnus-topic-mode minor-mode-map-alist) | 917 (unless (assq 'gnus-topic-mode minor-mode-map-alist) |
| 677 (push (cons 'gnus-topic-mode gnus-topic-mode-map) | 918 (push (cons 'gnus-topic-mode gnus-topic-mode-map) |
| 678 minor-mode-map-alist)) | 919 minor-mode-map-alist)) |
| 679 (add-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) | 920 (add-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) |
| 680 (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic) | 921 (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic) |
| 681 (add-hook 'gnus-group-update-group-hook 'gnus-topic-update-topic) | 922 (set (make-local-variable 'gnus-group-prepare-function) |
| 682 (make-local-variable 'gnus-group-prepare-function) | 923 'gnus-group-prepare-topics) |
| 683 (setq gnus-group-prepare-function 'gnus-group-prepare-topics) | 924 (set (make-local-variable 'gnus-group-get-parameter-function) |
| 684 (make-local-variable 'gnus-group-goto-next-group-function) | 925 'gnus-group-topic-parameters) |
| 685 (setq gnus-group-goto-next-group-function | 926 (set (make-local-variable 'gnus-group-goto-next-group-function) |
| 686 'gnus-topic-goto-next-group) | 927 'gnus-topic-goto-next-group) |
| 928 (set (make-local-variable 'gnus-group-indentation-function) | |
| 929 'gnus-topic-group-indentation) | |
| 930 (set (make-local-variable 'gnus-group-update-group-function) | |
| 931 'gnus-topic-update-topics-containing-group) | |
| 932 (set (make-local-variable 'gnus-group-sort-alist-function) | |
| 933 'gnus-group-sort-topic) | |
| 687 (setq gnus-group-change-level-function 'gnus-topic-change-level) | 934 (setq gnus-group-change-level-function 'gnus-topic-change-level) |
| 688 (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group) | 935 (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group) |
| 689 (make-local-variable 'gnus-group-indentation-function) | 936 (make-local-hook 'gnus-check-bogus-groups-hook) |
| 690 (setq gnus-group-indentation-function | |
| 691 'gnus-topic-group-indentation) | |
| 692 (gnus-make-local-hook 'gnus-check-bogus-groups-hook) | |
| 693 (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist) | 937 (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist) |
| 694 (setq gnus-topology-checked-p nil) | 938 (setq gnus-topology-checked-p nil) |
| 695 ;; We check the topology. | 939 ;; We check the topology. |
| 696 (when gnus-newsrc-alist | 940 (when gnus-newsrc-alist |
| 697 (gnus-topic-check-topology)) | 941 (gnus-topic-check-topology)) |
| 700 (unless gnus-topic-mode | 944 (unless gnus-topic-mode |
| 701 (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) | 945 (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) |
| 702 (remove-hook 'gnus-group-change-level-function | 946 (remove-hook 'gnus-group-change-level-function |
| 703 'gnus-topic-change-level) | 947 'gnus-topic-change-level) |
| 704 (remove-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist) | 948 (remove-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist) |
| 705 (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)) | |
| 706 (when redisplay | 951 (when redisplay |
| 707 (gnus-group-list-groups)))) | 952 (gnus-group-list-groups)))) |
| 708 | 953 |
| 709 (defun gnus-topic-select-group (&optional all) | 954 (defun gnus-topic-select-group (&optional all) |
| 710 "Select this newsgroup. | 955 "Select this newsgroup. |
| 744 | 989 |
| 745 (defun gnus-topic-create-topic (topic parent &optional previous full-topic) | 990 (defun gnus-topic-create-topic (topic parent &optional previous full-topic) |
| 746 (interactive | 991 (interactive |
| 747 (list | 992 (list |
| 748 (read-string "New topic: ") | 993 (read-string "New topic: ") |
| 749 (gnus-group-parent-topic))) | 994 (gnus-current-topic))) |
| 750 ;; Check whether this topic already exists. | 995 ;; Check whether this topic already exists. |
| 751 (when (gnus-topic-find-topology topic) | 996 (when (gnus-topic-find-topology topic) |
| 752 (error "Topic aleady exists")) | 997 (error "Topic already exists")) |
| 753 (unless parent | 998 (unless parent |
| 754 (setq parent (caar gnus-topic-topology))) | 999 (setq parent (caar gnus-topic-topology))) |
| 755 (let ((top (cdr (gnus-topic-find-topology parent))) | 1000 (let ((top (cdr (gnus-topic-find-topology parent))) |
| 756 (full-topic (or full-topic `((,topic visible))))) | 1001 (full-topic (or full-topic `((,topic visible))))) |
| 757 (unless top | 1002 (unless top |
| 775 (interactive | 1020 (interactive |
| 776 (list current-prefix-arg | 1021 (list current-prefix-arg |
| 777 (completing-read "Move to topic: " gnus-topic-alist nil t))) | 1022 (completing-read "Move to topic: " gnus-topic-alist nil t))) |
| 778 (let ((groups (gnus-group-process-prefix n)) | 1023 (let ((groups (gnus-group-process-prefix n)) |
| 779 (topicl (assoc topic gnus-topic-alist)) | 1024 (topicl (assoc topic gnus-topic-alist)) |
| 1025 (start-group (progn (forward-line 1) (gnus-group-group-name))) | |
| 1026 (start-topic (gnus-group-topic-name)) | |
| 780 entry) | 1027 entry) |
| 781 (mapcar (lambda (g) | 1028 (mapcar |
| 782 (gnus-group-remove-mark g) | 1029 (lambda (g) |
| 783 (when (and | 1030 (gnus-group-remove-mark g) |
| 784 (setq entry (assoc (gnus-group-parent-topic) | 1031 (when (and |
| 785 gnus-topic-alist)) | 1032 (setq entry (assoc (gnus-current-topic) gnus-topic-alist)) |
| 786 (not copyp)) | 1033 (not copyp)) |
| 787 (setcdr entry (gnus-delete-first g (cdr entry)))) | 1034 (setcdr entry (gnus-delete-first g (cdr entry)))) |
| 788 (nconc topicl (list g))) | 1035 (nconc topicl (list g))) |
| 789 groups) | 1036 groups) |
| 790 (gnus-group-position-point)) | 1037 (gnus-topic-enter-dribble) |
| 791 (gnus-topic-enter-dribble) | 1038 (if start-group |
| 792 (gnus-group-list-groups)) | 1039 (gnus-group-goto-group start-group) |
| 793 | 1040 (gnus-topic-goto-topic start-topic)) |
| 794 (defun gnus-topic-remove-group () | 1041 (gnus-group-list-groups))) |
| 1042 | |
| 1043 (defun gnus-topic-remove-group (&optional arg) | |
| 795 "Remove the current group from the topic." | 1044 "Remove the current group from the topic." |
| 796 (interactive) | 1045 (interactive "P") |
| 797 (let ((topicl (assoc (gnus-group-parent-topic) gnus-topic-alist)) | 1046 (gnus-group-iterate arg |
| 798 (group (gnus-group-group-name)) | 1047 (lambda (group) |
| 799 (buffer-read-only nil)) | 1048 (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist)) |
| 800 (when (and topicl group) | 1049 (buffer-read-only nil)) |
| 801 (gnus-delete-line) | 1050 (when (and topicl group) |
| 802 (gnus-delete-first group topicl)) | 1051 (gnus-delete-line) |
| 803 (gnus-group-position-point))) | 1052 (gnus-delete-first group topicl)) |
| 1053 (gnus-topic-update-topic) | |
| 1054 (gnus-group-position-point))))) | |
| 804 | 1055 |
| 805 (defun gnus-topic-copy-group (n topic) | 1056 (defun gnus-topic-copy-group (n topic) |
| 806 "Copy the current group to a topic." | 1057 "Copy the current group to a topic." |
| 807 (interactive | 1058 (interactive |
| 808 (list current-prefix-arg | 1059 (list current-prefix-arg |
| 809 (completing-read "Copy to topic: " gnus-topic-alist nil t))) | 1060 (completing-read "Copy to topic: " gnus-topic-alist nil t))) |
| 810 (gnus-topic-move-group n topic t)) | 1061 (gnus-topic-move-group n topic t)) |
| 811 | 1062 |
| 812 (defun gnus-topic-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 | |
| 819 (defun gnus-topic-clean-alist () | |
| 820 "Remove bogus groups from the topic alist." | |
| 821 (let ((topic-alist gnus-topic-alist) | |
| 822 result topic) | |
| 823 (unless gnus-killed-hashtb | |
| 824 (gnus-make-hashtable-from-killed)) | |
| 825 (while (setq topic (pop topic-alist)) | |
| 826 (let ((topic-name (pop topic)) | |
| 827 group filtered-topic) | |
| 828 (while (setq group (pop topic)) | |
| 829 (if (and (gnus-gethash group gnus-active-hashtb) | |
| 830 (not (gnus-gethash group gnus-killed-hashtb))) | |
| 831 (push group filtered-topic))) | |
| 832 (push (cons topic-name (nreverse filtered-topic)) result))) | |
| 833 (setq gnus-topic-alist (nreverse result)))) | |
| 834 | |
| 835 (defun gnus-topic-change-level (group level oldlevel) | |
| 836 "Run when changing levels to enter/remove groups from topics." | |
| 837 (save-excursion | |
| 838 (set-buffer gnus-group-buffer) | |
| 839 (when (and gnus-topic-mode | |
| 840 gnus-topic-alist | |
| 841 (not gnus-topic-inhibit-change-level)) | |
| 842 ;; Remove the group from the topics. | |
| 843 (when (and (< oldlevel gnus-level-zombie) | |
| 844 (>= level gnus-level-zombie)) | |
| 845 (let (alist) | |
| 846 (forward-line -1) | |
| 847 (when (setq alist (assoc (gnus-group-parent-topic) gnus-topic-alist)) | |
| 848 (setcdr alist (gnus-delete-first group (cdr alist)))))) | |
| 849 ;; If the group is subscribed. then we enter it into the topics. | |
| 850 (when (and (< level gnus-level-zombie) | |
| 851 (>= oldlevel gnus-level-zombie)) | |
| 852 (let* ((prev (gnus-group-group-name)) | |
| 853 (gnus-topic-inhibit-change-level t) | |
| 854 (gnus-group-indentation | |
| 855 (make-string | |
| 856 (* gnus-topic-indent-level | |
| 857 (or (save-excursion | |
| 858 (gnus-topic-goto-topic (gnus-group-parent-topic)) | |
| 859 (gnus-group-topic-level)) 0)) ? )) | |
| 860 (yanked (list group)) | |
| 861 alist talist end) | |
| 862 ;; Then we enter the yanked groups into the topics they belong | |
| 863 ;; to. | |
| 864 (when (setq alist (assoc (save-excursion | |
| 865 (forward-line -1) | |
| 866 (or | |
| 867 (gnus-group-parent-topic) | |
| 868 (caar gnus-topic-topology))) | |
| 869 gnus-topic-alist)) | |
| 870 (setq talist alist) | |
| 871 (when (stringp yanked) | |
| 872 (setq yanked (list yanked))) | |
| 873 (if (not prev) | |
| 874 (nconc alist yanked) | |
| 875 (if (not (cdr alist)) | |
| 876 (setcdr alist (nconc yanked (cdr alist))) | |
| 877 (while (and (not end) (cdr alist)) | |
| 878 (when (equal (cadr alist) prev) | |
| 879 (setcdr alist (nconc yanked (cdr alist))) | |
| 880 (setq end t)) | |
| 881 (setq alist (cdr alist))) | |
| 882 (unless end | |
| 883 (nconc talist yanked)))))) | |
| 884 (gnus-topic-update-topic))))) | |
| 885 | |
| 886 (defun gnus-topic-goto-next-group (group props) | |
| 887 "Go to group or the next group after group." | |
| 888 (if (null group) | |
| 889 (gnus-topic-goto-topic (symbol-name (cadr (memq 'gnus-topic props)))) | |
| 890 (if (gnus-group-goto-group group) | |
| 891 t | |
| 892 ;; The group is no longer visible. | |
| 893 (let* ((list (assoc (gnus-group-parent-topic) gnus-topic-alist)) | |
| 894 (after (cdr (member group (cdr list))))) | |
| 895 ;; First try to put point on a group after the current one. | |
| 896 (while (and after | |
| 897 (not (gnus-group-goto-group (car after)))) | |
| 898 (setq after (cdr after))) | |
| 899 ;; Then try to put point on a group before point. | |
| 900 (unless after | |
| 901 (setq after (cdr (member group (reverse (cdr list))))) | |
| 902 (while (and after | |
| 903 (not (gnus-group-goto-group (car after)))) | |
| 904 (setq after (cdr after)))) | |
| 905 ;; Finally, just put point on the topic. | |
| 906 (unless after | |
| 907 (gnus-topic-goto-topic (car list)) | |
| 908 (setq after nil)) | |
| 909 t)))) | |
| 910 | |
| 911 (defun gnus-topic-kill-group (&optional n discard) | 1063 (defun gnus-topic-kill-group (&optional n discard) |
| 912 "Kill the next N groups." | 1064 "Kill the next N groups." |
| 913 (interactive "P") | 1065 (interactive "P") |
| 914 (if (gnus-group-topic-p) | 1066 (if (gnus-group-topic-p) |
| 915 (let ((topic (gnus-group-topic-name))) | 1067 (let ((topic (gnus-group-topic-name))) |
| 1068 (push (cons | |
| 1069 (gnus-topic-find-topology topic) | |
| 1070 (assoc topic gnus-topic-alist)) | |
| 1071 gnus-topic-killed-topics) | |
| 916 (gnus-topic-remove-topic nil t) | 1072 (gnus-topic-remove-topic nil t) |
| 917 (push (gnus-topic-find-topology topic nil nil gnus-topic-topology) | 1073 (gnus-topic-find-topology topic nil nil gnus-topic-topology) |
| 918 gnus-topic-killed-topics)) | 1074 (gnus-topic-enter-dribble)) |
| 919 (gnus-group-kill-group n discard) | 1075 (gnus-group-kill-group n discard) |
| 920 (gnus-topic-update-topic))) | 1076 (gnus-topic-update-topic))) |
| 921 | 1077 |
| 922 (defun gnus-topic-yank-group (&optional arg) | 1078 (defun gnus-topic-yank-group (&optional arg) |
| 923 "Yank the last topic." | 1079 "Yank the last topic." |
| 924 (interactive "p") | 1080 (interactive "p") |
| 925 (if gnus-topic-killed-topics | 1081 (if gnus-topic-killed-topics |
| 926 (let ((previous | 1082 (let* ((previous |
| 927 (or (gnus-group-topic-name) | 1083 (or (gnus-group-topic-name) |
| 928 (gnus-topic-next-topic (gnus-group-parent-topic)))) | 1084 (gnus-topic-next-topic (gnus-current-topic)))) |
| 929 (item (cdr (pop gnus-topic-killed-topics)))) | 1085 (data (pop gnus-topic-killed-topics)) |
| 1086 (alist (cdr data)) | |
| 1087 (item (cdar data))) | |
| 1088 (push alist gnus-topic-alist) | |
| 930 (gnus-topic-create-topic | 1089 (gnus-topic-create-topic |
| 931 (caar item) (gnus-topic-parent-topic previous) previous | 1090 (caar item) (gnus-topic-parent-topic previous) previous |
| 932 item) | 1091 item) |
| 1092 (gnus-topic-enter-dribble) | |
| 933 (gnus-topic-goto-topic (caar item))) | 1093 (gnus-topic-goto-topic (caar item))) |
| 934 (let* ((prev (gnus-group-group-name)) | 1094 (let* ((prev (gnus-group-group-name)) |
| 935 (gnus-topic-inhibit-change-level t) | 1095 (gnus-topic-inhibit-change-level t) |
| 936 (gnus-group-indentation | 1096 (gnus-group-indentation |
| 937 (make-string | 1097 (make-string |
| 938 (* gnus-topic-indent-level | 1098 (* gnus-topic-indent-level |
| 939 (or (save-excursion | 1099 (or (save-excursion |
| 940 (gnus-topic-goto-topic (gnus-group-parent-topic)) | 1100 (gnus-topic-goto-topic (gnus-current-topic)) |
| 941 (gnus-group-topic-level)) 0)) ? )) | 1101 (gnus-group-topic-level)) |
| 1102 0)) | |
| 1103 ? )) | |
| 942 yanked alist) | 1104 yanked alist) |
| 943 ;; We first yank the groups the normal way... | 1105 ;; We first yank the groups the normal way... |
| 944 (setq yanked (gnus-group-yank-group arg)) | 1106 (setq yanked (gnus-group-yank-group arg)) |
| 945 ;; Then we enter the yanked groups into the topics they belong | 1107 ;; Then we enter the yanked groups into the topics they belong |
| 946 ;; to. | 1108 ;; to. |
| 947 (setq alist (assoc (save-excursion | 1109 (setq alist (assoc (save-excursion |
| 948 (forward-line -1) | 1110 (forward-line -1) |
| 949 (gnus-group-parent-topic)) | 1111 (gnus-current-topic)) |
| 950 gnus-topic-alist)) | 1112 gnus-topic-alist)) |
| 951 (when (stringp yanked) | 1113 (when (stringp yanked) |
| 952 (setq yanked (list yanked))) | 1114 (setq yanked (list yanked))) |
| 953 (if (not prev) | 1115 (if (not prev) |
| 954 (nconc alist yanked) | 1116 (nconc alist yanked) |
| 962 (gnus-topic-update-topic))) | 1124 (gnus-topic-update-topic))) |
| 963 | 1125 |
| 964 (defun gnus-topic-hide-topic () | 1126 (defun gnus-topic-hide-topic () |
| 965 "Hide the current topic." | 1127 "Hide the current topic." |
| 966 (interactive) | 1128 (interactive) |
| 967 (when (gnus-group-parent-topic) | 1129 (when (gnus-current-topic) |
| 968 (gnus-topic-goto-topic (gnus-group-parent-topic)) | 1130 (gnus-topic-goto-topic (gnus-current-topic)) |
| 969 (gnus-topic-remove-topic nil nil 'hidden))) | 1131 (gnus-topic-remove-topic nil nil 'hidden))) |
| 970 | 1132 |
| 971 (defun gnus-topic-show-topic () | 1133 (defun gnus-topic-show-topic () |
| 972 "Show the hidden topic." | 1134 "Show the hidden topic." |
| 973 (interactive) | 1135 (interactive) |
| 974 (when (gnus-group-topic-p) | 1136 (when (gnus-group-topic-p) |
| 975 (gnus-topic-remove-topic t nil 'shown))) | 1137 (gnus-topic-remove-topic t nil 'shown))) |
| 976 | 1138 |
| 977 (defun gnus-topic-mark-topic (topic &optional unmark) | 1139 (defun gnus-topic-mark-topic (topic &optional unmark) |
| 978 "Mark all groups in the topic with the process mark." | 1140 "Mark all groups in the topic with the process mark." |
| 979 (interactive (list (gnus-group-parent-topic))) | 1141 (interactive (list (gnus-group-topic-name))) |
| 980 (save-excursion | 1142 (if (not topic) |
| 981 (let ((groups (gnus-topic-find-groups topic 9 t))) | 1143 (call-interactively 'gnus-group-mark-group) |
| 982 (while groups | 1144 (save-excursion |
| 983 (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) | 1145 (let ((groups (gnus-topic-find-groups topic 9 t))) |
| 984 (gnus-info-group (nth 2 (pop groups)))))))) | 1146 (while groups |
| 1147 (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) | |
| 1148 (gnus-info-group (nth 2 (pop groups))))))))) | |
| 985 | 1149 |
| 986 (defun gnus-topic-unmark-topic (topic &optional unmark) | 1150 (defun gnus-topic-unmark-topic (topic &optional unmark) |
| 987 "Remove the process mark from all groups in the topic." | 1151 "Remove the process mark from all groups in the topic." |
| 988 (interactive (list (gnus-group-parent-topic))) | 1152 (interactive (list (gnus-group-topic-name))) |
| 989 (gnus-topic-mark-topic topic t)) | 1153 (if (not topic) |
| 1154 (call-interactively 'gnus-group-unmark-group) | |
| 1155 (gnus-topic-mark-topic topic t))) | |
| 990 | 1156 |
| 991 (defun gnus-topic-get-new-news-this-topic (&optional n) | 1157 (defun gnus-topic-get-new-news-this-topic (&optional n) |
| 992 "Check for new news in the current topic." | 1158 "Check for new news in the current topic." |
| 993 (interactive "P") | 1159 (interactive "P") |
| 994 (if (not (gnus-group-topic-p)) | 1160 (if (not (gnus-group-topic-p)) |
| 1035 (gnus-topic-find-topology topic nil nil 'delete))) | 1201 (gnus-topic-find-topology topic nil nil 'delete))) |
| 1036 | 1202 |
| 1037 (defun gnus-topic-rename (old-name new-name) | 1203 (defun gnus-topic-rename (old-name new-name) |
| 1038 "Rename a topic." | 1204 "Rename a topic." |
| 1039 (interactive | 1205 (interactive |
| 1040 (let ((topic (gnus-group-parent-topic))) | 1206 (let ((topic (gnus-current-topic))) |
| 1041 (list topic | 1207 (list topic |
| 1042 (read-string (format "Rename %s to: " topic))))) | 1208 (read-string (format "Rename %s to: " topic))))) |
| 1043 (let ((top (gnus-topic-find-topology old-name)) | 1209 (let ((top (gnus-topic-find-topology old-name)) |
| 1044 (entry (assoc old-name gnus-topic-alist))) | 1210 (entry (assoc old-name gnus-topic-alist))) |
| 1045 (when top | 1211 (when top |
| 1046 (setcar (cadr top) new-name)) | 1212 (setcar (cadr top) new-name)) |
| 1047 (when entry | 1213 (when entry |
| 1048 (setcar entry new-name)) | 1214 (setcar entry new-name)) |
| 1049 (forward-line -1) | 1215 (forward-line -1) |
| 1216 (gnus-dribble-touch) | |
| 1050 (gnus-group-list-groups))) | 1217 (gnus-group-list-groups))) |
| 1051 | 1218 |
| 1052 (defun gnus-topic-indent (&optional unindent) | 1219 (defun gnus-topic-indent (&optional unindent) |
| 1053 "Indent a topic -- make it a sub-topic of the previous topic. | 1220 "Indent a topic -- make it a sub-topic of the previous topic. |
| 1054 If UNINDENT, remove an indentation." | 1221 If UNINDENT, remove an indentation." |
| 1055 (interactive "P") | 1222 (interactive "P") |
| 1056 (if unindent | 1223 (if unindent |
| 1057 (gnus-topic-unindent) | 1224 (gnus-topic-unindent) |
| 1058 (let* ((topic (gnus-group-parent-topic)) | 1225 (let* ((topic (gnus-current-topic)) |
| 1059 (parent (gnus-topic-previous-topic topic))) | 1226 (parent (gnus-topic-previous-topic topic)) |
| 1227 (buffer-read-only nil)) | |
| 1060 (unless parent | 1228 (unless parent |
| 1061 (error "Nothing to indent %s into" topic)) | 1229 (error "Nothing to indent %s into" topic)) |
| 1062 (when topic | 1230 (when topic |
| 1063 (gnus-topic-goto-topic topic) | 1231 (gnus-topic-goto-topic topic) |
| 1064 (gnus-topic-kill-group) | 1232 (gnus-topic-kill-group) |
| 1233 (push (cdar gnus-topic-killed-topics) gnus-topic-alist) | |
| 1065 (gnus-topic-create-topic | 1234 (gnus-topic-create-topic |
| 1066 topic parent nil (cdr (pop gnus-topic-killed-topics))) | 1235 topic parent nil (cdaar gnus-topic-killed-topics)) |
| 1236 (pop gnus-topic-killed-topics) | |
| 1067 (or (gnus-topic-goto-topic topic) | 1237 (or (gnus-topic-goto-topic topic) |
| 1068 (gnus-topic-goto-topic parent)))))) | 1238 (gnus-topic-goto-topic parent)))))) |
| 1069 | 1239 |
| 1070 (defun gnus-topic-unindent () | 1240 (defun gnus-topic-unindent () |
| 1071 "Unindent a topic." | 1241 "Unindent a topic." |
| 1072 (interactive) | 1242 (interactive) |
| 1073 (let* ((topic (gnus-group-parent-topic)) | 1243 (let* ((topic (gnus-current-topic)) |
| 1074 (parent (gnus-topic-parent-topic topic)) | 1244 (parent (gnus-topic-parent-topic topic)) |
| 1075 (grandparent (gnus-topic-parent-topic parent))) | 1245 (grandparent (gnus-topic-parent-topic parent))) |
| 1076 (unless grandparent | 1246 (unless grandparent |
| 1077 (error "Nothing to indent %s into" topic)) | 1247 (error "Nothing to indent %s into" topic)) |
| 1078 (when topic | 1248 (when topic |
| 1079 (gnus-topic-goto-topic topic) | 1249 (gnus-topic-goto-topic topic) |
| 1080 (gnus-topic-kill-group) | 1250 (gnus-topic-kill-group) |
| 1251 (push (cdar gnus-topic-killed-topics) gnus-topic-alist) | |
| 1081 (gnus-topic-create-topic | 1252 (gnus-topic-create-topic |
| 1082 topic grandparent (gnus-topic-next-topic parent) | 1253 topic grandparent (gnus-topic-next-topic parent) |
| 1083 (cdr (pop gnus-topic-killed-topics))) | 1254 (cdaar gnus-topic-killed-topics)) |
| 1255 (pop gnus-topic-killed-topics) | |
| 1084 (gnus-topic-goto-topic topic)))) | 1256 (gnus-topic-goto-topic topic)))) |
| 1085 | 1257 |
| 1086 (defun gnus-topic-list-active (&optional force) | 1258 (defun gnus-topic-list-active (&optional force) |
| 1087 "List all groups that Gnus knows about in a topicsified fashion. | 1259 "List all groups that Gnus knows about in a topicsified fashion. |
| 1088 If FORCE, always re-read the active file." | 1260 If FORCE, always re-read the active file." |
| 1093 (let ((gnus-topic-topology gnus-topic-active-topology) | 1265 (let ((gnus-topic-topology gnus-topic-active-topology) |
| 1094 (gnus-topic-alist gnus-topic-active-alist) | 1266 (gnus-topic-alist gnus-topic-active-alist) |
| 1095 gnus-killed-list gnus-zombie-list) | 1267 gnus-killed-list gnus-zombie-list) |
| 1096 (gnus-group-list-groups 9 nil 1))) | 1268 (gnus-group-list-groups 9 nil 1))) |
| 1097 | 1269 |
| 1270 ;;; Topic sorting functions | |
| 1271 | |
| 1272 (defun gnus-topic-edit-parameters (group) | |
| 1273 "Edit the group parameters of GROUP. | |
| 1274 If performed on a topic, edit the topic parameters instead." | |
| 1275 (interactive (list (gnus-group-group-name))) | |
| 1276 (if group | |
| 1277 (gnus-group-edit-group-parameters group) | |
| 1278 (if (not (gnus-group-topic-p)) | |
| 1279 (error "Nothing to edit on the current line.") | |
| 1280 (let ((topic (gnus-group-topic-name))) | |
| 1281 (gnus-edit-form | |
| 1282 (gnus-topic-parameters topic) | |
| 1283 "Editing the topic parameters." | |
| 1284 `(lambda (form) | |
| 1285 (gnus-topic-set-parameters ,topic form))))))) | |
| 1286 | |
| 1287 (defun gnus-group-sort-topic (func reverse) | |
| 1288 "Sort groups in the topics according to FUNC and REVERSE." | |
| 1289 (let ((alist gnus-topic-alist)) | |
| 1290 (while alist | |
| 1291 ;; !!!Sometimes nil elements sneak into the alist, | |
| 1292 ;; for some reason or other. | |
| 1293 (setcar alist (delq nil (car alist))) | |
| 1294 (setcar alist (delete "dummy.group" (car alist))) | |
| 1295 (gnus-topic-sort-topic (pop alist) func reverse)))) | |
| 1296 | |
| 1297 (defun gnus-topic-sort-topic (topic func reverse) | |
| 1298 ;; Each topic only lists the name of the group, while | |
| 1299 ;; the sort predicates expect group infos as inputs. | |
| 1300 ;; So we first transform the group names into infos, | |
| 1301 ;; then sort, and then transform back into group names. | |
| 1302 (setcdr | |
| 1303 topic | |
| 1304 (mapcar | |
| 1305 (lambda (info) (gnus-info-group info)) | |
| 1306 (sort | |
| 1307 (mapcar | |
| 1308 (lambda (group) (gnus-get-info group)) | |
| 1309 (cdr topic)) | |
| 1310 func))) | |
| 1311 ;; Do the reversal, if necessary. | |
| 1312 (when reverse | |
| 1313 (setcdr topic (nreverse (cdr topic))))) | |
| 1314 | |
| 1315 (defun gnus-topic-sort-groups (func &optional reverse) | |
| 1316 "Sort the current topic according to FUNC. | |
| 1317 If REVERSE, reverse the sorting order." | |
| 1318 (interactive (list gnus-group-sort-function current-prefix-arg)) | |
| 1319 (let ((topic (assoc (gnus-current-topic) gnus-topic-alist))) | |
| 1320 (gnus-topic-sort-topic | |
| 1321 topic (gnus-make-sort-function func) reverse) | |
| 1322 (gnus-group-list-groups))) | |
| 1323 | |
| 1324 (defun gnus-topic-sort-groups-by-alphabet (&optional reverse) | |
| 1325 "Sort the current topic alphabetically by group name. | |
| 1326 If REVERSE, sort in reverse order." | |
| 1327 (interactive "P") | |
| 1328 (gnus-topic-sort-groups 'gnus-group-sort-by-alphabet reverse)) | |
| 1329 | |
| 1330 (defun gnus-topic-sort-groups-by-unread (&optional reverse) | |
| 1331 "Sort the current topic by number of unread articles. | |
| 1332 If REVERSE, sort in reverse order." | |
| 1333 (interactive "P") | |
| 1334 (gnus-topic-sort-groups 'gnus-group-sort-by-unread reverse)) | |
| 1335 | |
| 1336 (defun gnus-topic-sort-groups-by-level (&optional reverse) | |
| 1337 "Sort the current topic by group level. | |
| 1338 If REVERSE, sort in reverse order." | |
| 1339 (interactive "P") | |
| 1340 (gnus-topic-sort-groups 'gnus-group-sort-by-level reverse)) | |
| 1341 | |
| 1342 (defun gnus-topic-sort-groups-by-score (&optional reverse) | |
| 1343 "Sort the current topic by group score. | |
| 1344 If REVERSE, sort in reverse order." | |
| 1345 (interactive "P") | |
| 1346 (gnus-topic-sort-groups 'gnus-group-sort-by-score reverse)) | |
| 1347 | |
| 1348 (defun gnus-topic-sort-groups-by-rank (&optional reverse) | |
| 1349 "Sort the current topic by group rank. | |
| 1350 If REVERSE, sort in reverse order." | |
| 1351 (interactive "P") | |
| 1352 (gnus-topic-sort-groups 'gnus-group-sort-by-rank reverse)) | |
| 1353 | |
| 1354 (defun gnus-topic-sort-groups-by-method (&optional reverse) | |
| 1355 "Sort the current topic alphabetically by backend name. | |
| 1356 If REVERSE, sort in reverse order." | |
| 1357 (interactive "P") | |
| 1358 (gnus-topic-sort-groups 'gnus-group-sort-by-method reverse)) | |
| 1359 | |
| 1098 (provide 'gnus-topic) | 1360 (provide 'gnus-topic) |
| 1099 | 1361 |
| 1100 ;;; gnus-topic.el ends here | 1362 ;;; gnus-topic.el ends here |