Mercurial > emacs
annotate lisp/gnus/gnus-agent.el @ 33067:adc6c04ffe30
*** empty log message ***
author | Stefan Monnier <monnier@iro.umontreal.ca> |
---|---|
date | Mon, 30 Oct 2000 15:21:36 +0000 |
parents | 2e19cd4c5909 |
children | bcba582cbfe5 |
rev | line source |
---|---|
24358 | 1 ;;; gnus-agent.el --- unplugged support for Gnus |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
2 ;; Copyright (C) 1997, 1998, 1999, 2000 Free Software Foundation, Inc. |
24358 | 3 |
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> | |
32985
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
5 ;; Maintainer: bugs@gnus.org |
24358 | 6 ;; This file is part of GNU Emacs. |
7 | |
8 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
9 ;; it under the terms of the GNU General Public License as published by | |
10 ;; the Free Software Foundation; either version 2, or (at your option) | |
11 ;; any later version. | |
12 | |
13 ;; GNU Emacs is distributed in the hope that it will be useful, | |
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 ;; GNU General Public License for more details. | |
17 | |
18 ;; You should have received a copy of the GNU General Public License | |
19 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
21 ;; Boston, MA 02111-1307, USA. | |
22 | |
23 ;;; Commentary: | |
24 | |
25 ;;; Code: | |
26 | |
27 (require 'gnus) | |
28 (require 'gnus-cache) | |
29 (require 'nnvirtual) | |
30 (require 'gnus-sum) | |
32985
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
31 (require 'gnus-score) |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
32 (eval-when-compile |
32985
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
33 (if (featurep 'xemacs) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
34 (require 'itimer) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
35 (require 'timer)) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
36 (require 'cl)) |
24358 | 37 |
38 (defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/") | |
39 "Where the Gnus agent will store its files." | |
40 :group 'gnus-agent | |
41 :type 'directory) | |
42 | |
43 (defcustom gnus-agent-plugged-hook nil | |
44 "Hook run when plugging into the network." | |
45 :group 'gnus-agent | |
46 :type 'hook) | |
47 | |
48 (defcustom gnus-agent-unplugged-hook nil | |
49 "Hook run when unplugging from the network." | |
50 :group 'gnus-agent | |
51 :type 'hook) | |
52 | |
53 (defcustom gnus-agent-handle-level gnus-level-subscribed | |
54 "Groups on levels higher than this variable will be ignored by the Agent." | |
55 :group 'gnus-agent | |
56 :type 'integer) | |
57 | |
58 (defcustom gnus-agent-expire-days 7 | |
59 "Read articles older than this will be expired." | |
60 :group 'gnus-agent | |
61 :type 'integer) | |
62 | |
63 (defcustom gnus-agent-expire-all nil | |
64 "If non-nil, also expire unread, ticked and dormant articles. | |
65 If nil, only read articles will be expired." | |
66 :group 'gnus-agent | |
67 :type 'boolean) | |
68 | |
69 (defcustom gnus-agent-group-mode-hook nil | |
70 "Hook run in Agent group minor modes." | |
71 :group 'gnus-agent | |
72 :type 'hook) | |
73 | |
74 (defcustom gnus-agent-summary-mode-hook nil | |
75 "Hook run in Agent summary minor modes." | |
76 :group 'gnus-agent | |
77 :type 'hook) | |
78 | |
79 (defcustom gnus-agent-server-mode-hook nil | |
80 "Hook run in Agent summary minor modes." | |
81 :group 'gnus-agent | |
82 :type 'hook) | |
83 | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
84 (defcustom gnus-agent-confirmation-function 'y-or-n-p |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
85 "Function to confirm when error happens." |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
86 :group 'gnus-agent |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
87 :type 'function) |
24358 | 88 |
32985
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
89 (defcustom gnus-agent-synchronize-flags 'ask |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
90 "Indicate if flags are synchronized when you plug in. |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
91 If this is `ask' the hook will query the user." |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
92 :type '(choice (const :tag "Always" t) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
93 (const :tag "Never" nil) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
94 (const :tag "Ask" ask)) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
95 :group 'gnus-agent) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
96 |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
97 ;;; Internal variables |
24358 | 98 |
99 (defvar gnus-agent-history-buffers nil) | |
100 (defvar gnus-agent-buffer-alist nil) | |
101 (defvar gnus-agent-article-alist nil) | |
102 (defvar gnus-agent-group-alist nil) | |
103 (defvar gnus-agent-covered-methods nil) | |
104 (defvar gnus-category-alist nil) | |
105 (defvar gnus-agent-current-history nil) | |
106 (defvar gnus-agent-overview-buffer nil) | |
107 (defvar gnus-category-predicate-cache nil) | |
108 (defvar gnus-category-group-cache nil) | |
109 (defvar gnus-agent-spam-hashtb nil) | |
110 (defvar gnus-agent-file-name nil) | |
111 (defvar gnus-agent-send-mail-function nil) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
112 (defvar gnus-agent-file-coding-system 'raw-text) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
113 |
24358 | 114 ;; Dynamic variables |
115 (defvar gnus-headers) | |
116 (defvar gnus-score) | |
117 | |
118 ;;; | |
119 ;;; Setup | |
120 ;;; | |
121 | |
122 (defun gnus-open-agent () | |
123 (setq gnus-agent t) | |
124 (gnus-agent-read-servers) | |
125 (gnus-category-read) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
126 (gnus-agent-create-buffer) |
24358 | 127 (add-hook 'gnus-group-mode-hook 'gnus-agent-mode) |
128 (add-hook 'gnus-summary-mode-hook 'gnus-agent-mode) | |
129 (add-hook 'gnus-server-mode-hook 'gnus-agent-mode)) | |
130 | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
131 (defun gnus-agent-create-buffer () |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
132 (if (gnus-buffer-live-p gnus-agent-overview-buffer) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
133 t |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
134 (setq gnus-agent-overview-buffer |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
135 (gnus-get-buffer-create " *Gnus agent overview*")) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
136 (with-current-buffer gnus-agent-overview-buffer |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
137 (mm-enable-multibyte)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
138 nil)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
139 |
24358 | 140 (gnus-add-shutdown 'gnus-close-agent 'gnus) |
141 | |
142 (defun gnus-close-agent () | |
143 (setq gnus-agent-covered-methods nil | |
144 gnus-category-predicate-cache nil | |
145 gnus-category-group-cache nil | |
146 gnus-agent-spam-hashtb nil) | |
147 (gnus-kill-buffer gnus-agent-overview-buffer)) | |
148 | |
149 ;;; | |
150 ;;; Utility functions | |
151 ;;; | |
152 | |
153 (defun gnus-agent-read-file (file) | |
154 "Load FILE and do a `read' there." | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
155 (with-temp-buffer |
24358 | 156 (ignore-errors |
157 (nnheader-insert-file-contents file) | |
158 (goto-char (point-min)) | |
159 (read (current-buffer))))) | |
160 | |
161 (defsubst gnus-agent-method () | |
162 (concat (symbol-name (car gnus-command-method)) "/" | |
163 (if (equal (cadr gnus-command-method) "") | |
164 "unnamed" | |
165 (cadr gnus-command-method)))) | |
166 | |
167 (defsubst gnus-agent-directory () | |
168 "Path of the Gnus agent directory." | |
169 (nnheader-concat gnus-agent-directory | |
170 (nnheader-translate-file-chars (gnus-agent-method)) "/")) | |
171 | |
172 (defun gnus-agent-lib-file (file) | |
173 "The full path of the Gnus agent library FILE." | |
174 (concat (gnus-agent-directory) "agent.lib/" file)) | |
175 | |
176 ;;; Fetching setup functions. | |
177 | |
178 (defun gnus-agent-start-fetch () | |
179 "Initialize data structures for efficient fetching." | |
180 (gnus-agent-open-history) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
181 (setq gnus-agent-current-history (gnus-agent-history-buffer)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
182 (gnus-agent-create-buffer)) |
24358 | 183 |
184 (defun gnus-agent-stop-fetch () | |
185 "Save all data structures and clean up." | |
186 (gnus-agent-save-history) | |
187 (gnus-agent-close-history) | |
188 (setq gnus-agent-spam-hashtb nil) | |
189 (save-excursion | |
190 (set-buffer nntp-server-buffer) | |
191 (widen))) | |
192 | |
193 (defmacro gnus-agent-with-fetch (&rest forms) | |
194 "Do FORMS safely." | |
195 `(unwind-protect | |
32985
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
196 (let ((gnus-agent-fetching t)) |
24358 | 197 (gnus-agent-start-fetch) |
198 ,@forms) | |
199 (gnus-agent-stop-fetch))) | |
200 | |
201 (put 'gnus-agent-with-fetch 'lisp-indent-function 0) | |
202 (put 'gnus-agent-with-fetch 'edebug-form-spec '(body)) | |
203 | |
204 ;;; | |
205 ;;; Mode infestation | |
206 ;;; | |
207 | |
208 (defvar gnus-agent-mode-hook nil | |
209 "Hook run when installing agent mode.") | |
210 | |
211 (defvar gnus-agent-mode nil) | |
212 (defvar gnus-agent-mode-status '(gnus-agent-mode " Plugged")) | |
213 | |
214 (defun gnus-agent-mode () | |
215 "Minor mode for providing a agent support in Gnus buffers." | |
216 (let* ((buffer (progn (string-match "^gnus-\\(.*\\)-mode$" | |
217 (symbol-name major-mode)) | |
218 (match-string 1 (symbol-name major-mode)))) | |
219 (mode (intern (format "gnus-agent-%s-mode" buffer)))) | |
220 (set (make-local-variable 'gnus-agent-mode) t) | |
221 (set mode nil) | |
222 (set (make-local-variable mode) t) | |
223 ;; Set up the menu. | |
224 (when (gnus-visual-p 'agent-menu 'menu) | |
225 (funcall (intern (format "gnus-agent-%s-make-menu-bar" buffer)))) | |
226 (unless (assq 'gnus-agent-mode minor-mode-alist) | |
227 (push gnus-agent-mode-status minor-mode-alist)) | |
228 (unless (assq mode minor-mode-map-alist) | |
229 (push (cons mode (symbol-value (intern (format "gnus-agent-%s-mode-map" | |
230 buffer)))) | |
231 minor-mode-map-alist)) | |
232 (when (eq major-mode 'gnus-group-mode) | |
233 (gnus-agent-toggle-plugged gnus-plugged)) | |
234 (gnus-run-hooks 'gnus-agent-mode-hook | |
235 (intern (format "gnus-agent-%s-mode-hook" buffer))))) | |
236 | |
237 (defvar gnus-agent-group-mode-map (make-sparse-keymap)) | |
238 (gnus-define-keys gnus-agent-group-mode-map | |
239 "Ju" gnus-agent-fetch-groups | |
240 "Jc" gnus-enter-category-buffer | |
241 "Jj" gnus-agent-toggle-plugged | |
242 "Js" gnus-agent-fetch-session | |
32985
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
243 "JY" gnus-agent-synchronize-flags |
24358 | 244 "JS" gnus-group-send-drafts |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
245 "Ja" gnus-agent-add-group |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
246 "Jr" gnus-agent-remove-group) |
24358 | 247 |
248 (defun gnus-agent-group-make-menu-bar () | |
249 (unless (boundp 'gnus-agent-group-menu) | |
250 (easy-menu-define | |
251 gnus-agent-group-menu gnus-agent-group-mode-map "" | |
252 '("Agent" | |
253 ["Toggle plugged" gnus-agent-toggle-plugged t] | |
254 ["List categories" gnus-enter-category-buffer t] | |
255 ["Send drafts" gnus-group-send-drafts gnus-plugged] | |
256 ("Fetch" | |
257 ["All" gnus-agent-fetch-session gnus-plugged] | |
258 ["Group" gnus-agent-fetch-group gnus-plugged]))))) | |
259 | |
260 (defvar gnus-agent-summary-mode-map (make-sparse-keymap)) | |
261 (gnus-define-keys gnus-agent-summary-mode-map | |
262 "Jj" gnus-agent-toggle-plugged | |
263 "J#" gnus-agent-mark-article | |
264 "J\M-#" gnus-agent-unmark-article | |
265 "@" gnus-agent-toggle-mark | |
266 "Jc" gnus-agent-catchup) | |
267 | |
268 (defun gnus-agent-summary-make-menu-bar () | |
269 (unless (boundp 'gnus-agent-summary-menu) | |
270 (easy-menu-define | |
271 gnus-agent-summary-menu gnus-agent-summary-mode-map "" | |
272 '("Agent" | |
273 ["Toggle plugged" gnus-agent-toggle-plugged t] | |
274 ["Mark as downloadable" gnus-agent-mark-article t] | |
275 ["Unmark as downloadable" gnus-agent-unmark-article t] | |
276 ["Toggle mark" gnus-agent-toggle-mark t] | |
277 ["Catchup undownloaded" gnus-agent-catchup t])))) | |
278 | |
279 (defvar gnus-agent-server-mode-map (make-sparse-keymap)) | |
280 (gnus-define-keys gnus-agent-server-mode-map | |
281 "Jj" gnus-agent-toggle-plugged | |
282 "Ja" gnus-agent-add-server | |
283 "Jr" gnus-agent-remove-server) | |
284 | |
285 (defun gnus-agent-server-make-menu-bar () | |
286 (unless (boundp 'gnus-agent-server-menu) | |
287 (easy-menu-define | |
288 gnus-agent-server-menu gnus-agent-server-mode-map "" | |
289 '("Agent" | |
290 ["Toggle plugged" gnus-agent-toggle-plugged t] | |
291 ["Add" gnus-agent-add-server t] | |
292 ["Remove" gnus-agent-remove-server t])))) | |
293 | |
294 (defun gnus-agent-toggle-plugged (plugged) | |
295 "Toggle whether Gnus is unplugged or not." | |
296 (interactive (list (not gnus-plugged))) | |
297 (if plugged | |
298 (progn | |
299 (setq gnus-plugged plugged) | |
32985
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
300 (gnus-agent-possibly-synchronize-flags) |
24358 | 301 (gnus-run-hooks 'gnus-agent-plugged-hook) |
302 (setcar (cdr gnus-agent-mode-status) " Plugged")) | |
303 (gnus-agent-close-connections) | |
304 (setq gnus-plugged plugged) | |
305 (gnus-run-hooks 'gnus-agent-unplugged-hook) | |
306 (setcar (cdr gnus-agent-mode-status) " Unplugged")) | |
307 (set-buffer-modified-p t)) | |
308 | |
309 (defun gnus-agent-close-connections () | |
310 "Close all methods covered by the Gnus agent." | |
311 (let ((methods gnus-agent-covered-methods)) | |
312 (while methods | |
313 (gnus-close-server (pop methods))))) | |
314 | |
315 ;;;###autoload | |
316 (defun gnus-unplugged () | |
317 "Start Gnus unplugged." | |
318 (interactive) | |
319 (setq gnus-plugged nil) | |
320 (gnus)) | |
321 | |
322 ;;;###autoload | |
323 (defun gnus-plugged () | |
324 "Start Gnus plugged." | |
325 (interactive) | |
326 (setq gnus-plugged t) | |
327 (gnus)) | |
328 | |
329 ;;;###autoload | |
330 (defun gnus-agentize () | |
331 "Allow Gnus to be an offline newsreader. | |
332 The normal usage of this command is to put the following as the | |
333 last form in your `.gnus.el' file: | |
334 | |
335 \(gnus-agentize) | |
336 | |
337 This will modify the `gnus-before-startup-hook', `gnus-post-method', | |
338 and `message-send-mail-function' variables, and install the Gnus | |
339 agent minor mode in all Gnus buffers." | |
340 (interactive) | |
341 (gnus-open-agent) | |
342 (add-hook 'gnus-setup-news-hook 'gnus-agent-queue-setup) | |
343 (unless gnus-agent-send-mail-function | |
344 (setq gnus-agent-send-mail-function message-send-mail-function | |
345 message-send-mail-function 'gnus-agent-send-mail)) | |
346 (unless gnus-agent-covered-methods | |
347 (setq gnus-agent-covered-methods (list gnus-select-method)))) | |
348 | |
349 (defun gnus-agent-queue-setup () | |
350 "Make sure the queue group exists." | |
351 (unless (gnus-gethash "nndraft:queue" gnus-newsrc-hashtb) | |
352 (gnus-request-create-group "queue" '(nndraft "")) | |
353 (let ((gnus-level-default-subscribed 1)) | |
354 (gnus-subscribe-group "nndraft:queue" nil '(nndraft ""))) | |
355 (gnus-group-set-parameter | |
356 "nndraft:queue" 'gnus-dummy '((gnus-draft-mode))))) | |
357 | |
358 (defun gnus-agent-send-mail () | |
359 (if gnus-plugged | |
360 (funcall gnus-agent-send-mail-function) | |
361 (goto-char (point-min)) | |
362 (re-search-forward | |
363 (concat "^" (regexp-quote mail-header-separator) "\n")) | |
364 (replace-match "\n") | |
365 (gnus-agent-insert-meta-information 'mail) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
366 (gnus-request-accept-article "nndraft:queue" nil t t))) |
24358 | 367 |
368 (defun gnus-agent-insert-meta-information (type &optional method) | |
369 "Insert meta-information into the message that says how it's to be posted. | |
370 TYPE can be either `mail' or `news'. If the latter METHOD can | |
371 be a select method." | |
372 (save-excursion | |
373 (message-remove-header gnus-agent-meta-information-header) | |
374 (goto-char (point-min)) | |
375 (insert gnus-agent-meta-information-header ": " | |
376 (symbol-name type) " " (format "%S" method) | |
377 "\n") | |
378 (forward-char -1) | |
379 (while (search-backward "\n" nil t) | |
380 (replace-match "\\n" t t)))) | |
381 | |
32985
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
382 (defun gnus-agent-restore-gcc () |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
383 "Restore GCC field from saved header." |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
384 (save-excursion |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
385 (goto-char (point-min)) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
386 (while (re-search-forward (concat gnus-agent-gcc-header ":") nil t) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
387 (replace-match "Gcc:" 'fixedcase)))) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
388 |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
389 (defun gnus-agent-any-covered-gcc () |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
390 (save-restriction |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
391 (message-narrow-to-headers) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
392 (let* ((gcc (mail-fetch-field "gcc" nil t)) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
393 (methods (and gcc |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
394 (mapcar 'gnus-inews-group-method |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
395 (message-unquote-tokens |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
396 (message-tokenize-header |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
397 gcc " ,"))))) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
398 covered) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
399 (while (and (not covered) methods) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
400 (setq covered |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
401 (member (car methods) gnus-agent-covered-methods) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
402 methods (cdr methods))) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
403 covered))) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
404 |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
405 (defun gnus-agent-possibly-save-gcc () |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
406 "Save GCC if Gnus is unplugged." |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
407 (when (and (not gnus-plugged) (gnus-agent-any-covered-gcc)) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
408 (save-excursion |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
409 (goto-char (point-min)) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
410 (let ((case-fold-search t)) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
411 (while (re-search-forward "^gcc:" nil t) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
412 (replace-match (concat gnus-agent-gcc-header ":") 'fixedcase)))))) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
413 |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
414 (defun gnus-agent-possibly-do-gcc () |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
415 "Do GCC if Gnus is plugged." |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
416 (when (or gnus-plugged (not (gnus-agent-any-covered-gcc))) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
417 (gnus-inews-do-gcc))) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
418 |
24358 | 419 ;;; |
420 ;;; Group mode commands | |
421 ;;; | |
422 | |
423 (defun gnus-agent-fetch-groups (n) | |
424 "Put all new articles in the current groups into the Agent." | |
425 (interactive "P") | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
426 (unless gnus-plugged |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
427 (error "Groups can't be fetched when Gnus is unplugged")) |
24358 | 428 (gnus-group-iterate n 'gnus-agent-fetch-group)) |
429 | |
430 (defun gnus-agent-fetch-group (group) | |
431 "Put all new articles in GROUP into the Agent." | |
432 (interactive (list (gnus-group-group-name))) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
433 (unless gnus-plugged |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
434 (error "Groups can't be fetched when Gnus is unplugged")) |
24358 | 435 (unless group |
436 (error "No group on the current line")) | |
437 (let ((gnus-command-method (gnus-find-method-for-group group))) | |
438 (gnus-agent-with-fetch | |
439 (gnus-agent-fetch-group-1 group gnus-command-method) | |
440 (gnus-message 5 "Fetching %s...done" group)))) | |
441 | |
442 (defun gnus-agent-add-group (category arg) | |
443 "Add the current group to an agent category." | |
444 (interactive | |
445 (list | |
446 (intern | |
447 (completing-read | |
448 "Add to category: " | |
449 (mapcar (lambda (cat) (list (symbol-name (car cat)))) | |
450 gnus-category-alist) | |
451 nil t)) | |
452 current-prefix-arg)) | |
453 (let ((cat (assq category gnus-category-alist)) | |
454 c groups) | |
455 (gnus-group-iterate arg | |
456 (lambda (group) | |
457 (when (cadddr (setq c (gnus-group-category group))) | |
458 (setf (cadddr c) (delete group (cadddr c)))) | |
459 (push group groups))) | |
460 (setf (cadddr cat) (nconc (cadddr cat) groups)) | |
461 (gnus-category-write))) | |
462 | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
463 (defun gnus-agent-remove-group (arg) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
464 "Remove the current group from its agent category, if any." |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
465 (interactive "P") |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
466 (let (c) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
467 (gnus-group-iterate arg |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
468 (lambda (group) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
469 (when (cadddr (setq c (gnus-group-category group))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
470 (setf (cadddr c) (delete group (cadddr c)))))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
471 (gnus-category-write))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
472 |
32985
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
473 (defun gnus-agent-synchronize-flags () |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
474 "Synchronize unplugged flags with servers." |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
475 (interactive) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
476 (save-excursion |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
477 (dolist (gnus-command-method gnus-agent-covered-methods) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
478 (when (file-exists-p (gnus-agent-lib-file "flags")) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
479 (gnus-agent-synchronize-flags-server gnus-command-method))))) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
480 |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
481 (defun gnus-agent-possibly-synchronize-flags () |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
482 "Synchronize flags according to `gnus-agent-synchronize-flags'." |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
483 (interactive) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
484 (save-excursion |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
485 (dolist (gnus-command-method gnus-agent-covered-methods) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
486 (when (file-exists-p (gnus-agent-lib-file "flags")) |
32985
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
487 (gnus-agent-possibly-synchronize-flags-server gnus-command-method))))) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
488 |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
489 (defun gnus-agent-synchronize-flags-server (method) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
490 "Synchronize flags set when unplugged for server." |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
491 (let ((gnus-command-method method)) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
492 (when (file-exists-p (gnus-agent-lib-file "flags")) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
493 (set-buffer (get-buffer-create " *Gnus Agent flag synchronize*")) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
494 (erase-buffer) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
495 (nnheader-insert-file-contents (gnus-agent-lib-file "flags")) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
496 (if (null (gnus-check-server gnus-command-method)) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
497 (message "Couldn't open server %s" (nth 1 gnus-command-method)) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
498 (while (not (eobp)) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
499 (if (null (eval (read (current-buffer)))) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
500 (progn (forward-line) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
501 (kill-line -1)) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
502 (write-file (gnus-agent-lib-file "flags")) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
503 (error "Couldn't set flags from file %s" |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
504 (gnus-agent-lib-file "flags")))) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
505 (delete-file (gnus-agent-lib-file "flags"))) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
506 (kill-buffer nil)))) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
507 |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
508 (defun gnus-agent-possibly-synchronize-flags-server (method) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
509 "Synchronize flags for server according to `gnus-agent-synchronize-flags'." |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
510 (when (or (and gnus-agent-synchronize-flags |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
511 (not (eq gnus-agent-synchronize-flags 'ask))) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
512 (and (eq gnus-agent-synchronize-flags 'ask) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
513 (gnus-y-or-n-p (format "Synchronize flags on server `%s'? " |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
514 (cadr method))))) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
515 (gnus-agent-synchronize-flags-server method))) |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
516 |
24358 | 517 ;;; |
518 ;;; Server mode commands | |
519 ;;; | |
520 | |
521 (defun gnus-agent-add-server (server) | |
522 "Enroll SERVER in the agent program." | |
523 (interactive (list (gnus-server-server-name))) | |
524 (unless server | |
525 (error "No server on the current line")) | |
526 (let ((method (gnus-server-get-method nil (gnus-server-server-name)))) | |
527 (when (member method gnus-agent-covered-methods) | |
528 (error "Server already in the agent program")) | |
529 (push method gnus-agent-covered-methods) | |
530 (gnus-agent-write-servers) | |
531 (message "Entered %s into the Agent" server))) | |
532 | |
533 (defun gnus-agent-remove-server (server) | |
534 "Remove SERVER from the agent program." | |
535 (interactive (list (gnus-server-server-name))) | |
536 (unless server | |
537 (error "No server on the current line")) | |
538 (let ((method (gnus-server-get-method nil (gnus-server-server-name)))) | |
539 (unless (member method gnus-agent-covered-methods) | |
540 (error "Server not in the agent program")) | |
541 (setq gnus-agent-covered-methods | |
542 (delete method gnus-agent-covered-methods)) | |
543 (gnus-agent-write-servers) | |
544 (message "Removed %s from the agent" server))) | |
545 | |
546 (defun gnus-agent-read-servers () | |
547 "Read the alist of covered servers." | |
548 (setq gnus-agent-covered-methods | |
549 (gnus-agent-read-file | |
550 (nnheader-concat gnus-agent-directory "lib/servers")))) | |
551 | |
552 (defun gnus-agent-write-servers () | |
553 "Write the alist of covered servers." | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
554 (gnus-make-directory (nnheader-concat gnus-agent-directory "lib")) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
555 (let ((coding-system-for-write nnheader-file-coding-system) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
556 (file-name-coding-system nnmail-pathname-coding-system)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
557 (with-temp-file (nnheader-concat gnus-agent-directory "lib/servers") |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
558 (prin1 gnus-agent-covered-methods (current-buffer))))) |
24358 | 559 |
560 ;;; | |
561 ;;; Summary commands | |
562 ;;; | |
563 | |
564 (defun gnus-agent-mark-article (n &optional unmark) | |
565 "Mark the next N articles as downloadable. | |
566 If N is negative, mark backward instead. If UNMARK is non-nil, remove | |
567 the mark instead. The difference between N and the actual number of | |
568 articles marked is returned." | |
569 (interactive "p") | |
570 (let ((backward (< n 0)) | |
571 (n (abs n))) | |
572 (while (and | |
573 (> n 0) | |
574 (progn | |
575 (gnus-summary-set-agent-mark | |
576 (gnus-summary-article-number) unmark) | |
577 (zerop (gnus-summary-next-subject (if backward -1 1) nil t)))) | |
578 (setq n (1- n))) | |
579 (when (/= 0 n) | |
580 (gnus-message 7 "No more articles")) | |
581 (gnus-summary-recenter) | |
582 (gnus-summary-position-point) | |
583 n)) | |
584 | |
585 (defun gnus-agent-unmark-article (n) | |
586 "Remove the downloadable mark from the next N articles. | |
587 If N is negative, unmark backward instead. The difference between N and | |
588 the actual number of articles unmarked is returned." | |
589 (interactive "p") | |
590 (gnus-agent-mark-article n t)) | |
591 | |
592 (defun gnus-agent-toggle-mark (n) | |
593 "Toggle the downloadable mark from the next N articles. | |
594 If N is negative, toggle backward instead. The difference between N and | |
595 the actual number of articles toggled is returned." | |
596 (interactive "p") | |
597 (gnus-agent-mark-article n 'toggle)) | |
598 | |
599 (defun gnus-summary-set-agent-mark (article &optional unmark) | |
600 "Mark ARTICLE as downloadable." | |
601 (let ((unmark (if (and (not (null unmark)) (not (eq t unmark))) | |
602 (memq article gnus-newsgroup-downloadable) | |
603 unmark))) | |
604 (if unmark | |
605 (progn | |
606 (setq gnus-newsgroup-downloadable | |
607 (delq article gnus-newsgroup-downloadable)) | |
608 (push article gnus-newsgroup-undownloaded)) | |
609 (setq gnus-newsgroup-undownloaded | |
610 (delq article gnus-newsgroup-undownloaded)) | |
611 (push article gnus-newsgroup-downloadable)) | |
612 (gnus-summary-update-mark | |
613 (if unmark gnus-undownloaded-mark gnus-downloadable-mark) | |
614 'unread))) | |
615 | |
616 (defun gnus-agent-get-undownloaded-list () | |
617 "Mark all unfetched articles as read." | |
618 (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))) | |
619 (when (and (not gnus-plugged) | |
620 (gnus-agent-method-p gnus-command-method)) | |
621 (gnus-agent-load-alist gnus-newsgroup-name) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
622 ;; First mark all undownloaded articles as undownloaded. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
623 (let ((articles (append gnus-newsgroup-unreads |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
624 gnus-newsgroup-marked |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
625 gnus-newsgroup-dormant)) |
24358 | 626 article) |
627 (while (setq article (pop articles)) | |
628 (unless (or (cdr (assq article gnus-agent-article-alist)) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
629 (memq article gnus-newsgroup-downloadable) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
630 (memq article gnus-newsgroup-cached)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
631 (push article gnus-newsgroup-undownloaded)))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
632 ;; Then mark downloaded downloadable as not-downloadable, |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
633 ;; if you get my drift. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
634 (let ((articles gnus-newsgroup-downloadable) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
635 article) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
636 (while (setq article (pop articles)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
637 (when (cdr (assq article gnus-agent-article-alist)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
638 (setq gnus-newsgroup-downloadable |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
639 (delq article gnus-newsgroup-downloadable)))))))) |
24358 | 640 |
641 (defun gnus-agent-catchup () | |
642 "Mark all undownloaded articles as read." | |
643 (interactive) | |
644 (save-excursion | |
645 (while gnus-newsgroup-undownloaded | |
646 (gnus-summary-mark-article | |
647 (pop gnus-newsgroup-undownloaded) gnus-catchup-mark))) | |
648 (gnus-summary-position-point)) | |
649 | |
650 ;;; | |
651 ;;; Internal functions | |
652 ;;; | |
653 | |
654 (defun gnus-agent-save-active (method) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
655 (gnus-agent-save-active-1 method 'gnus-active-to-gnus-format)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
656 |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
657 (defun gnus-agent-save-active-1 (method function) |
24358 | 658 (when (gnus-agent-method-p method) |
659 (let* ((gnus-command-method method) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
660 (new (gnus-make-hashtable (count-lines (point-min) (point-max)))) |
24358 | 661 (file (gnus-agent-lib-file "active"))) |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
662 (funcall function nil new) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
663 (gnus-agent-write-active file new) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
664 (erase-buffer) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
665 (nnheader-insert-file-contents file)))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
666 |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
667 (defun gnus-agent-write-active (file new) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
668 (let ((orig (gnus-make-hashtable (count-lines (point-min) (point-max)))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
669 (file (gnus-agent-lib-file "active")) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
670 elem osym) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
671 (when (file-exists-p file) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
672 (with-temp-buffer |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
673 (nnheader-insert-file-contents file) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
674 (gnus-active-to-gnus-format nil orig)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
675 (mapatoms |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
676 (lambda (sym) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
677 (when (and sym (boundp sym)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
678 (if (and (boundp (setq osym (intern (symbol-name sym) orig))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
679 (setq elem (symbol-value osym))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
680 (setcdr elem (cdr (symbol-value sym))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
681 (set (intern (symbol-name sym) orig) (symbol-value sym))))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
682 new)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
683 (gnus-make-directory (file-name-directory file)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
684 (let ((coding-system-for-write gnus-agent-file-coding-system)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
685 ;; The hashtable contains real names of groups, no more prefix |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
686 ;; removing, so set `full' to `t'. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
687 (gnus-write-active-file file orig t)))) |
24358 | 688 |
689 (defun gnus-agent-save-groups (method) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
690 (gnus-agent-save-active-1 method 'gnus-groups-to-gnus-format)) |
24358 | 691 |
692 (defun gnus-agent-save-group-info (method group active) | |
693 (when (gnus-agent-method-p method) | |
694 (let* ((gnus-command-method method) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
695 (coding-system-for-write nnheader-file-coding-system) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
696 (file-name-coding-system nnmail-pathname-coding-system) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
697 (file (gnus-agent-lib-file "active")) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
698 oactive) |
24358 | 699 (gnus-make-directory (file-name-directory file)) |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
700 (with-temp-file file |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
701 ;; Emacs got problem to match non-ASCII group in multibyte buffer. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
702 (mm-disable-multibyte) |
24358 | 703 (when (file-exists-p file) |
704 (nnheader-insert-file-contents file)) | |
705 (goto-char (point-min)) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
706 (when (re-search-forward |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
707 (concat "^" (regexp-quote group) " ") nil t) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
708 (save-excursion |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
709 (save-restriction |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
710 (narrow-to-region (match-beginning 0) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
711 (progn |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
712 (forward-line 1) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
713 (point))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
714 (setq oactive (car (nnmail-parse-active))))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
715 (gnus-delete-line)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
716 (insert (format "%S %d %d y\n" (intern group) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
717 (cdr active) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
718 (or (car oactive) (car active)))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
719 (goto-char (point-max)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
720 (while (search-backward "\\." nil t) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
721 (delete-char 1)))))) |
24358 | 722 |
723 (defun gnus-agent-group-path (group) | |
724 "Translate GROUP into a path." | |
725 (if nnmail-use-long-file-names | |
726 (gnus-group-real-name group) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
727 (nnheader-translate-file-chars |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
728 (nnheader-replace-chars-in-string |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
729 (nnheader-replace-duplicate-chars-in-string |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
730 (nnheader-replace-chars-in-string |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
731 (gnus-group-real-name group) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
732 ?/ ?_) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
733 ?. ?_) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
734 ?. ?/)))) |
24358 | 735 |
736 | |
737 | |
738 (defun gnus-agent-method-p (method) | |
739 "Say whether METHOD is covered by the agent." | |
740 (member method gnus-agent-covered-methods)) | |
741 | |
742 (defun gnus-agent-get-function (method) | |
743 (if (and (not gnus-plugged) | |
744 (gnus-agent-method-p method)) | |
745 (progn | |
746 (require 'nnagent) | |
747 'nnagent) | |
748 (car method))) | |
749 | |
750 ;;; History functions | |
751 | |
752 (defun gnus-agent-history-buffer () | |
753 (cdr (assoc (gnus-agent-method) gnus-agent-history-buffers))) | |
754 | |
755 (defun gnus-agent-open-history () | |
756 (save-excursion | |
757 (push (cons (gnus-agent-method) | |
758 (set-buffer (gnus-get-buffer-create | |
759 (format " *Gnus agent %s history*" | |
760 (gnus-agent-method))))) | |
761 gnus-agent-history-buffers) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
762 (mm-disable-multibyte) ;; everything is binary |
24358 | 763 (erase-buffer) |
764 (insert "\n") | |
765 (let ((file (gnus-agent-lib-file "history"))) | |
766 (when (file-exists-p file) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
767 (nnheader-insert-file-contents file)) |
24358 | 768 (set (make-local-variable 'gnus-agent-file-name) file)))) |
769 | |
770 (defun gnus-agent-save-history () | |
771 (save-excursion | |
772 (set-buffer gnus-agent-current-history) | |
773 (gnus-make-directory (file-name-directory gnus-agent-file-name)) | |
774 (let ((coding-system-for-write gnus-agent-file-coding-system)) | |
775 (write-region (1+ (point-min)) (point-max) | |
776 gnus-agent-file-name nil 'silent)))) | |
777 | |
778 (defun gnus-agent-close-history () | |
779 (when (gnus-buffer-live-p gnus-agent-current-history) | |
780 (kill-buffer gnus-agent-current-history) | |
781 (setq gnus-agent-history-buffers | |
782 (delq (assoc (gnus-agent-method) gnus-agent-history-buffers) | |
783 gnus-agent-history-buffers)))) | |
784 | |
785 (defun gnus-agent-enter-history (id group-arts date) | |
786 (save-excursion | |
787 (set-buffer gnus-agent-current-history) | |
788 (goto-char (point-max)) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
789 (let ((p (point))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
790 (insert id "\t" (number-to-string date) "\t") |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
791 (while group-arts |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
792 (insert (format "%S" (intern (caar group-arts))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
793 " " (number-to-string (cdr (pop group-arts))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
794 " ")) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
795 (insert "\n") |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
796 (while (search-backward "\\." p t) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
797 (delete-char 1))))) |
24358 | 798 |
799 (defun gnus-agent-article-in-history-p (id) | |
800 (save-excursion | |
801 (set-buffer (gnus-agent-history-buffer)) | |
802 (goto-char (point-min)) | |
803 (search-forward (concat "\n" id "\t") nil t))) | |
804 | |
805 (defun gnus-agent-history-path (id) | |
806 (save-excursion | |
807 (set-buffer (gnus-agent-history-buffer)) | |
808 (goto-char (point-min)) | |
809 (when (search-forward (concat "\n" id "\t") nil t) | |
810 (let ((method (gnus-agent-method))) | |
811 (let (paths group) | |
812 (while (not (numberp (setq group (read (current-buffer))))) | |
813 (push (concat method "/" group) paths)) | |
814 (nreverse paths)))))) | |
815 | |
816 ;;; | |
817 ;;; Fetching | |
818 ;;; | |
819 | |
820 (defun gnus-agent-fetch-articles (group articles) | |
821 "Fetch ARTICLES from GROUP and put them into the Agent." | |
822 (when articles | |
823 ;; Prune off articles that we have already fetched. | |
824 (while (and articles | |
825 (cdr (assq (car articles) gnus-agent-article-alist))) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
826 (pop articles)) |
24358 | 827 (let ((arts articles)) |
828 (while (cdr arts) | |
829 (if (cdr (assq (cadr arts) gnus-agent-article-alist)) | |
830 (setcdr arts (cddr arts)) | |
831 (setq arts (cdr arts))))) | |
832 (when articles | |
833 (let ((dir (concat | |
834 (gnus-agent-directory) | |
835 (gnus-agent-group-path group) "/")) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
836 (date (time-to-days (current-time))) |
24358 | 837 (case-fold-search t) |
838 pos crosses id elem) | |
839 (gnus-make-directory dir) | |
840 (gnus-message 7 "Fetching articles for %s..." group) | |
841 ;; Fetch the articles from the backend. | |
842 (if (gnus-check-backend-function 'retrieve-articles group) | |
843 (setq pos (gnus-retrieve-articles articles group)) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
844 (with-temp-buffer |
24358 | 845 (let (article) |
846 (while (setq article (pop articles)) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
847 (when (or |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
848 (gnus-backlog-request-article group article |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
849 nntp-server-buffer) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
850 (gnus-request-article article group)) |
24358 | 851 (goto-char (point-max)) |
852 (push (cons article (point)) pos) | |
853 (insert-buffer-substring nntp-server-buffer))) | |
854 (copy-to-buffer nntp-server-buffer (point-min) (point-max)) | |
855 (setq pos (nreverse pos))))) | |
856 ;; Then save these articles into the Agent. | |
857 (save-excursion | |
858 (set-buffer nntp-server-buffer) | |
859 (while pos | |
860 (narrow-to-region (cdar pos) (or (cdadr pos) (point-max))) | |
861 (goto-char (point-min)) | |
862 (when (search-forward "\n\n" nil t) | |
863 (when (search-backward "\nXrefs: " nil t) | |
864 ;; Handle crossposting. | |
865 (skip-chars-forward "^ ") | |
866 (skip-chars-forward " ") | |
867 (setq crosses nil) | |
868 (while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) +") | |
869 (push (cons (buffer-substring (match-beginning 1) | |
870 (match-end 1)) | |
871 (buffer-substring (match-beginning 2) | |
872 (match-end 2))) | |
873 crosses) | |
874 (goto-char (match-end 0))) | |
875 (gnus-agent-crosspost crosses (caar pos)))) | |
876 (goto-char (point-min)) | |
877 (if (not (re-search-forward "^Message-ID: *<\\([^>\n]+\\)>" nil t)) | |
878 (setq id "No-Message-ID-in-article") | |
879 (setq id (buffer-substring (match-beginning 1) (match-end 1)))) | |
880 (let ((coding-system-for-write | |
881 gnus-agent-file-coding-system)) | |
882 (write-region (point-min) (point-max) | |
883 (concat dir (number-to-string (caar pos))) | |
884 nil 'silent)) | |
885 (when (setq elem (assq (caar pos) gnus-agent-article-alist)) | |
886 (setcdr elem t)) | |
887 (gnus-agent-enter-history | |
888 id (or crosses (list (cons group (caar pos)))) date) | |
889 (widen) | |
890 (pop pos))) | |
891 (gnus-agent-save-alist group))))) | |
892 | |
893 (defun gnus-agent-crosspost (crosses article) | |
894 (let (gnus-agent-article-alist group alist beg end) | |
895 (save-excursion | |
896 (set-buffer gnus-agent-overview-buffer) | |
897 (when (nnheader-find-nov-line article) | |
898 (forward-word 1) | |
899 (setq beg (point)) | |
900 (setq end (progn (forward-line 1) (point))))) | |
901 (while crosses | |
902 (setq group (caar crosses)) | |
903 (unless (setq alist (assoc group gnus-agent-group-alist)) | |
904 (push (setq alist (list group (gnus-agent-load-alist (caar crosses)))) | |
905 gnus-agent-group-alist)) | |
906 (setcdr alist (cons (cons (cdar crosses) t) (cdr alist))) | |
907 (save-excursion | |
908 (set-buffer (gnus-get-buffer-create (format " *Gnus agent overview %s*" | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
909 group))) |
24358 | 910 (when (= (point-max) (point-min)) |
911 (push (cons group (current-buffer)) gnus-agent-buffer-alist) | |
912 (ignore-errors | |
913 (nnheader-insert-file-contents | |
914 (gnus-agent-article-name ".overview" group)))) | |
915 (nnheader-find-nov-line (string-to-number (cdar crosses))) | |
916 (insert (string-to-number (cdar crosses))) | |
917 (insert-buffer-substring gnus-agent-overview-buffer beg end)) | |
918 (pop crosses)))) | |
919 | |
920 (defun gnus-agent-flush-cache () | |
921 (save-excursion | |
922 (while gnus-agent-buffer-alist | |
923 (set-buffer (cdar gnus-agent-buffer-alist)) | |
924 (let ((coding-system-for-write | |
925 gnus-agent-file-coding-system)) | |
926 (write-region (point-min) (point-max) | |
927 (gnus-agent-article-name ".overview" | |
928 (caar gnus-agent-buffer-alist)) | |
929 nil 'silent)) | |
930 (pop gnus-agent-buffer-alist)) | |
931 (while gnus-agent-group-alist | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
932 (with-temp-file (caar gnus-agent-group-alist) |
24358 | 933 (princ (cdar gnus-agent-group-alist)) |
934 (insert "\n")) | |
935 (pop gnus-agent-group-alist)))) | |
936 | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
937 (if (fboundp 'union) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
938 (defalias 'gnus-agent-union 'union) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
939 (defun gnus-agent-union (l1 l2) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
940 "Set union of lists L1 and L2." |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
941 (cond ((null l1) l2) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
942 ((null l2) l1) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
943 ((equal l1 l2) l1) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
944 (t |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
945 (or (>= (length l1) (length l2)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
946 (setq l1 (prog1 l2 (setq l2 l1)))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
947 (while l2 |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
948 (or (memq (car l2) l1) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
949 (push (car l2) l1)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
950 (pop l2)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
951 l1)))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
952 |
24358 | 953 (defun gnus-agent-fetch-headers (group &optional force) |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
954 (let ((articles (gnus-list-of-unread-articles group)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
955 (gnus-decode-encoded-word-function 'identity) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
956 (file (gnus-agent-article-name ".overview" group))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
957 ;; Add article with marks to list of article headers we want to fetch. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
958 (dolist (arts (gnus-info-marks (gnus-get-info group))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
959 (setq articles (gnus-agent-union (gnus-uncompress-sequence (cdr arts)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
960 articles))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
961 (setq articles (sort articles '<)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
962 ;; Remove known articles. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
963 (when (gnus-agent-load-alist group) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
964 (setq articles (gnus-sorted-intersection |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
965 articles |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
966 (gnus-uncompress-range |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
967 (cons (1+ (caar (last gnus-agent-article-alist))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
968 (cdr (gnus-active group))))))) |
24358 | 969 ;; Fetch them. |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
970 (gnus-make-directory (nnheader-translate-file-chars |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
971 (file-name-directory file) t)) |
24358 | 972 (when articles |
973 (gnus-message 7 "Fetching headers for %s..." group) | |
974 (save-excursion | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
975 (set-buffer nntp-server-buffer) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
976 (unless (eq 'nov (gnus-retrieve-headers articles group)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
977 (nnvirtual-convert-headers)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
978 ;; Save these headers for later processing. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
979 (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
980 (when (file-exists-p file) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
981 (gnus-agent-braid-nov group articles file)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
982 (let ((coding-system-for-write |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
983 gnus-agent-file-coding-system)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
984 (write-region (point-min) (point-max) file nil 'silent)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
985 (gnus-agent-save-alist group articles nil) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
986 (gnus-agent-enter-history |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
987 "last-header-fetched-for-session" |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
988 (list (cons group (nth (- (length articles) 1) articles))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
989 (time-to-days (current-time))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
990 articles)))) |
24358 | 991 |
992 (defsubst gnus-agent-copy-nov-line (article) | |
993 (let (b e) | |
994 (set-buffer gnus-agent-overview-buffer) | |
995 (setq b (point)) | |
996 (if (eq article (read (current-buffer))) | |
997 (setq e (progn (forward-line 1) (point))) | |
998 (progn | |
999 (beginning-of-line) | |
1000 (setq e b))) | |
1001 (set-buffer nntp-server-buffer) | |
1002 (insert-buffer-substring gnus-agent-overview-buffer b e))) | |
1003 | |
1004 (defun gnus-agent-braid-nov (group articles file) | |
1005 (set-buffer gnus-agent-overview-buffer) | |
1006 (goto-char (point-min)) | |
1007 (set-buffer nntp-server-buffer) | |
1008 (erase-buffer) | |
1009 (nnheader-insert-file-contents file) | |
1010 (goto-char (point-max)) | |
1011 (if (or (= (point-min) (point-max)) | |
1012 (progn | |
1013 (forward-line -1) | |
1014 (< (read (current-buffer)) (car articles)))) | |
1015 ;; We have only headers that are after the older headers, | |
1016 ;; so we just append them. | |
1017 (progn | |
1018 (goto-char (point-max)) | |
1019 (insert-buffer-substring gnus-agent-overview-buffer)) | |
1020 ;; We do it the hard way. | |
1021 (nnheader-find-nov-line (car articles)) | |
1022 (gnus-agent-copy-nov-line (car articles)) | |
1023 (pop articles) | |
1024 (while (and articles | |
1025 (not (eobp))) | |
1026 (while (and (not (eobp)) | |
1027 (< (read (current-buffer)) (car articles))) | |
1028 (forward-line 1)) | |
1029 (beginning-of-line) | |
1030 (unless (eobp) | |
1031 (gnus-agent-copy-nov-line (car articles)) | |
1032 (setq articles (cdr articles)))) | |
1033 (when articles | |
1034 (let (b e) | |
1035 (set-buffer gnus-agent-overview-buffer) | |
1036 (setq b (point) | |
1037 e (point-max)) | |
1038 (set-buffer nntp-server-buffer) | |
1039 (insert-buffer-substring gnus-agent-overview-buffer b e))))) | |
1040 | |
1041 (defun gnus-agent-load-alist (group &optional dir) | |
1042 "Load the article-state alist for GROUP." | |
1043 (setq gnus-agent-article-alist | |
1044 (gnus-agent-read-file | |
1045 (if dir | |
1046 (concat dir ".agentview") | |
1047 (gnus-agent-article-name ".agentview" group))))) | |
1048 | |
1049 (defun gnus-agent-save-alist (group &optional articles state dir) | |
1050 "Save the article-state alist for GROUP." | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1051 (let ((file-name-coding-system nnmail-pathname-coding-system)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1052 (with-temp-file (if dir |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1053 (concat dir ".agentview") |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1054 (gnus-agent-article-name ".agentview" group)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1055 (princ (setq gnus-agent-article-alist |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1056 (nconc gnus-agent-article-alist |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1057 (mapcar (lambda (article) (cons article state)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1058 articles))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1059 (current-buffer)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1060 (insert "\n")))) |
24358 | 1061 |
1062 (defun gnus-agent-article-name (article group) | |
1063 (concat (gnus-agent-directory) (gnus-agent-group-path group) "/" | |
1064 (if (stringp article) article (string-to-number article)))) | |
1065 | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1066 (defun gnus-agent-batch-confirmation (msg) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1067 "Show error message and return t." |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1068 (gnus-message 1 msg) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1069 t) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1070 |
24358 | 1071 ;;;###autoload |
1072 (defun gnus-agent-batch-fetch () | |
1073 "Start Gnus and fetch session." | |
1074 (interactive) | |
1075 (gnus) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1076 (let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1077 (gnus-agent-fetch-session)) |
24358 | 1078 (gnus-group-exit)) |
1079 | |
1080 (defun gnus-agent-fetch-session () | |
1081 "Fetch all articles and headers that are eligible for fetching." | |
1082 (interactive) | |
1083 (unless gnus-agent-covered-methods | |
1084 (error "No servers are covered by the Gnus agent")) | |
1085 (unless gnus-plugged | |
1086 (error "Can't fetch articles while Gnus is unplugged")) | |
1087 (let ((methods gnus-agent-covered-methods) | |
1088 groups group gnus-command-method) | |
1089 (save-excursion | |
1090 (while methods | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1091 (condition-case err |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1092 (progn |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1093 (setq gnus-command-method (car methods)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1094 (when (or (gnus-server-opened gnus-command-method) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1095 (gnus-open-server gnus-command-method)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1096 (setq groups (gnus-groups-from-server (car methods))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1097 (gnus-agent-with-fetch |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1098 (while (setq group (pop groups)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1099 (when (<= (gnus-group-level group) gnus-agent-handle-level) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1100 (gnus-agent-fetch-group-1 group gnus-command-method)))))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1101 (error |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1102 (unless (funcall gnus-agent-confirmation-function |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1103 (format "Error (%s). Continue? " err)) |
32985
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1104 (error "Cannot fetch articles into the Gnus agent."))) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1105 (quit |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1106 (unless (funcall gnus-agent-confirmation-function |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1107 (format "Quit (%s). Continue? " err)) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1108 (signal 'quit "Cannot fetch articles into the Gnus agent.")))) |
24358 | 1109 (pop methods)) |
1110 (gnus-message 6 "Finished fetching articles into the Gnus agent")))) | |
1111 | |
1112 (defun gnus-agent-fetch-group-1 (group method) | |
1113 "Fetch GROUP." | |
1114 (let ((gnus-command-method method) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1115 (gnus-newsgroup-name group) |
24358 | 1116 gnus-newsgroup-dependencies gnus-newsgroup-headers |
1117 gnus-newsgroup-scored gnus-headers gnus-score | |
1118 gnus-use-cache articles arts | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1119 category predicate info marks score-param |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1120 (gnus-summary-expunge-below gnus-summary-expunge-below) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1121 (gnus-summary-mark-below gnus-summary-mark-below) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1122 (gnus-orphan-score gnus-orphan-score) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1123 ;; Maybe some other gnus-summary local variables should also |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1124 ;; be put here. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1125 ) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1126 (unless (gnus-check-group group) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1127 (error "Can't open server for %s" group)) |
24358 | 1128 ;; Fetch headers. |
1129 (when (and (or (gnus-active group) (gnus-activate-group group)) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1130 (setq articles (gnus-agent-fetch-headers group)) |
32985
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1131 (let ((nntp-server-buffer gnus-agent-overview-buffer)) |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1132 ;; Parse them and see which articles we want to fetch. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1133 (setq gnus-newsgroup-dependencies |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1134 (make-vector (length articles) 0)) |
32985
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1135 (setq gnus-newsgroup-headers |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1136 (gnus-get-newsgroup-headers-xover articles nil nil |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1137 group)) |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1138 ;; `gnus-agent-overview-buffer' may be killed for |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1139 ;; timeout reason. If so, recreate it. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1140 (gnus-agent-create-buffer))) |
24358 | 1141 (setq category (gnus-group-category group)) |
1142 (setq predicate | |
1143 (gnus-get-predicate | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1144 (or (gnus-group-find-parameter group 'agent-predicate t) |
24358 | 1145 (cadr category)))) |
32985
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1146 (if (memq (caaddr predicate) '(gnus-agent-true gnus-agent-false)) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1147 ;; Simple implementation |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1148 (setq arts |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1149 (and (eq (caaddr predicate) 'gnus-agent-true) articles)) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1150 (setq arts nil) |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1151 (setq score-param |
32985
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1152 (or (gnus-group-get-parameter group 'agent-score t) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1153 (caddr category))) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1154 ;; Translate score-param into real one |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1155 (cond |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1156 ((not score-param)) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1157 ((eq score-param 'file) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1158 (setq score-param (gnus-all-score-files group))) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1159 ((stringp (car score-param))) |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1160 (t |
2e19cd4c5909
2000-10-27 Simon Josefsson <simon@josefsson.org>
Dave Love <fx@gnu.org>
parents:
31716
diff
changeset
|
1161 (setq score-param (list (list score-param))))) |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1162 (when score-param |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1163 (gnus-score-headers score-param)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1164 (while (setq gnus-headers (pop gnus-newsgroup-headers)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1165 (setq gnus-score |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1166 (or (cdr (assq (mail-header-number gnus-headers) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1167 gnus-newsgroup-scored)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1168 gnus-summary-default-score)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1169 (when (funcall predicate) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1170 (push (mail-header-number gnus-headers) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1171 arts)))) |
24358 | 1172 ;; Fetch the articles. |
1173 (when arts | |
1174 (gnus-agent-fetch-articles group arts))) | |
1175 ;; Perhaps we have some additional articles to fetch. | |
1176 (setq arts (assq 'download (gnus-info-marks | |
1177 (setq info (gnus-get-info group))))) | |
1178 (when (cdr arts) | |
1179 (gnus-agent-fetch-articles | |
1180 group (gnus-uncompress-range (cdr arts))) | |
1181 (setq marks (delq arts (gnus-info-marks info))) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1182 (gnus-info-set-marks info marks) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1183 (gnus-dribble-enter |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1184 (concat "(gnus-group-set-info '" |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1185 (gnus-prin1-to-string info) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1186 ")"))))) |
24358 | 1187 |
1188 ;;; | |
1189 ;;; Agent Category Mode | |
1190 ;;; | |
1191 | |
1192 (defvar gnus-category-mode-hook nil | |
1193 "Hook run in `gnus-category-mode' buffers.") | |
1194 | |
1195 (defvar gnus-category-line-format " %(%20c%): %g\n" | |
1196 "Format of category lines.") | |
1197 | |
1198 (defvar gnus-category-mode-line-format "Gnus: %%b" | |
1199 "The format specification for the category mode line.") | |
1200 | |
1201 (defvar gnus-agent-short-article 100 | |
1202 "Articles that have fewer lines than this are short.") | |
1203 | |
1204 (defvar gnus-agent-long-article 200 | |
1205 "Articles that have more lines than this are long.") | |
1206 | |
1207 (defvar gnus-agent-low-score 0 | |
1208 "Articles that have a score lower than this have a low score.") | |
1209 | |
1210 (defvar gnus-agent-high-score 0 | |
1211 "Articles that have a score higher than this have a high score.") | |
1212 | |
1213 | |
1214 ;;; Internal variables. | |
1215 | |
1216 (defvar gnus-category-buffer "*Agent Category*") | |
1217 | |
1218 (defvar gnus-category-line-format-alist | |
1219 `((?c gnus-tmp-name ?s) | |
1220 (?g gnus-tmp-groups ?d))) | |
1221 | |
1222 (defvar gnus-category-mode-line-format-alist | |
1223 `((?u user-defined ?s))) | |
1224 | |
1225 (defvar gnus-category-line-format-spec nil) | |
1226 (defvar gnus-category-mode-line-format-spec nil) | |
1227 | |
1228 (defvar gnus-category-mode-map nil) | |
1229 (put 'gnus-category-mode 'mode-class 'special) | |
1230 | |
1231 (unless gnus-category-mode-map | |
1232 (setq gnus-category-mode-map (make-sparse-keymap)) | |
1233 (suppress-keymap gnus-category-mode-map) | |
1234 | |
1235 (gnus-define-keys gnus-category-mode-map | |
1236 "q" gnus-category-exit | |
1237 "k" gnus-category-kill | |
1238 "c" gnus-category-copy | |
1239 "a" gnus-category-add | |
1240 "p" gnus-category-edit-predicate | |
1241 "g" gnus-category-edit-groups | |
1242 "s" gnus-category-edit-score | |
1243 "l" gnus-category-list | |
1244 | |
1245 "\C-c\C-i" gnus-info-find-node | |
1246 "\C-c\C-b" gnus-bug)) | |
1247 | |
1248 (defvar gnus-category-menu-hook nil | |
1249 "*Hook run after the creation of the menu.") | |
1250 | |
1251 (defun gnus-category-make-menu-bar () | |
1252 (gnus-turn-off-edit-menu 'category) | |
1253 (unless (boundp 'gnus-category-menu) | |
1254 (easy-menu-define | |
1255 gnus-category-menu gnus-category-mode-map "" | |
1256 '("Categories" | |
1257 ["Add" gnus-category-add t] | |
1258 ["Kill" gnus-category-kill t] | |
1259 ["Copy" gnus-category-copy t] | |
1260 ["Edit predicate" gnus-category-edit-predicate t] | |
1261 ["Edit score" gnus-category-edit-score t] | |
1262 ["Edit groups" gnus-category-edit-groups t] | |
1263 ["Exit" gnus-category-exit t])) | |
1264 | |
1265 (gnus-run-hooks 'gnus-category-menu-hook))) | |
1266 | |
1267 (defun gnus-category-mode () | |
1268 "Major mode for listing and editing agent categories. | |
1269 | |
1270 All normal editing commands are switched off. | |
1271 \\<gnus-category-mode-map> | |
1272 For more in-depth information on this mode, read the manual | |
1273 (`\\[gnus-info-find-node]'). | |
1274 | |
1275 The following commands are available: | |
1276 | |
1277 \\{gnus-category-mode-map}" | |
1278 (interactive) | |
1279 (when (gnus-visual-p 'category-menu 'menu) | |
1280 (gnus-category-make-menu-bar)) | |
1281 (kill-all-local-variables) | |
1282 (gnus-simplify-mode-line) | |
1283 (setq major-mode 'gnus-category-mode) | |
1284 (setq mode-name "Category") | |
1285 (gnus-set-default-directory) | |
1286 (setq mode-line-process nil) | |
1287 (use-local-map gnus-category-mode-map) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1288 (buffer-disable-undo) |
24358 | 1289 (setq truncate-lines t) |
1290 (setq buffer-read-only t) | |
1291 (gnus-run-hooks 'gnus-category-mode-hook)) | |
1292 | |
1293 (defalias 'gnus-category-position-point 'gnus-goto-colon) | |
1294 | |
1295 (defun gnus-category-insert-line (category) | |
1296 (let* ((gnus-tmp-name (car category)) | |
1297 (gnus-tmp-groups (length (cadddr category)))) | |
1298 (beginning-of-line) | |
1299 (gnus-add-text-properties | |
1300 (point) | |
1301 (prog1 (1+ (point)) | |
1302 ;; Insert the text. | |
1303 (eval gnus-category-line-format-spec)) | |
1304 (list 'gnus-category gnus-tmp-name)))) | |
1305 | |
1306 (defun gnus-enter-category-buffer () | |
1307 "Go to the Category buffer." | |
1308 (interactive) | |
1309 (gnus-category-setup-buffer) | |
1310 (gnus-configure-windows 'category) | |
1311 (gnus-category-prepare)) | |
1312 | |
1313 (defun gnus-category-setup-buffer () | |
1314 (unless (get-buffer gnus-category-buffer) | |
1315 (save-excursion | |
1316 (set-buffer (gnus-get-buffer-create gnus-category-buffer)) | |
1317 (gnus-category-mode)))) | |
1318 | |
1319 (defun gnus-category-prepare () | |
1320 (gnus-set-format 'category-mode) | |
1321 (gnus-set-format 'category t) | |
1322 (let ((alist gnus-category-alist) | |
1323 (buffer-read-only nil)) | |
1324 (erase-buffer) | |
1325 (while alist | |
1326 (gnus-category-insert-line (pop alist))) | |
1327 (goto-char (point-min)) | |
1328 (gnus-category-position-point))) | |
1329 | |
1330 (defun gnus-category-name () | |
1331 (or (get-text-property (gnus-point-at-bol) 'gnus-category) | |
1332 (error "No category on the current line"))) | |
1333 | |
1334 (defun gnus-category-read () | |
1335 "Read the category alist." | |
1336 (setq gnus-category-alist | |
1337 (or (gnus-agent-read-file | |
1338 (nnheader-concat gnus-agent-directory "lib/categories")) | |
1339 (list (list 'default 'short nil nil))))) | |
1340 | |
1341 (defun gnus-category-write () | |
1342 "Write the category alist." | |
1343 (setq gnus-category-predicate-cache nil | |
1344 gnus-category-group-cache nil) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1345 (gnus-make-directory (nnheader-concat gnus-agent-directory "lib")) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1346 (with-temp-file (nnheader-concat gnus-agent-directory "lib/categories") |
24358 | 1347 (prin1 gnus-category-alist (current-buffer)))) |
1348 | |
1349 (defun gnus-category-edit-predicate (category) | |
1350 "Edit the predicate for CATEGORY." | |
1351 (interactive (list (gnus-category-name))) | |
1352 (let ((info (assq category gnus-category-alist))) | |
1353 (gnus-edit-form | |
1354 (cadr info) (format "Editing the predicate for category %s" category) | |
1355 `(lambda (predicate) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1356 (setcar (cdr (assq ',category gnus-category-alist)) predicate) |
24358 | 1357 (gnus-category-write) |
1358 (gnus-category-list))))) | |
1359 | |
1360 (defun gnus-category-edit-score (category) | |
1361 "Edit the score expression for CATEGORY." | |
1362 (interactive (list (gnus-category-name))) | |
1363 (let ((info (assq category gnus-category-alist))) | |
1364 (gnus-edit-form | |
1365 (caddr info) | |
1366 (format "Editing the score expression for category %s" category) | |
1367 `(lambda (groups) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1368 (setcar (cddr (assq ',category gnus-category-alist)) groups) |
24358 | 1369 (gnus-category-write) |
1370 (gnus-category-list))))) | |
1371 | |
1372 (defun gnus-category-edit-groups (category) | |
1373 "Edit the group list for CATEGORY." | |
1374 (interactive (list (gnus-category-name))) | |
1375 (let ((info (assq category gnus-category-alist))) | |
1376 (gnus-edit-form | |
1377 (cadddr info) (format "Editing the group list for category %s" category) | |
1378 `(lambda (groups) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1379 (setcar (nthcdr 3 (assq ',category gnus-category-alist)) groups) |
24358 | 1380 (gnus-category-write) |
1381 (gnus-category-list))))) | |
1382 | |
1383 (defun gnus-category-kill (category) | |
1384 "Kill the current category." | |
1385 (interactive (list (gnus-category-name))) | |
1386 (let ((info (assq category gnus-category-alist)) | |
1387 (buffer-read-only nil)) | |
1388 (gnus-delete-line) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1389 (setq gnus-category-alist (delq info gnus-category-alist)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1390 (gnus-category-write))) |
24358 | 1391 |
1392 (defun gnus-category-copy (category to) | |
1393 "Copy the current category." | |
1394 (interactive (list (gnus-category-name) (intern (read-string "New name: ")))) | |
1395 (let ((info (assq category gnus-category-alist))) | |
1396 (push (list to (gnus-copy-sequence (cadr info)) | |
1397 (gnus-copy-sequence (caddr info)) nil) | |
1398 gnus-category-alist) | |
1399 (gnus-category-write) | |
1400 (gnus-category-list))) | |
1401 | |
1402 (defun gnus-category-add (category) | |
1403 "Create a new category." | |
1404 (interactive "SCategory name: ") | |
1405 (when (assq category gnus-category-alist) | |
1406 (error "Category %s already exists" category)) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1407 (push (list category 'false nil nil) |
24358 | 1408 gnus-category-alist) |
1409 (gnus-category-write) | |
1410 (gnus-category-list)) | |
1411 | |
1412 (defun gnus-category-list () | |
1413 "List all categories." | |
1414 (interactive) | |
1415 (gnus-category-prepare)) | |
1416 | |
1417 (defun gnus-category-exit () | |
1418 "Return to the group buffer." | |
1419 (interactive) | |
1420 (kill-buffer (current-buffer)) | |
1421 (gnus-configure-windows 'group t)) | |
1422 | |
1423 ;; To avoid having 8-bit characters in the source file. | |
1424 (defvar gnus-category-not (list '! 'not (intern (format "%c" 172)))) | |
1425 | |
1426 (defvar gnus-category-predicate-alist | |
1427 '((spam . gnus-agent-spam-p) | |
1428 (short . gnus-agent-short-p) | |
1429 (long . gnus-agent-long-p) | |
1430 (low . gnus-agent-low-scored-p) | |
1431 (high . gnus-agent-high-scored-p) | |
1432 (true . gnus-agent-true) | |
1433 (false . gnus-agent-false)) | |
1434 "Mapping from short score predicate symbols to predicate functions.") | |
1435 | |
1436 (defun gnus-agent-spam-p () | |
1437 "Say whether an article is spam or not." | |
1438 (unless gnus-agent-spam-hashtb | |
1439 (setq gnus-agent-spam-hashtb (gnus-make-hashtable 1000))) | |
1440 (if (not (equal (mail-header-references gnus-headers) "")) | |
1441 nil | |
1442 (let ((string (gnus-simplify-subject (mail-header-subject gnus-headers)))) | |
1443 (prog1 | |
1444 (gnus-gethash string gnus-agent-spam-hashtb) | |
1445 (gnus-sethash string t gnus-agent-spam-hashtb))))) | |
1446 | |
1447 (defun gnus-agent-short-p () | |
1448 "Say whether an article is short or not." | |
1449 (< (mail-header-lines gnus-headers) gnus-agent-short-article)) | |
1450 | |
1451 (defun gnus-agent-long-p () | |
1452 "Say whether an article is long or not." | |
1453 (> (mail-header-lines gnus-headers) gnus-agent-long-article)) | |
1454 | |
1455 (defun gnus-agent-low-scored-p () | |
1456 "Say whether an article has a low score or not." | |
1457 (< gnus-score gnus-agent-low-score)) | |
1458 | |
1459 (defun gnus-agent-high-scored-p () | |
1460 "Say whether an article has a high score or not." | |
1461 (> gnus-score gnus-agent-high-score)) | |
1462 | |
1463 (defun gnus-category-make-function (cat) | |
1464 "Make a function from category CAT." | |
1465 `(lambda () ,(gnus-category-make-function-1 cat))) | |
1466 | |
1467 (defun gnus-agent-true () | |
1468 "Return t." | |
1469 t) | |
1470 | |
1471 (defun gnus-agent-false () | |
1472 "Return nil." | |
1473 nil) | |
1474 | |
1475 (defun gnus-category-make-function-1 (cat) | |
1476 "Make a function from category CAT." | |
1477 (cond | |
1478 ;; Functions are just returned as is. | |
1479 ((or (symbolp cat) | |
1480 (gnus-functionp cat)) | |
1481 `(,(or (cdr (assq cat gnus-category-predicate-alist)) | |
1482 cat))) | |
1483 ;; More complex category. | |
1484 ((consp cat) | |
1485 `(,(cond | |
1486 ((memq (car cat) '(& and)) | |
1487 'and) | |
1488 ((memq (car cat) '(| or)) | |
1489 'or) | |
1490 ((memq (car cat) gnus-category-not) | |
1491 'not)) | |
1492 ,@(mapcar 'gnus-category-make-function-1 (cdr cat)))) | |
1493 (t | |
1494 (error "Unknown category type: %s" cat)))) | |
1495 | |
1496 (defun gnus-get-predicate (predicate) | |
1497 "Return the predicate for CATEGORY." | |
1498 (or (cdr (assoc predicate gnus-category-predicate-cache)) | |
1499 (cdar (push (cons predicate | |
1500 (gnus-category-make-function predicate)) | |
1501 gnus-category-predicate-cache)))) | |
1502 | |
1503 (defun gnus-group-category (group) | |
1504 "Return the category GROUP belongs to." | |
1505 (unless gnus-category-group-cache | |
1506 (setq gnus-category-group-cache (gnus-make-hashtable 1000)) | |
1507 (let ((cs gnus-category-alist) | |
1508 groups cat) | |
1509 (while (setq cat (pop cs)) | |
1510 (setq groups (cadddr cat)) | |
1511 (while groups | |
1512 (gnus-sethash (pop groups) cat gnus-category-group-cache))))) | |
1513 (or (gnus-gethash group gnus-category-group-cache) | |
1514 (assq 'default gnus-category-alist))) | |
1515 | |
1516 (defun gnus-agent-expire () | |
1517 "Expire all old articles." | |
1518 (interactive) | |
1519 (let ((methods gnus-agent-covered-methods) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1520 (day (- (time-to-days (current-time)) gnus-agent-expire-days)) |
24358 | 1521 gnus-command-method sym group articles |
1522 history overview file histories elem art nov-file low info | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1523 unreads marked article orig lowest highest) |
24358 | 1524 (save-excursion |
1525 (setq overview (gnus-get-buffer-create " *expire overview*")) | |
1526 (while (setq gnus-command-method (pop methods)) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1527 (when (file-exists-p (gnus-agent-lib-file "active")) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1528 (with-temp-buffer |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1529 (nnheader-insert-file-contents (gnus-agent-lib-file "active")) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1530 (gnus-active-to-gnus-format |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1531 gnus-command-method |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1532 (setq orig (gnus-make-hashtable |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1533 (count-lines (point-min) (point-max)))))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1534 (let ((expiry-hashtb (gnus-make-hashtable 1023))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1535 (gnus-agent-open-history) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1536 (set-buffer |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1537 (setq gnus-agent-current-history |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1538 (setq history (gnus-agent-history-buffer)))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1539 (goto-char (point-min)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1540 (when (> (buffer-size) 1) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1541 (goto-char (point-min)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1542 (while (not (eobp)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1543 (skip-chars-forward "^\t") |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1544 (if (> (read (current-buffer)) day) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1545 ;; New article; we don't expire it. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1546 (forward-line 1) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1547 ;; Old article. Schedule it for possible nuking. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1548 (while (not (eolp)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1549 (setq sym (let ((obarray expiry-hashtb) s) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1550 (setq s (read (current-buffer))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1551 (if (stringp s) (intern s) s))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1552 (if (boundp sym) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1553 (set sym (cons (cons (read (current-buffer)) (point)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1554 (symbol-value sym))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1555 (set sym (list (cons (read (current-buffer)) (point))))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1556 (skip-chars-forward " ")) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1557 (forward-line 1))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1558 ;; We now have all articles that can possibly be expired. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1559 (mapatoms |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1560 (lambda (sym) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1561 (setq group (symbol-name sym) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1562 articles (sort (symbol-value sym) 'car-less-than-car) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1563 low (car (gnus-active group)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1564 info (gnus-get-info group) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1565 unreads (ignore-errors |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1566 (gnus-list-of-unread-articles group)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1567 marked (nconc |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1568 (gnus-uncompress-range |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1569 (cdr (assq 'tick (gnus-info-marks info)))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1570 (gnus-uncompress-range |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1571 (cdr (assq 'dormant |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1572 (gnus-info-marks info))))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1573 nov-file (gnus-agent-article-name ".overview" group) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1574 lowest nil |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1575 highest nil) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1576 (gnus-agent-load-alist group) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1577 (gnus-message 5 "Expiring articles in %s" group) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1578 (set-buffer overview) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1579 (erase-buffer) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1580 (when (file-exists-p nov-file) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1581 (nnheader-insert-file-contents nov-file)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1582 (goto-char (point-min)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1583 (setq article 0) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1584 (while (setq elem (pop articles)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1585 (setq article (car elem)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1586 (when (or (null low) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1587 (< article low) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1588 gnus-agent-expire-all |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1589 (and (not (memq article unreads)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1590 (not (memq article marked)))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1591 ;; Find and nuke the NOV line. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1592 (while (and (not (eobp)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1593 (or (not (numberp |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1594 (setq art (read (current-buffer))))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1595 (< art article))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1596 (if (and (numberp art) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1597 (file-exists-p |
24358 | 1598 (gnus-agent-article-name |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1599 (number-to-string art) group))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1600 (progn |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1601 (unless lowest |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1602 (setq lowest art)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1603 (setq highest art) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1604 (forward-line 1)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1605 ;; Remove old NOV lines that have no articles. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1606 (gnus-delete-line))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1607 (if (or (eobp) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1608 (/= art article)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1609 (beginning-of-line) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1610 (gnus-delete-line)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1611 ;; Nuke the article. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1612 (when (file-exists-p |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1613 (setq file (gnus-agent-article-name |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1614 (number-to-string article) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1615 group))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1616 (delete-file file)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1617 ;; Schedule the history line for nuking. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1618 (push (cdr elem) histories))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1619 (gnus-make-directory (file-name-directory nov-file)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1620 (let ((coding-system-for-write |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1621 gnus-agent-file-coding-system)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1622 (write-region (point-min) (point-max) nov-file nil 'silent)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1623 ;; Delete the unwanted entries in the alist. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1624 (setq gnus-agent-article-alist |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1625 (sort gnus-agent-article-alist 'car-less-than-car)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1626 (let* ((alist gnus-agent-article-alist) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1627 (prev (cons nil alist)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1628 (first prev) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1629 expired) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1630 (while (and alist |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1631 (<= (caar alist) article)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1632 (if (or (not (cdar alist)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1633 (not (file-exists-p |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1634 (gnus-agent-article-name |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1635 (number-to-string |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1636 (caar alist)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1637 group)))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1638 (progn |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1639 (push (caar alist) expired) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1640 (setcdr prev (setq alist (cdr alist)))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1641 (setq prev alist |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1642 alist (cdr alist)))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1643 (setq gnus-agent-article-alist (cdr first)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1644 (gnus-agent-save-alist group) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1645 ;; Mark all articles up to the first article |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1646 ;; in `gnus-article-alist' as read. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1647 (when (and info (caar gnus-agent-article-alist)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1648 (setcar (nthcdr 2 info) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1649 (gnus-range-add |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1650 (nth 2 info) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1651 (cons 1 (- (caar gnus-agent-article-alist) 1))))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1652 ;; Maybe everything has been expired from `gnus-article-alist' |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1653 ;; and so the above marking as read could not be conducted, |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1654 ;; or there are expired article within the range of the alist. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1655 (when (and info |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1656 expired |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1657 (or (not (caar gnus-agent-article-alist)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1658 (> (car expired) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1659 (caar gnus-agent-article-alist)))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1660 (setcar (nthcdr 2 info) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1661 (gnus-add-to-range |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1662 (nth 2 info) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1663 (nreverse expired)))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1664 (gnus-dribble-enter |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1665 (concat "(gnus-group-set-info '" |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1666 (gnus-prin1-to-string info) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1667 ")"))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1668 (when lowest |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1669 (if (gnus-gethash group orig) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1670 (setcar (gnus-gethash group orig) lowest) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1671 (gnus-sethash group (cons lowest highest) orig)))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1672 expiry-hashtb) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1673 (set-buffer history) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1674 (setq histories (nreverse (sort histories '<))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1675 (while histories |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1676 (goto-char (pop histories)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1677 (gnus-delete-line)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1678 (gnus-agent-save-history) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1679 (gnus-agent-close-history) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1680 (gnus-write-active-file |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1681 (gnus-agent-lib-file "active") orig)) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24358
diff
changeset
|
1682 (gnus-message 4 "Expiry...done"))))))) |
24358 | 1683 |
1684 ;;;###autoload | |
1685 (defun gnus-agent-batch () | |
1686 (interactive) | |
1687 (let ((init-file-user "") | |
1688 (gnus-always-read-dribble-file t)) | |
1689 (gnus)) | |
1690 (gnus-group-send-drafts) | |
1691 (gnus-agent-fetch-session)) | |
1692 | |
1693 (provide 'gnus-agent) | |
1694 | |
1695 ;;; gnus-agent.el ends here |