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