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