1 |
;;; gnus-agent.el --- unplugged support for Gnus |
;;; gnus-agent.el --- unplugged support for Gnus |
2 |
;; Copyright (C) 1997, 1998, 1999, 2000 Free Software Foundation, Inc. |
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 |
3 |
|
;; Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
6 |
;; This file is part of GNU Emacs. |
;; This file is part of GNU Emacs. |
26 |
|
|
27 |
(require 'gnus) |
(require 'gnus) |
28 |
(require 'gnus-cache) |
(require 'gnus-cache) |
29 |
|
(require 'nnmail) |
30 |
(require 'nnvirtual) |
(require 'nnvirtual) |
31 |
(require 'gnus-sum) |
(require 'gnus-sum) |
32 |
(require 'gnus-score) |
(require 'gnus-score) |
33 |
|
(require 'gnus-srvr) |
34 |
|
(require 'gnus-util) |
35 |
(eval-when-compile |
(eval-when-compile |
36 |
(if (featurep 'xemacs) |
(if (featurep 'xemacs) |
37 |
(require 'itimer) |
(require 'itimer) |
38 |
(require 'timer)) |
(require 'timer)) |
39 |
(require 'cl)) |
(require 'cl)) |
40 |
|
|
41 |
|
(eval-and-compile |
42 |
|
(autoload 'gnus-server-update-server "gnus-srvr") |
43 |
|
(autoload 'gnus-agent-customize-category "gnus-cus") |
44 |
|
) |
45 |
|
|
46 |
(defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/") |
(defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/") |
47 |
"Where the Gnus agent will store its files." |
"Where the Gnus agent will store its files." |
48 |
:group 'gnus-agent |
:group 'gnus-agent |
58 |
:group 'gnus-agent |
:group 'gnus-agent |
59 |
:type 'hook) |
:type 'hook) |
60 |
|
|
61 |
|
(defcustom gnus-agent-fetched-hook nil |
62 |
|
"Hook run when finished fetching articles." |
63 |
|
:group 'gnus-agent |
64 |
|
:type 'hook) |
65 |
|
|
66 |
(defcustom gnus-agent-handle-level gnus-level-subscribed |
(defcustom gnus-agent-handle-level gnus-level-subscribed |
67 |
"Groups on levels higher than this variable will be ignored by the Agent." |
"Groups on levels higher than this variable will be ignored by the Agent." |
68 |
:group 'gnus-agent |
:group 'gnus-agent |
69 |
:type 'integer) |
:type 'integer) |
70 |
|
|
71 |
(defcustom gnus-agent-expire-days 7 |
(defcustom gnus-agent-expire-days 7 |
72 |
"Read articles older than this will be expired." |
"Read articles older than this will be expired. |
73 |
|
If you wish to disable Agent expiring, see `gnus-agent-enable-expiration'." |
74 |
:group 'gnus-agent |
:group 'gnus-agent |
75 |
:type 'integer) |
:type '(number :tag "days")) |
76 |
|
|
77 |
(defcustom gnus-agent-expire-all nil |
(defcustom gnus-agent-expire-all nil |
78 |
"If non-nil, also expire unread, ticked and dormant articles. |
"If non-nil, also expire unread, ticked and dormant articles. |
85 |
:group 'gnus-agent |
:group 'gnus-agent |
86 |
:type 'hook) |
:type 'hook) |
87 |
|
|
88 |
|
;; Extracted from gnus-xmas-redefine in order to preserve user settings |
89 |
|
(when (featurep 'xemacs) |
90 |
|
(add-hook 'gnus-agent-group-mode-hook 'gnus-xmas-agent-group-menu-add)) |
91 |
|
|
92 |
(defcustom gnus-agent-summary-mode-hook nil |
(defcustom gnus-agent-summary-mode-hook nil |
93 |
"Hook run in Agent summary minor modes." |
"Hook run in Agent summary minor modes." |
94 |
:group 'gnus-agent |
:group 'gnus-agent |
95 |
:type 'hook) |
:type 'hook) |
96 |
|
|
97 |
|
;; Extracted from gnus-xmas-redefine in order to preserve user settings |
98 |
|
(when (featurep 'xemacs) |
99 |
|
(add-hook 'gnus-agent-summary-mode-hook 'gnus-xmas-agent-summary-menu-add)) |
100 |
|
|
101 |
(defcustom gnus-agent-server-mode-hook nil |
(defcustom gnus-agent-server-mode-hook nil |
102 |
"Hook run in Agent summary minor modes." |
"Hook run in Agent summary minor modes." |
103 |
:group 'gnus-agent |
:group 'gnus-agent |
104 |
:type 'hook) |
:type 'hook) |
105 |
|
|
106 |
|
;; Extracted from gnus-xmas-redefine in order to preserve user settings |
107 |
|
(when (featurep 'xemacs) |
108 |
|
(add-hook 'gnus-agent-server-mode-hook 'gnus-xmas-agent-server-menu-add)) |
109 |
|
|
110 |
(defcustom gnus-agent-confirmation-function 'y-or-n-p |
(defcustom gnus-agent-confirmation-function 'y-or-n-p |
111 |
"Function to confirm when error happens." |
"Function to confirm when error happens." |
112 |
:version "21.1" |
:version "21.1" |
122 |
(const :tag "Ask" ask)) |
(const :tag "Ask" ask)) |
123 |
:group 'gnus-agent) |
:group 'gnus-agent) |
124 |
|
|
125 |
|
(defcustom gnus-agent-go-online 'ask |
126 |
|
"Indicate if offline servers go online when you plug in. |
127 |
|
If this is `ask' the hook will query the user." |
128 |
|
:version "21.1" |
129 |
|
:type '(choice (const :tag "Always" t) |
130 |
|
(const :tag "Never" nil) |
131 |
|
(const :tag "Ask" ask)) |
132 |
|
:group 'gnus-agent) |
133 |
|
|
134 |
|
(defcustom gnus-agent-mark-unread-after-downloaded t |
135 |
|
"Indicate whether to mark articles unread after downloaded." |
136 |
|
:version "21.1" |
137 |
|
:type 'boolean |
138 |
|
:group 'gnus-agent) |
139 |
|
|
140 |
|
(defcustom gnus-agent-download-marks '(download) |
141 |
|
"Marks for downloading." |
142 |
|
:version "21.1" |
143 |
|
:type '(repeat (symbol :tag "Mark")) |
144 |
|
:group 'gnus-agent) |
145 |
|
|
146 |
|
(defcustom gnus-agent-consider-all-articles nil |
147 |
|
"When non-nil, the agent will let the agent predicate decide |
148 |
|
whether articles need to be downloaded or not, for all articles. When |
149 |
|
nil, the default, the agent will only let the predicate decide |
150 |
|
whether unread articles are downloaded or not. If you enable this, |
151 |
|
groups with large active ranges may open slower and you may also want |
152 |
|
to look into the agent expiry settings to block the expiration of |
153 |
|
read articles as they would just be downloaded again." |
154 |
|
:version "21.4" |
155 |
|
:type 'boolean |
156 |
|
:group 'gnus-agent) |
157 |
|
|
158 |
|
(defcustom gnus-agent-max-fetch-size 10000000 ;; 10 Mb |
159 |
|
"Chunk size for `gnus-agent-fetch-session'. |
160 |
|
The function will split its article fetches into chunks smaller than |
161 |
|
this limit." |
162 |
|
:group 'gnus-agent |
163 |
|
:type 'integer) |
164 |
|
|
165 |
|
(defcustom gnus-agent-enable-expiration 'ENABLE |
166 |
|
"The default expiration state for each group. |
167 |
|
When set to ENABLE, the default, `gnus-agent-expire' will expire old |
168 |
|
contents from a group's local storage. This value may be overridden |
169 |
|
to disable expiration in specific categories, topics, and groups. Of |
170 |
|
course, you could change gnus-agent-enable-expiration to DISABLE then |
171 |
|
enable expiration per categories, topics, and groups." |
172 |
|
:group 'gnus-agent |
173 |
|
:type '(radio (const :format "Enable " ENABLE) |
174 |
|
(const :format "Disable " DISABLE))) |
175 |
|
|
176 |
|
(defcustom gnus-agent-expire-unagentized-dirs t |
177 |
|
"*Whether expiration should expire in unagentized directories. |
178 |
|
Have gnus-agent-expire scan the directories under |
179 |
|
\(gnus-agent-directory) for groups that are no longer agentized. |
180 |
|
When found, offer to remove them." |
181 |
|
:type 'boolean |
182 |
|
:group 'gnus-agent) |
183 |
|
|
184 |
|
(defcustom gnus-agent-auto-agentize-methods '(nntp nnimap) |
185 |
|
"Initially, all servers from these methods are agentized. |
186 |
|
The user may remove or add servers using the Server buffer. |
187 |
|
See Info node `(gnus)Server Buffer'." |
188 |
|
:type '(repeat symbol) |
189 |
|
:group 'gnus-agent) |
190 |
|
|
191 |
|
(defcustom gnus-agent-queue-mail t |
192 |
|
"Whether and when outgoing mail should be queued by the agent. |
193 |
|
When `always', always queue outgoing mail. When nil, never |
194 |
|
queue. Otherwise, queue if and only if unplugged." |
195 |
|
:group 'gnus-agent |
196 |
|
:type '(radio (const :format "Always" always) |
197 |
|
(const :format "Never" nil) |
198 |
|
(const :format "When plugged" t))) |
199 |
|
|
200 |
|
(defcustom gnus-agent-prompt-send-queue nil |
201 |
|
"If non-nil, `gnus-group-send-queue' will prompt if called when |
202 |
|
unplugged." |
203 |
|
:group 'gnus-agent |
204 |
|
:type 'boolean) |
205 |
|
|
206 |
;;; Internal variables |
;;; Internal variables |
207 |
|
|
208 |
(defvar gnus-agent-history-buffers nil) |
(defvar gnus-agent-history-buffers nil) |
209 |
(defvar gnus-agent-buffer-alist nil) |
(defvar gnus-agent-buffer-alist nil) |
210 |
(defvar gnus-agent-article-alist nil) |
(defvar gnus-agent-article-alist nil |
211 |
|
"An assoc list identifying the articles whose headers have been fetched. |
212 |
|
If successfully fetched, these headers will be stored in the group's overview |
213 |
|
file. The key of each assoc pair is the article ID, the value of each assoc |
214 |
|
pair is a flag indicating whether the identified article has been downloaded |
215 |
|
\(gnus-agent-fetch-articles sets the value to the day of the download). |
216 |
|
NOTES: |
217 |
|
1) The last element of this list can not be expired as some |
218 |
|
routines (for example, get-agent-fetch-headers) use the last |
219 |
|
value to track which articles have had their headers retrieved. |
220 |
|
2) The function `gnus-agent-regenerate' may destructively modify the value.") |
221 |
(defvar gnus-agent-group-alist nil) |
(defvar gnus-agent-group-alist nil) |
|
(defvar gnus-agent-covered-methods nil) |
|
222 |
(defvar gnus-category-alist nil) |
(defvar gnus-category-alist nil) |
223 |
(defvar gnus-agent-current-history nil) |
(defvar gnus-agent-current-history nil) |
224 |
(defvar gnus-agent-overview-buffer nil) |
(defvar gnus-agent-overview-buffer nil) |
228 |
(defvar gnus-agent-file-name nil) |
(defvar gnus-agent-file-name nil) |
229 |
(defvar gnus-agent-send-mail-function nil) |
(defvar gnus-agent-send-mail-function nil) |
230 |
(defvar gnus-agent-file-coding-system 'raw-text) |
(defvar gnus-agent-file-coding-system 'raw-text) |
231 |
|
(defvar gnus-agent-file-loading-cache nil) |
232 |
|
|
233 |
;; Dynamic variables |
;; Dynamic variables |
234 |
(defvar gnus-headers) |
(defvar gnus-headers) |
259 |
(gnus-add-shutdown 'gnus-close-agent 'gnus) |
(gnus-add-shutdown 'gnus-close-agent 'gnus) |
260 |
|
|
261 |
(defun gnus-close-agent () |
(defun gnus-close-agent () |
262 |
(setq gnus-agent-covered-methods nil |
(setq gnus-category-predicate-cache nil |
|
gnus-category-predicate-cache nil |
|
263 |
gnus-category-group-cache nil |
gnus-category-group-cache nil |
264 |
gnus-agent-spam-hashtb nil) |
gnus-agent-spam-hashtb nil) |
265 |
(gnus-kill-buffer gnus-agent-overview-buffer)) |
(gnus-kill-buffer gnus-agent-overview-buffer)) |
293 |
(file-name-as-directory |
(file-name-as-directory |
294 |
(expand-file-name "agent.lib" (gnus-agent-directory))))) |
(expand-file-name "agent.lib" (gnus-agent-directory))))) |
295 |
|
|
296 |
|
(defun gnus-agent-cat-set-property (category property value) |
297 |
|
(if value |
298 |
|
(setcdr (or (assq property category) |
299 |
|
(let ((cell (cons property nil))) |
300 |
|
(setcdr category (cons cell (cdr category))) |
301 |
|
cell)) value) |
302 |
|
(let ((category category)) |
303 |
|
(while (cond ((eq property (caadr category)) |
304 |
|
(setcdr category (cddr category)) |
305 |
|
nil) |
306 |
|
(t |
307 |
|
(setq category (cdr category))))))) |
308 |
|
category) |
309 |
|
|
310 |
|
(eval-when-compile |
311 |
|
(defmacro gnus-agent-cat-defaccessor (name prop-name) |
312 |
|
"Define accessor and setter methods for manipulating a list of the form |
313 |
|
\(NAME (PROPERTY1 VALUE1) ... (PROPERTY_N VALUE_N)). |
314 |
|
Given the call (gnus-agent-cat-defaccessor func PROPERTY1), the list may be |
315 |
|
manipulated as follows: |
316 |
|
(func LIST): Returns VALUE1 |
317 |
|
(setf (func LIST) NEW_VALUE1): Replaces VALUE1 with NEW_VALUE1." |
318 |
|
`(progn (defmacro ,name (category) |
319 |
|
(list (quote cdr) (list (quote assq) |
320 |
|
(quote (quote ,prop-name)) category))) |
321 |
|
|
322 |
|
(define-setf-method ,name (category) |
323 |
|
(let* ((--category--temp-- (make-symbol "--category--")) |
324 |
|
(--value--temp-- (make-symbol "--value--"))) |
325 |
|
(list (list --category--temp--) ; temporary-variables |
326 |
|
(list category) ; value-forms |
327 |
|
(list --value--temp--) ; store-variables |
328 |
|
(let* ((category --category--temp--) ; store-form |
329 |
|
(value --value--temp--)) |
330 |
|
(list (quote gnus-agent-cat-set-property) |
331 |
|
category |
332 |
|
(quote (quote ,prop-name)) |
333 |
|
value)) |
334 |
|
(list (quote ,name) --category--temp--) ; access-form |
335 |
|
))))) |
336 |
|
) |
337 |
|
|
338 |
|
(defmacro gnus-agent-cat-name (category) |
339 |
|
`(car ,category)) |
340 |
|
|
341 |
|
(gnus-agent-cat-defaccessor |
342 |
|
gnus-agent-cat-days-until-old agent-days-until-old) |
343 |
|
(gnus-agent-cat-defaccessor |
344 |
|
gnus-agent-cat-enable-expiration agent-enable-expiration) |
345 |
|
(gnus-agent-cat-defaccessor |
346 |
|
gnus-agent-cat-groups agent-groups) |
347 |
|
(gnus-agent-cat-defaccessor |
348 |
|
gnus-agent-cat-high-score agent-high-score) |
349 |
|
(gnus-agent-cat-defaccessor |
350 |
|
gnus-agent-cat-length-when-long agent-length-when-long) |
351 |
|
(gnus-agent-cat-defaccessor |
352 |
|
gnus-agent-cat-length-when-short agent-length-when-short) |
353 |
|
(gnus-agent-cat-defaccessor |
354 |
|
gnus-agent-cat-low-score agent-low-score) |
355 |
|
(gnus-agent-cat-defaccessor |
356 |
|
gnus-agent-cat-predicate agent-predicate) |
357 |
|
(gnus-agent-cat-defaccessor |
358 |
|
gnus-agent-cat-score-file agent-score-file) |
359 |
|
(gnus-agent-cat-defaccessor |
360 |
|
gnus-agent-cat-enable-undownloaded-faces agent-enable-undownloaded-faces) |
361 |
|
|
362 |
|
(eval-and-compile |
363 |
|
(defsetf gnus-agent-cat-groups (category) (groups) |
364 |
|
(list 'gnus-agent-set-cat-groups category groups))) |
365 |
|
|
366 |
|
(defun gnus-agent-set-cat-groups (category groups) |
367 |
|
(unless (eq groups 'ignore) |
368 |
|
(let ((new-g groups) |
369 |
|
(old-g (gnus-agent-cat-groups category))) |
370 |
|
(cond ((eq new-g old-g) |
371 |
|
;; gnus-agent-add-group is fiddling with the group |
372 |
|
;; list. Still, Im done. |
373 |
|
nil |
374 |
|
) |
375 |
|
((eq new-g (cdr old-g)) |
376 |
|
;; gnus-agent-add-group is fiddling with the group list |
377 |
|
(setcdr (or (assq 'agent-groups category) |
378 |
|
(let ((cell (cons 'agent-groups nil))) |
379 |
|
(setcdr category (cons cell (cdr category))) |
380 |
|
cell)) new-g)) |
381 |
|
(t |
382 |
|
(let ((groups groups)) |
383 |
|
(while groups |
384 |
|
(let* ((group (pop groups)) |
385 |
|
(old-category (gnus-group-category group))) |
386 |
|
(if (eq category old-category) |
387 |
|
nil |
388 |
|
(setf (gnus-agent-cat-groups old-category) |
389 |
|
(delete group (gnus-agent-cat-groups |
390 |
|
old-category)))))) |
391 |
|
;; Purge cache as preceeding loop invalidated it. |
392 |
|
(setq gnus-category-group-cache nil)) |
393 |
|
|
394 |
|
(setcdr (or (assq 'agent-groups category) |
395 |
|
(let ((cell (cons 'agent-groups nil))) |
396 |
|
(setcdr category (cons cell (cdr category))) |
397 |
|
cell)) groups)))))) |
398 |
|
|
399 |
|
(defsubst gnus-agent-cat-make (name &optional default-agent-predicate) |
400 |
|
(list name `(agent-predicate . ,(or default-agent-predicate 'false)))) |
401 |
|
|
402 |
;;; Fetching setup functions. |
;;; Fetching setup functions. |
403 |
|
|
404 |
(defun gnus-agent-start-fetch () |
(defun gnus-agent-start-fetch () |
405 |
"Initialize data structures for efficient fetching." |
"Initialize data structures for efficient fetching." |
|
(gnus-agent-open-history) |
|
|
(setq gnus-agent-current-history (gnus-agent-history-buffer)) |
|
406 |
(gnus-agent-create-buffer)) |
(gnus-agent-create-buffer)) |
407 |
|
|
408 |
(defun gnus-agent-stop-fetch () |
(defun gnus-agent-stop-fetch () |
409 |
"Save all data structures and clean up." |
"Save all data structures and clean up." |
|
(gnus-agent-save-history) |
|
|
(gnus-agent-close-history) |
|
410 |
(setq gnus-agent-spam-hashtb nil) |
(setq gnus-agent-spam-hashtb nil) |
411 |
(save-excursion |
(save-excursion |
412 |
(set-buffer nntp-server-buffer) |
(set-buffer nntp-server-buffer) |
423 |
(put 'gnus-agent-with-fetch 'lisp-indent-function 0) |
(put 'gnus-agent-with-fetch 'lisp-indent-function 0) |
424 |
(put 'gnus-agent-with-fetch 'edebug-form-spec '(body)) |
(put 'gnus-agent-with-fetch 'edebug-form-spec '(body)) |
425 |
|
|
426 |
|
(defmacro gnus-agent-append-to-list (tail value) |
427 |
|
`(setq ,tail (setcdr ,tail (cons ,value nil)))) |
428 |
|
|
429 |
|
(defmacro gnus-agent-message (level &rest args) |
430 |
|
`(if (<= ,level gnus-verbose) |
431 |
|
(message ,@args))) |
432 |
|
|
433 |
;;; |
;;; |
434 |
;;; Mode infestation |
;;; Mode infestation |
435 |
;;; |
;;; |
459 |
buffer)))) |
buffer)))) |
460 |
minor-mode-map-alist)) |
minor-mode-map-alist)) |
461 |
(when (eq major-mode 'gnus-group-mode) |
(when (eq major-mode 'gnus-group-mode) |
462 |
(gnus-agent-toggle-plugged gnus-plugged)) |
(let ((init-plugged gnus-plugged) |
463 |
|
(gnus-agent-go-online nil)) |
464 |
|
;; g-a-t-p does nothing when gnus-plugged isn't changed. |
465 |
|
;; Therefore, make certain that the current value does not |
466 |
|
;; match the desired initial value. |
467 |
|
(setq gnus-plugged :unknown) |
468 |
|
(gnus-agent-toggle-plugged init-plugged))) |
469 |
(gnus-run-hooks 'gnus-agent-mode-hook |
(gnus-run-hooks 'gnus-agent-mode-hook |
470 |
(intern (format "gnus-agent-%s-mode-hook" buffer))))) |
(intern (format "gnus-agent-%s-mode-hook" buffer))))) |
471 |
|
|
476 |
"Jj" gnus-agent-toggle-plugged |
"Jj" gnus-agent-toggle-plugged |
477 |
"Js" gnus-agent-fetch-session |
"Js" gnus-agent-fetch-session |
478 |
"JY" gnus-agent-synchronize-flags |
"JY" gnus-agent-synchronize-flags |
479 |
"JS" gnus-group-send-drafts |
"JS" gnus-group-send-queue |
480 |
"Ja" gnus-agent-add-group |
"Ja" gnus-agent-add-group |
481 |
"Jr" gnus-agent-remove-group) |
"Jr" gnus-agent-remove-group |
482 |
|
"Jo" gnus-agent-toggle-group-plugged) |
483 |
|
|
484 |
(defun gnus-agent-group-make-menu-bar () |
(defun gnus-agent-group-make-menu-bar () |
485 |
(unless (boundp 'gnus-agent-group-menu) |
(unless (boundp 'gnus-agent-group-menu) |
487 |
gnus-agent-group-menu gnus-agent-group-mode-map "" |
gnus-agent-group-menu gnus-agent-group-mode-map "" |
488 |
'("Agent" |
'("Agent" |
489 |
["Toggle plugged" gnus-agent-toggle-plugged t] |
["Toggle plugged" gnus-agent-toggle-plugged t] |
490 |
|
["Toggle group plugged" gnus-agent-toggle-group-plugged t] |
491 |
["List categories" gnus-enter-category-buffer t] |
["List categories" gnus-enter-category-buffer t] |
492 |
["Send drafts" gnus-group-send-drafts gnus-plugged] |
["Add (current) group to category" gnus-agent-add-group t] |
493 |
|
["Remove (current) group from category" gnus-agent-remove-group t] |
494 |
|
["Send queue" gnus-group-send-queue gnus-plugged] |
495 |
("Fetch" |
("Fetch" |
496 |
["All" gnus-agent-fetch-session gnus-plugged] |
["All" gnus-agent-fetch-session gnus-plugged] |
497 |
["Group" gnus-agent-fetch-group gnus-plugged]))))) |
["Group" gnus-agent-fetch-group gnus-plugged]) |
498 |
|
["Synchronize flags" gnus-agent-synchronize-flags t] |
499 |
|
)))) |
500 |
|
|
501 |
(defvar gnus-agent-summary-mode-map (make-sparse-keymap)) |
(defvar gnus-agent-summary-mode-map (make-sparse-keymap)) |
502 |
(gnus-define-keys gnus-agent-summary-mode-map |
(gnus-define-keys gnus-agent-summary-mode-map |
503 |
"Jj" gnus-agent-toggle-plugged |
"Jj" gnus-agent-toggle-plugged |
504 |
|
"Ju" gnus-agent-summary-fetch-group |
505 |
|
"JS" gnus-agent-fetch-group |
506 |
|
"Js" gnus-agent-summary-fetch-series |
507 |
"J#" gnus-agent-mark-article |
"J#" gnus-agent-mark-article |
508 |
"J\M-#" gnus-agent-unmark-article |
"J\M-#" gnus-agent-unmark-article |
509 |
"@" gnus-agent-toggle-mark |
"@" gnus-agent-toggle-mark |
518 |
["Mark as downloadable" gnus-agent-mark-article t] |
["Mark as downloadable" gnus-agent-mark-article t] |
519 |
["Unmark as downloadable" gnus-agent-unmark-article t] |
["Unmark as downloadable" gnus-agent-unmark-article t] |
520 |
["Toggle mark" gnus-agent-toggle-mark t] |
["Toggle mark" gnus-agent-toggle-mark t] |
521 |
|
["Fetch downloadable" gnus-agent-summary-fetch-group t] |
522 |
["Catchup undownloaded" gnus-agent-catchup t])))) |
["Catchup undownloaded" gnus-agent-catchup t])))) |
523 |
|
|
524 |
(defvar gnus-agent-server-mode-map (make-sparse-keymap)) |
(defvar gnus-agent-server-mode-map (make-sparse-keymap)) |
536 |
["Add" gnus-agent-add-server t] |
["Add" gnus-agent-add-server t] |
537 |
["Remove" gnus-agent-remove-server t])))) |
["Remove" gnus-agent-remove-server t])))) |
538 |
|
|
539 |
(defun gnus-agent-toggle-plugged (plugged) |
(defun gnus-agent-make-mode-line-string (string mouse-button mouse-func) |
540 |
|
(if (and (fboundp 'propertize) |
541 |
|
(fboundp 'make-mode-line-mouse-map)) |
542 |
|
(propertize string 'local-map |
543 |
|
(make-mode-line-mouse-map mouse-button mouse-func)) |
544 |
|
string)) |
545 |
|
|
546 |
|
(defun gnus-agent-toggle-plugged (set-to) |
547 |
"Toggle whether Gnus is unplugged or not." |
"Toggle whether Gnus is unplugged or not." |
548 |
(interactive (list (not gnus-plugged))) |
(interactive (list (not gnus-plugged))) |
549 |
(if plugged |
(cond ((eq set-to gnus-plugged) |
550 |
(progn |
nil) |
551 |
(setq gnus-plugged plugged) |
(set-to |
552 |
(gnus-agent-possibly-synchronize-flags) |
(setq gnus-plugged set-to) |
553 |
(gnus-run-hooks 'gnus-agent-plugged-hook) |
(gnus-run-hooks 'gnus-agent-plugged-hook) |
554 |
(setcar (cdr gnus-agent-mode-status) " Plugged")) |
(setcar (cdr gnus-agent-mode-status) |
555 |
(gnus-agent-close-connections) |
(gnus-agent-make-mode-line-string " Plugged" |
556 |
(setq gnus-plugged plugged) |
'mouse-2 |
557 |
(gnus-run-hooks 'gnus-agent-unplugged-hook) |
'gnus-agent-toggle-plugged)) |
558 |
(setcar (cdr gnus-agent-mode-status) " Unplugged")) |
(gnus-agent-go-online gnus-agent-go-online) |
559 |
|
(gnus-agent-possibly-synchronize-flags)) |
560 |
|
(t |
561 |
|
(gnus-agent-close-connections) |
562 |
|
(setq gnus-plugged set-to) |
563 |
|
(gnus-run-hooks 'gnus-agent-unplugged-hook) |
564 |
|
(setcar (cdr gnus-agent-mode-status) |
565 |
|
(gnus-agent-make-mode-line-string " Unplugged" |
566 |
|
'mouse-2 |
567 |
|
'gnus-agent-toggle-plugged)))) |
568 |
(set-buffer-modified-p t)) |
(set-buffer-modified-p t)) |
569 |
|
|
570 |
|
(defmacro gnus-agent-while-plugged (&rest body) |
571 |
|
`(let ((original-gnus-plugged gnus-plugged)) |
572 |
|
(unwind-protect |
573 |
|
(progn (gnus-agent-toggle-plugged t) |
574 |
|
,@body) |
575 |
|
(gnus-agent-toggle-plugged original-gnus-plugged)))) |
576 |
|
|
577 |
|
(put 'gnus-agent-while-plugged 'lisp-indent-function 0) |
578 |
|
(put 'gnus-agent-while-plugged 'edebug-form-spec '(body)) |
579 |
|
|
580 |
(defun gnus-agent-close-connections () |
(defun gnus-agent-close-connections () |
581 |
"Close all methods covered by the Gnus agent." |
"Close all methods covered by the Gnus agent." |
582 |
(let ((methods gnus-agent-covered-methods)) |
(let ((methods (gnus-agent-covered-methods))) |
583 |
(while methods |
(while methods |
584 |
(gnus-close-server (pop methods))))) |
(gnus-close-server (pop methods))))) |
585 |
|
|
598 |
(gnus)) |
(gnus)) |
599 |
|
|
600 |
;;;###autoload |
;;;###autoload |
601 |
|
(defun gnus-slave-unplugged (&optional arg) |
602 |
|
"Read news as a slave unplugged." |
603 |
|
(interactive "P") |
604 |
|
(setq gnus-plugged nil) |
605 |
|
(gnus arg nil 'slave)) |
606 |
|
|
607 |
|
;;;###autoload |
608 |
(defun gnus-agentize () |
(defun gnus-agentize () |
609 |
"Allow Gnus to be an offline newsreader. |
"Allow Gnus to be an offline newsreader. |
|
The normal usage of this command is to put the following as the |
|
|
last form in your `.gnus.el' file: |
|
|
|
|
|
\(gnus-agentize) |
|
610 |
|
|
611 |
This will modify the `gnus-before-startup-hook', `gnus-post-method', |
The gnus-agentize function is now called internally by gnus when |
612 |
and `message-send-mail-function' variables, and install the Gnus |
gnus-agent is set. If you wish to avoid calling gnus-agentize, |
613 |
agent minor mode in all Gnus buffers." |
customize gnus-agent to nil. |
614 |
|
|
615 |
|
This will modify the `gnus-setup-news-hook', and |
616 |
|
`message-send-mail-real-function' variables, and install the Gnus agent |
617 |
|
minor mode in all Gnus buffers." |
618 |
(interactive) |
(interactive) |
619 |
(gnus-open-agent) |
(gnus-open-agent) |
620 |
(add-hook 'gnus-setup-news-hook 'gnus-agent-queue-setup) |
(add-hook 'gnus-setup-news-hook 'gnus-agent-queue-setup) |
621 |
(unless gnus-agent-send-mail-function |
(unless gnus-agent-send-mail-function |
622 |
(setq gnus-agent-send-mail-function message-send-mail-function |
(setq gnus-agent-send-mail-function |
623 |
message-send-mail-function 'gnus-agent-send-mail)) |
(or message-send-mail-real-function |
624 |
(unless gnus-agent-covered-methods |
message-send-mail-function) |
625 |
(setq gnus-agent-covered-methods (list gnus-select-method)))) |
message-send-mail-real-function 'gnus-agent-send-mail)) |
626 |
|
|
627 |
(defun gnus-agent-queue-setup () |
;; If the servers file doesn't exist, auto-agentize some servers and |
628 |
"Make sure the queue group exists." |
;; save the servers file so this auto-agentizing isn't invoked |
629 |
(unless (gnus-gethash "nndraft:queue" gnus-newsrc-hashtb) |
;; again. |
630 |
(gnus-request-create-group "queue" '(nndraft "")) |
(unless (file-exists-p (nnheader-concat gnus-agent-directory "lib/servers")) |
631 |
|
(gnus-message 3 "First time agent user, agentizing remote groups...") |
632 |
|
(mapc |
633 |
|
(lambda (server-or-method) |
634 |
|
(let ((method (gnus-server-to-method server-or-method))) |
635 |
|
(when (memq (car method) |
636 |
|
gnus-agent-auto-agentize-methods) |
637 |
|
(push (gnus-method-to-server method) |
638 |
|
gnus-agent-covered-methods) |
639 |
|
(setq gnus-agent-method-p-cache nil)))) |
640 |
|
(cons gnus-select-method gnus-secondary-select-methods)) |
641 |
|
(gnus-agent-write-servers))) |
642 |
|
|
643 |
|
(defun gnus-agent-queue-setup (&optional group-name) |
644 |
|
"Make sure the queue group exists. |
645 |
|
Optional arg GROUP-NAME allows to specify another group." |
646 |
|
(unless (gnus-gethash (format "nndraft:%s" (or group-name "queue")) |
647 |
|
gnus-newsrc-hashtb) |
648 |
|
(gnus-request-create-group (or group-name "queue") '(nndraft "")) |
649 |
(let ((gnus-level-default-subscribed 1)) |
(let ((gnus-level-default-subscribed 1)) |
650 |
(gnus-subscribe-group "nndraft:queue" nil '(nndraft ""))) |
(gnus-subscribe-group (format "nndraft:%s" (or group-name "queue")) |
651 |
|
nil '(nndraft ""))) |
652 |
(gnus-group-set-parameter |
(gnus-group-set-parameter |
653 |
"nndraft:queue" 'gnus-dummy '((gnus-draft-mode))))) |
(format "nndraft:%s" (or group-name "queue")) |
654 |
|
'gnus-dummy '((gnus-draft-mode))))) |
655 |
|
|
656 |
(defun gnus-agent-send-mail () |
(defun gnus-agent-send-mail () |
657 |
(if gnus-plugged |
(if (or (not gnus-agent-queue-mail) |
658 |
|
(and gnus-plugged (not (eq gnus-agent-queue-mail 'always)))) |
659 |
(funcall gnus-agent-send-mail-function) |
(funcall gnus-agent-send-mail-function) |
660 |
(goto-char (point-min)) |
(goto-char (point-min)) |
661 |
(re-search-forward |
(re-search-forward |
666 |
|
|
667 |
(defun gnus-agent-insert-meta-information (type &optional method) |
(defun gnus-agent-insert-meta-information (type &optional method) |
668 |
"Insert meta-information into the message that says how it's to be posted. |
"Insert meta-information into the message that says how it's to be posted. |
669 |
TYPE can be either `mail' or `news'. If the latter METHOD can |
TYPE can be either `mail' or `news'. If the latter, then METHOD can |
670 |
be a select method." |
be a select method." |
671 |
(save-excursion |
(save-excursion |
672 |
(message-remove-header gnus-agent-meta-information-header) |
(message-remove-header gnus-agent-meta-information-header) |
682 |
"Restore GCC field from saved header." |
"Restore GCC field from saved header." |
683 |
(save-excursion |
(save-excursion |
684 |
(goto-char (point-min)) |
(goto-char (point-min)) |
685 |
(while (re-search-forward (concat gnus-agent-gcc-header ":") nil t) |
(while (re-search-forward |
686 |
|
(concat "^" (regexp-quote gnus-agent-gcc-header) ":") nil t) |
687 |
(replace-match "Gcc:" 'fixedcase)))) |
(replace-match "Gcc:" 'fixedcase)))) |
688 |
|
|
689 |
(defun gnus-agent-any-covered-gcc () |
(defun gnus-agent-any-covered-gcc () |
697 |
gcc " ,"))))) |
gcc " ,"))))) |
698 |
covered) |
covered) |
699 |
(while (and (not covered) methods) |
(while (and (not covered) methods) |
700 |
(setq covered |
(setq covered (gnus-agent-method-p (car methods)) |
|
(member (car methods) gnus-agent-covered-methods) |
|
701 |
methods (cdr methods))) |
methods (cdr methods))) |
702 |
covered))) |
covered))) |
703 |
|
|
704 |
|
;;;###autoload |
705 |
(defun gnus-agent-possibly-save-gcc () |
(defun gnus-agent-possibly-save-gcc () |
706 |
"Save GCC if Gnus is unplugged." |
"Save GCC if Gnus is unplugged." |
707 |
(when (and (not gnus-plugged) (gnus-agent-any-covered-gcc)) |
(when (and (not gnus-plugged) (gnus-agent-any-covered-gcc)) |
727 |
(error "Groups can't be fetched when Gnus is unplugged")) |
(error "Groups can't be fetched when Gnus is unplugged")) |
728 |
(gnus-group-iterate n 'gnus-agent-fetch-group)) |
(gnus-group-iterate n 'gnus-agent-fetch-group)) |
729 |
|
|
730 |
(defun gnus-agent-fetch-group (group) |
(defun gnus-agent-fetch-group (&optional group) |
731 |
"Put all new articles in GROUP into the Agent." |
"Put all new articles in GROUP into the Agent." |
732 |
(interactive (list (gnus-group-group-name))) |
(interactive (list (gnus-group-group-name))) |
733 |
(unless gnus-plugged |
(setq group (or group gnus-newsgroup-name)) |
|
(error "Groups can't be fetched when Gnus is unplugged")) |
|
734 |
(unless group |
(unless group |
735 |
(error "No group on the current line")) |
(error "No group on the current line")) |
736 |
(let ((gnus-command-method (gnus-find-method-for-group group))) |
|
737 |
(gnus-agent-with-fetch |
(gnus-agent-while-plugged |
738 |
(gnus-agent-fetch-group-1 group gnus-command-method) |
(let ((gnus-command-method (gnus-find-method-for-group group))) |
739 |
(gnus-message 5 "Fetching %s...done" group)))) |
(gnus-agent-with-fetch |
740 |
|
(gnus-agent-fetch-group-1 group gnus-command-method) |
741 |
|
(gnus-message 5 "Fetching %s...done" group))))) |
742 |
|
|
743 |
(defun gnus-agent-add-group (category arg) |
(defun gnus-agent-add-group (category arg) |
744 |
"Add the current group to an agent category." |
"Add the current group to an agent category." |
755 |
c groups) |
c groups) |
756 |
(gnus-group-iterate arg |
(gnus-group-iterate arg |
757 |
(lambda (group) |
(lambda (group) |
758 |
(when (cadddr (setq c (gnus-group-category group))) |
(when (gnus-agent-cat-groups (setq c (gnus-group-category group))) |
759 |
(setf (cadddr c) (delete group (cadddr c)))) |
(setf (gnus-agent-cat-groups c) |
760 |
|
(delete group (gnus-agent-cat-groups c)))) |
761 |
(push group groups))) |
(push group groups))) |
762 |
(setf (cadddr cat) (nconc (cadddr cat) groups)) |
(setf (gnus-agent-cat-groups cat) |
763 |
|
(nconc (gnus-agent-cat-groups cat) groups)) |
764 |
(gnus-category-write))) |
(gnus-category-write))) |
765 |
|
|
766 |
(defun gnus-agent-remove-group (arg) |
(defun gnus-agent-remove-group (arg) |
769 |
(let (c) |
(let (c) |
770 |
(gnus-group-iterate arg |
(gnus-group-iterate arg |
771 |
(lambda (group) |
(lambda (group) |
772 |
(when (cadddr (setq c (gnus-group-category group))) |
(when (gnus-agent-cat-groups (setq c (gnus-group-category group))) |
773 |
(setf (cadddr c) (delete group (cadddr c)))))) |
(setf (gnus-agent-cat-groups c) |
774 |
|
(delete group (gnus-agent-cat-groups c)))))) |
775 |
(gnus-category-write))) |
(gnus-category-write))) |
776 |
|
|
777 |
(defun gnus-agent-synchronize-flags () |
(defun gnus-agent-synchronize-flags () |
778 |
"Synchronize unplugged flags with servers." |
"Synchronize unplugged flags with servers." |
779 |
(interactive) |
(interactive) |
780 |
(save-excursion |
(save-excursion |
781 |
(dolist (gnus-command-method gnus-agent-covered-methods) |
(dolist (gnus-command-method (gnus-agent-covered-methods)) |
782 |
(when (file-exists-p (gnus-agent-lib-file "flags")) |
(when (file-exists-p (gnus-agent-lib-file "flags")) |
783 |
(gnus-agent-synchronize-flags-server gnus-command-method))))) |
(gnus-agent-synchronize-flags-server gnus-command-method))))) |
784 |
|
|
786 |
"Synchronize flags according to `gnus-agent-synchronize-flags'." |
"Synchronize flags according to `gnus-agent-synchronize-flags'." |
787 |
(interactive) |
(interactive) |
788 |
(save-excursion |
(save-excursion |
789 |
(dolist (gnus-command-method gnus-agent-covered-methods) |
(dolist (gnus-command-method (gnus-agent-covered-methods)) |
790 |
(when (file-exists-p (gnus-agent-lib-file "flags")) |
(when (file-exists-p (gnus-agent-lib-file "flags")) |
791 |
(gnus-agent-possibly-synchronize-flags-server gnus-command-method))))) |
(gnus-agent-possibly-synchronize-flags-server gnus-command-method))))) |
792 |
|
|
798 |
(erase-buffer) |
(erase-buffer) |
799 |
(nnheader-insert-file-contents (gnus-agent-lib-file "flags")) |
(nnheader-insert-file-contents (gnus-agent-lib-file "flags")) |
800 |
(if (null (gnus-check-server gnus-command-method)) |
(if (null (gnus-check-server gnus-command-method)) |
801 |
(message "Couldn't open server %s" (nth 1 gnus-command-method)) |
(gnus-message 1 "Couldn't open server %s" (nth 1 gnus-command-method)) |
802 |
(while (not (eobp)) |
(while (not (eobp)) |
803 |
(if (null (eval (read (current-buffer)))) |
(if (null (eval (read (current-buffer)))) |
804 |
(progn (forward-line) |
(gnus-delete-line) |
|
(kill-line -1)) |
|
805 |
(write-file (gnus-agent-lib-file "flags")) |
(write-file (gnus-agent-lib-file "flags")) |
806 |
(error "Couldn't set flags from file %s" |
(error "Couldn't set flags from file %s" |
807 |
(gnus-agent-lib-file "flags")))) |
(gnus-agent-lib-file "flags")))) |
821 |
;;; Server mode commands |
;;; Server mode commands |
822 |
;;; |
;;; |
823 |
|
|
824 |
(defun gnus-agent-add-server (server) |
(defun gnus-agent-add-server () |
825 |
"Enroll SERVER in the agent program." |
"Enroll SERVER in the agent program." |
826 |
(interactive (list (gnus-server-server-name))) |
(interactive) |
827 |
(unless server |
(let* ((server (gnus-server-server-name)) |
828 |
(error "No server on the current line")) |
(named-server (gnus-server-named-server)) |
829 |
(let ((method (gnus-server-get-method nil (gnus-server-server-name)))) |
(method (and server |
830 |
(when (member method gnus-agent-covered-methods) |
(gnus-server-get-method nil server)))) |
831 |
|
(unless server |
832 |
|
(error "No server on the current line")) |
833 |
|
|
834 |
|
(when (gnus-agent-method-p method) |
835 |
(error "Server already in the agent program")) |
(error "Server already in the agent program")) |
836 |
(push method gnus-agent-covered-methods) |
|
837 |
|
(push named-server gnus-agent-covered-methods) |
838 |
|
|
839 |
|
(setq gnus-agent-method-p-cache nil) |
840 |
|
(gnus-server-update-server server) |
841 |
(gnus-agent-write-servers) |
(gnus-agent-write-servers) |
842 |
(message "Entered %s into the Agent" server))) |
(gnus-message 1 "Entered %s into the Agent" server))) |
843 |
|
|
844 |
(defun gnus-agent-remove-server (server) |
(defun gnus-agent-remove-server () |
845 |
"Remove SERVER from the agent program." |
"Remove SERVER from the agent program." |
846 |
(interactive (list (gnus-server-server-name))) |
(interactive) |
847 |
(unless server |
(let* ((server (gnus-server-server-name)) |
848 |
(error "No server on the current line")) |
(named-server (gnus-server-named-server))) |
849 |
(let ((method (gnus-server-get-method nil (gnus-server-server-name)))) |
(unless server |
850 |
(unless (member method gnus-agent-covered-methods) |
(error "No server on the current line")) |
851 |
|
|
852 |
|
(unless (member named-server gnus-agent-covered-methods) |
853 |
(error "Server not in the agent program")) |
(error "Server not in the agent program")) |
854 |
(setq gnus-agent-covered-methods |
|
855 |
(delete method gnus-agent-covered-methods)) |
(setq gnus-agent-covered-methods |
856 |
|
(delete named-server gnus-agent-covered-methods) |
857 |
|
gnus-agent-method-p-cache nil) |
858 |
|
|
859 |
|
(gnus-server-update-server server) |
860 |
(gnus-agent-write-servers) |
(gnus-agent-write-servers) |
861 |
(message "Removed %s from the agent" server))) |
(gnus-message 1 "Removed %s from the agent" server))) |
862 |
|
|
863 |
(defun gnus-agent-read-servers () |
(defun gnus-agent-read-servers () |
864 |
"Read the alist of covered servers." |
"Read the alist of covered servers." |
865 |
|
(setq gnus-agent-covered-methods |
866 |
|
(gnus-agent-read-file |
867 |
|
(nnheader-concat gnus-agent-directory "lib/servers")) |
868 |
|
gnus-agent-method-p-cache nil) |
869 |
|
|
870 |
|
;; I am called so early in start-up that I can not validate server |
871 |
|
;; names. When that is the case, I skip the validation. That is |
872 |
|
;; alright as the gnus startup code calls the validate methods |
873 |
|
;; directly. |
874 |
|
(if gnus-server-alist |
875 |
|
(gnus-agent-read-servers-validate))) |
876 |
|
|
877 |
|
(defun gnus-agent-read-servers-validate () |
878 |
|
(mapcar (lambda (server-or-method) |
879 |
|
(let* ((server (if (stringp server-or-method) |
880 |
|
server-or-method |
881 |
|
(gnus-method-to-server server-or-method))) |
882 |
|
(method (gnus-server-to-method server))) |
883 |
|
(if method |
884 |
|
(unless (member server gnus-agent-covered-methods) |
885 |
|
(push server gnus-agent-covered-methods) |
886 |
|
(setq gnus-agent-method-p-cache nil)) |
887 |
|
(gnus-message 1 "Ignoring disappeared server `%s'" server)))) |
888 |
|
(prog1 gnus-agent-covered-methods |
889 |
|
(setq gnus-agent-covered-methods nil)))) |
890 |
|
|
891 |
|
(defun gnus-agent-read-servers-validate-native (native-method) |
892 |
(setq gnus-agent-covered-methods |
(setq gnus-agent-covered-methods |
893 |
(gnus-agent-read-file |
(mapcar (lambda (method) |
894 |
(nnheader-concat gnus-agent-directory "lib/servers")))) |
(if (or (not method) |
895 |
|
(equal method native-method)) |
896 |
|
"native" |
897 |
|
method)) gnus-agent-covered-methods))) |
898 |
|
|
899 |
(defun gnus-agent-write-servers () |
(defun gnus-agent-write-servers () |
900 |
"Write the alist of covered servers." |
"Write the alist of covered servers." |
902 |
(let ((coding-system-for-write nnheader-file-coding-system) |
(let ((coding-system-for-write nnheader-file-coding-system) |
903 |
(file-name-coding-system nnmail-pathname-coding-system)) |
(file-name-coding-system nnmail-pathname-coding-system)) |
904 |
(with-temp-file (nnheader-concat gnus-agent-directory "lib/servers") |
(with-temp-file (nnheader-concat gnus-agent-directory "lib/servers") |
905 |
(prin1 gnus-agent-covered-methods (current-buffer))))) |
(prin1 gnus-agent-covered-methods |
906 |
|
(current-buffer))))) |
907 |
|
|
908 |
;;; |
;;; |
909 |
;;; Summary commands |
;;; Summary commands |
945 |
(gnus-agent-mark-article n 'toggle)) |
(gnus-agent-mark-article n 'toggle)) |
946 |
|
|
947 |
(defun gnus-summary-set-agent-mark (article &optional unmark) |
(defun gnus-summary-set-agent-mark (article &optional unmark) |
948 |
"Mark ARTICLE as downloadable." |
"Mark ARTICLE as downloadable. If UNMARK is nil, article is marked. |
949 |
(let ((unmark (if (and (not (null unmark)) (not (eq t unmark))) |
When UNMARK is t, the article is unmarked. For any other value, the |
950 |
(memq article gnus-newsgroup-downloadable) |
article's mark is toggled." |
951 |
unmark))) |
(let ((unmark (cond ((eq nil unmark) |
952 |
(if unmark |
nil) |
953 |
(progn |
((eq t unmark) |
954 |
(setq gnus-newsgroup-downloadable |
t) |
955 |
(delq article gnus-newsgroup-downloadable)) |
(t |
956 |
(push article gnus-newsgroup-undownloaded)) |
(memq article gnus-newsgroup-downloadable))))) |
957 |
(setq gnus-newsgroup-undownloaded |
(when (gnus-summary-goto-subject article nil t) |
958 |
(delq article gnus-newsgroup-undownloaded)) |
(gnus-summary-update-mark |
959 |
(push article gnus-newsgroup-downloadable)) |
(if unmark |
960 |
(gnus-summary-update-mark |
(progn |
961 |
(if unmark gnus-undownloaded-mark gnus-downloadable-mark) |
(setq gnus-newsgroup-downloadable |
962 |
'unread))) |
(delq article gnus-newsgroup-downloadable)) |
963 |
|
(gnus-article-mark article)) |
964 |
|
(setq gnus-newsgroup-downloadable |
965 |
|
(gnus-add-to-sorted-list gnus-newsgroup-downloadable article)) |
966 |
|
gnus-downloadable-mark) |
967 |
|
'unread)))) |
968 |
|
|
969 |
(defun gnus-agent-get-undownloaded-list () |
(defun gnus-agent-get-undownloaded-list () |
970 |
"Mark all unfetched articles as read." |
"Construct list of articles that have not been downloaded." |
971 |
(let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))) |
(let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))) |
972 |
(when (and (not gnus-plugged) |
(when (set (make-local-variable 'gnus-newsgroup-agentized) |
973 |
(gnus-agent-method-p gnus-command-method)) |
(gnus-agent-method-p gnus-command-method)) |
974 |
(gnus-agent-load-alist gnus-newsgroup-name) |
(let* ((alist (gnus-agent-load-alist gnus-newsgroup-name)) |
975 |
;; First mark all undownloaded articles as undownloaded. |
(headers (sort (mapcar (lambda (h) |
976 |
(let ((articles (append gnus-newsgroup-unreads |
(mail-header-number h)) |
977 |
gnus-newsgroup-marked |
gnus-newsgroup-headers) '<)) |
978 |
gnus-newsgroup-dormant)) |
(cached (and gnus-use-cache gnus-newsgroup-cached)) |
979 |
article) |
(undownloaded (list nil)) |
980 |
(while (setq article (pop articles)) |
(tail-undownloaded undownloaded) |
981 |
(unless (or (cdr (assq article gnus-agent-article-alist)) |
(unfetched (list nil)) |
982 |
(memq article gnus-newsgroup-downloadable) |
(tail-unfetched unfetched)) |
983 |
(memq article gnus-newsgroup-cached)) |
(while (and alist headers) |
984 |
(push article gnus-newsgroup-undownloaded)))) |
(let ((a (caar alist)) |
985 |
;; Then mark downloaded downloadable as not-downloadable, |
(h (car headers))) |
986 |
;; if you get my drift. |
(cond ((< a h) |
987 |
(let ((articles gnus-newsgroup-downloadable) |
;; Ignore IDs in the alist that are not being |
988 |
article) |
;; displayed in the summary. |
989 |
(while (setq article (pop articles)) |
(setq alist (cdr alist))) |
990 |
(when (cdr (assq article gnus-agent-article-alist)) |
((> a h) |
991 |
(setq gnus-newsgroup-downloadable |
;; Headers that are not in the alist should be |
992 |
(delq article gnus-newsgroup-downloadable)))))))) |
;; fictious (see nnagent-retrieve-headers); they |
993 |
|
;; imply that this article isn't in the agent. |
994 |
|
(gnus-agent-append-to-list tail-undownloaded h) |
995 |
|
(gnus-agent-append-to-list tail-unfetched h) |
996 |
|
(setq headers (cdr headers))) |
997 |
|
((cdar alist) |
998 |
|
(setq alist (cdr alist)) |
999 |
|
(setq headers (cdr headers)) |
1000 |
|
nil ; ignore already downloaded |
1001 |
|
) |
1002 |
|
(t |
1003 |
|
(setq alist (cdr alist)) |
1004 |
|
(setq headers (cdr headers)) |
1005 |
|
|
1006 |
|
;; This article isn't in the agent. Check to see |
1007 |
|
;; if it is in the cache. If it is, it's been |
1008 |
|
;; downloaded. |
1009 |
|
(while (and cached (< (car cached) a)) |
1010 |
|
(setq cached (cdr cached))) |
1011 |
|
(unless (equal a (car cached)) |
1012 |
|
(gnus-agent-append-to-list tail-undownloaded a)))))) |
1013 |
|
|
1014 |
|
(while headers |
1015 |
|
(let ((num (pop headers))) |
1016 |
|
(gnus-agent-append-to-list tail-undownloaded num) |
1017 |
|
(gnus-agent-append-to-list tail-unfetched num))) |
1018 |
|
|
1019 |
|
(setq gnus-newsgroup-undownloaded (cdr undownloaded) |
1020 |
|
gnus-newsgroup-unfetched (cdr unfetched)))))) |
1021 |
|
|
1022 |
(defun gnus-agent-catchup () |
(defun gnus-agent-catchup () |
1023 |
"Mark all undownloaded articles as read." |
"Mark as read all unhandled articles. |
1024 |
|
An article is unhandled if it is neither cached, nor downloaded, nor |
1025 |
|
downloadable." |
1026 |
(interactive) |
(interactive) |
1027 |
(save-excursion |
(save-excursion |
1028 |
(while gnus-newsgroup-undownloaded |
(let ((articles gnus-newsgroup-undownloaded)) |
1029 |
(gnus-summary-mark-article |
(when (or gnus-newsgroup-downloadable |
1030 |
(pop gnus-newsgroup-undownloaded) gnus-catchup-mark))) |
gnus-newsgroup-cached) |
1031 |
(gnus-summary-position-point)) |
(setq articles (gnus-sorted-ndifference |
1032 |
|
(gnus-sorted-ndifference |
1033 |
|
(gnus-copy-sequence articles) |
1034 |
|
gnus-newsgroup-downloadable) |
1035 |
|
gnus-newsgroup-cached))) |
1036 |
|
|
1037 |
|
(while articles |
1038 |
|
(gnus-summary-mark-article |
1039 |
|
(pop articles) gnus-catchup-mark))) |
1040 |
|
(gnus-summary-position-point))) |
1041 |
|
|
1042 |
|
(defun gnus-agent-summary-fetch-series () |
1043 |
|
(interactive) |
1044 |
|
(when gnus-newsgroup-processable |
1045 |
|
(setq gnus-newsgroup-downloadable |
1046 |
|
(let* ((dl gnus-newsgroup-downloadable) |
1047 |
|
(gnus-newsgroup-downloadable |
1048 |
|
(sort (gnus-copy-sequence gnus-newsgroup-processable) '<)) |
1049 |
|
(fetched-articles (gnus-agent-summary-fetch-group))) |
1050 |
|
;; The preceeding call to (gnus-agent-summary-fetch-group) |
1051 |
|
;; updated gnus-newsgroup-downloadable to remove each |
1052 |
|
;; article successfully fetched. |
1053 |
|
|
1054 |
|
;; For each article that I processed, remove its |
1055 |
|
;; processable mark IF the article is no longer |
1056 |
|
;; downloadable (i.e. it's already downloaded) |
1057 |
|
(dolist (article gnus-newsgroup-processable) |
1058 |
|
(unless (memq article gnus-newsgroup-downloadable) |
1059 |
|
(gnus-summary-remove-process-mark article))) |
1060 |
|
(gnus-sorted-ndifference dl fetched-articles))))) |
1061 |
|
|
1062 |
|
(defun gnus-agent-summary-fetch-group (&optional all) |
1063 |
|
"Fetch the downloadable articles in the group. |
1064 |
|
Optional arg ALL, if non-nil, means to fetch all articles." |
1065 |
|
(interactive "P") |
1066 |
|
(let ((articles |
1067 |
|
(if all gnus-newsgroup-articles |
1068 |
|
gnus-newsgroup-downloadable)) |
1069 |
|
(gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name)) |
1070 |
|
fetched-articles) |
1071 |
|
(gnus-agent-while-plugged |
1072 |
|
(unless articles |
1073 |
|
(error "No articles to download")) |
1074 |
|
(gnus-agent-with-fetch |
1075 |
|
(setq gnus-newsgroup-undownloaded |
1076 |
|
(gnus-sorted-ndifference |
1077 |
|
gnus-newsgroup-undownloaded |
1078 |
|
(setq fetched-articles |
1079 |
|
(gnus-agent-fetch-articles |
1080 |
|
gnus-newsgroup-name articles))))) |
1081 |
|
(save-excursion |
1082 |
|
(dolist (article articles) |
1083 |
|
(let ((was-marked-downloadable |
1084 |
|
(memq article gnus-newsgroup-downloadable))) |
1085 |
|
(cond (gnus-agent-mark-unread-after-downloaded |
1086 |
|
(setq gnus-newsgroup-downloadable |
1087 |
|
(delq article gnus-newsgroup-downloadable)) |
1088 |
|
|
1089 |
|
(gnus-summary-mark-article article gnus-unread-mark)) |
1090 |
|
(was-marked-downloadable |
1091 |
|
(gnus-summary-set-agent-mark article t))) |
1092 |
|
(when (gnus-summary-goto-subject article nil t) |
1093 |
|
(gnus-summary-update-download-mark article)))))) |
1094 |
|
fetched-articles)) |
1095 |
|
|
1096 |
|
(defun gnus-agent-fetch-selected-article () |
1097 |
|
"Fetch the current article as it is selected. |
1098 |
|
This can be added to `gnus-select-article-hook' or |
1099 |
|
`gnus-mark-article-hook'." |
1100 |
|
(let ((gnus-command-method gnus-current-select-method)) |
1101 |
|
(when (and gnus-plugged (gnus-agent-method-p gnus-command-method)) |
1102 |
|
(when (gnus-agent-fetch-articles |
1103 |
|
gnus-newsgroup-name |
1104 |
|
(list gnus-current-article)) |
1105 |
|
(setq gnus-newsgroup-undownloaded |
1106 |
|
(delq gnus-current-article gnus-newsgroup-undownloaded)) |
1107 |
|
(gnus-summary-update-download-mark gnus-current-article))))) |
1108 |
|
|
1109 |
;;; |
;;; |
1110 |
;;; Internal functions |
;;; Internal functions |
1111 |
;;; |
;;; |
1112 |
|
|
1113 |
(defun gnus-agent-save-active (method) |
(defun gnus-agent-save-active (method) |
|
(gnus-agent-save-active-1 method 'gnus-active-to-gnus-format)) |
|
|
|
|
|
(defun gnus-agent-save-active-1 (method function) |
|
1114 |
(when (gnus-agent-method-p method) |
(when (gnus-agent-method-p method) |
1115 |
(let* ((gnus-command-method method) |
(let* ((gnus-command-method method) |
1116 |
(new (gnus-make-hashtable (count-lines (point-min) (point-max)))) |
(new (gnus-make-hashtable (count-lines (point-min) (point-max)))) |
1117 |
(file (gnus-agent-lib-file "active"))) |
(file (gnus-agent-lib-file "active"))) |
1118 |
(funcall function nil new) |
(gnus-active-to-gnus-format nil new) |
1119 |
(gnus-agent-write-active file new) |
(gnus-agent-write-active file new) |
1120 |
(erase-buffer) |
(erase-buffer) |
1121 |
(nnheader-insert-file-contents file)))) |
(nnheader-insert-file-contents file)))) |
1122 |
|
|
1123 |
(defun gnus-agent-write-active (file new) |
(defun gnus-agent-write-active (file new) |
|
(let ((orig (gnus-make-hashtable (count-lines (point-min) (point-max)))) |
|
|
(file (gnus-agent-lib-file "active")) |
|
|
elem osym) |
|
|
(when (file-exists-p file) |
|
|
(with-temp-buffer |
|
|
(nnheader-insert-file-contents file) |
|
|
(gnus-active-to-gnus-format nil orig)) |
|
|
(mapatoms |
|
|
(lambda (sym) |
|
|
(when (and sym (boundp sym)) |
|
|
(if (and (boundp (setq osym (intern (symbol-name sym) orig))) |
|
|
(setq elem (symbol-value osym))) |
|
|
(setcdr elem (cdr (symbol-value sym))) |
|
|
(set (intern (symbol-name sym) orig) (symbol-value sym))))) |
|
|
new)) |
|
1124 |
(gnus-make-directory (file-name-directory file)) |
(gnus-make-directory (file-name-directory file)) |
1125 |
(let ((coding-system-for-write gnus-agent-file-coding-system)) |
(let ((nnmail-active-file-coding-system gnus-agent-file-coding-system)) |
1126 |
;; The hashtable contains real names of groups, no more prefix |
;; The hashtable contains real names of groups. However, do NOT |
1127 |
;; removing, so set `full' to `t'. |
;; add the foreign server prefix as gnus-active-to-gnus-format |
1128 |
(gnus-write-active-file file orig t)))) |
;; will add it while reading the file. |
1129 |
|
(gnus-write-active-file file new nil))) |
1130 |
(defun gnus-agent-save-groups (method) |
|
1131 |
(gnus-agent-save-active-1 method 'gnus-groups-to-gnus-format)) |
(defun gnus-agent-possibly-alter-active (group active &optional info) |
1132 |
|
"Possibly expand a group's active range to include articles |
1133 |
|
downloaded into the agent." |
1134 |
|
(let* ((gnus-command-method (or gnus-command-method |
1135 |
|
(gnus-find-method-for-group group)))) |
1136 |
|
(when (gnus-agent-method-p gnus-command-method) |
1137 |
|
(let* ((local (gnus-agent-get-local group)) |
1138 |
|
(active-min (or (car active) 0)) |
1139 |
|
(active-max (or (cdr active) 0)) |
1140 |
|
(agent-min (or (car local) active-min)) |
1141 |
|
(agent-max (or (cdr local) active-max))) |
1142 |
|
|
1143 |
|
(when (< agent-min active-min) |
1144 |
|
(setcar active agent-min)) |
1145 |
|
|
1146 |
|
(when (> agent-max active-max) |
1147 |
|
(setcdr active agent-max)) |
1148 |
|
|
1149 |
|
(when (and info (< agent-max (- active-min 100))) |
1150 |
|
;; I'm expanding the active range by such a large amount |
1151 |
|
;; that there is a gap of more than 100 articles between the |
1152 |
|
;; last article known to the agent and the first article |
1153 |
|
;; currently available on the server. This gap contains |
1154 |
|
;; articles that have been lost, mark them as read so that |
1155 |
|
;; gnus doesn't waste resources trying to fetch them. |
1156 |
|
|
1157 |
|
;; NOTE: I don't do this for smaller gaps (< 100) as I don't |
1158 |
|
;; want to modify the local file everytime someone restarts |
1159 |
|
;; gnus. The small gap will cause a tiny performance hit |
1160 |
|
;; when gnus tries, and fails, to retrieve the articles. |
1161 |
|
;; Still that should be smaller than opening a buffer, |
1162 |
|
;; printing this list to the buffer, and then writing it to a |
1163 |
|
;; file. |
1164 |
|
|
1165 |
|
(let ((read (gnus-info-read info))) |
1166 |
|
(gnus-info-set-read |
1167 |
|
info |
1168 |
|
(gnus-range-add |
1169 |
|
read |
1170 |
|
(list (cons (1+ agent-max) |
1171 |
|
(1- active-min)))))) |
1172 |
|
|
1173 |
|
;; Lie about the agent's local range for this group to |
1174 |
|
;; disable the set read each time this server is opened. |
1175 |
|
;; NOTE: Opening this group will restore the valid local |
1176 |
|
;; range but it will also expand the local range to |
1177 |
|
;; incompass the new active range. |
1178 |
|
(gnus-agent-set-local group agent-min (1- active-min))))))) |
1179 |
|
|
1180 |
(defun gnus-agent-save-group-info (method group active) |
(defun gnus-agent-save-group-info (method group active) |
1181 |
|
"Update a single group's active range in the agent's copy of the server's active file." |
1182 |
(when (gnus-agent-method-p method) |
(when (gnus-agent-method-p method) |
1183 |
(let* ((gnus-command-method method) |
(let* ((gnus-command-method method) |
1184 |
(coding-system-for-write nnheader-file-coding-system) |
(coding-system-for-write nnheader-file-coding-system) |
1185 |
(file-name-coding-system nnmail-pathname-coding-system) |
(file-name-coding-system nnmail-pathname-coding-system) |
1186 |
(file (gnus-agent-lib-file "active")) |
(file (gnus-agent-lib-file "active")) |
1187 |
oactive) |
oactive-min oactive-max) |
1188 |
(gnus-make-directory (file-name-directory file)) |
(gnus-make-directory (file-name-directory file)) |
1189 |
(with-temp-file file |
(with-temp-file file |
1190 |
;; Emacs got problem to match non-ASCII group in multibyte buffer. |
;; Emacs got problem to match non-ASCII group in multibyte buffer. |
1191 |
(mm-disable-multibyte) |
(mm-disable-multibyte) |
1192 |
(when (file-exists-p file) |
(when (file-exists-p file) |
1193 |
(nnheader-insert-file-contents file)) |
(nnheader-insert-file-contents file) |
1194 |
(goto-char (point-min)) |
|
1195 |
(when (re-search-forward |
(goto-char (point-min)) |
1196 |
(concat "^" (regexp-quote group) " ") nil t) |
(when (re-search-forward |
1197 |
(save-excursion |
(concat "^" (regexp-quote group) " ") nil t) |
1198 |
(save-restriction |
(save-excursion |
1199 |
(narrow-to-region (match-beginning 0) |
(setq oactive-max (read (current-buffer)) ;; max |
1200 |
(progn |
oactive-min (read (current-buffer)))) ;; min |
1201 |
(forward-line 1) |
(gnus-delete-line))) |
|
(point))) |
|
|
(setq oactive (car (nnmail-parse-active))))) |
|
|
(gnus-delete-line)) |
|
1202 |
(insert (format "%S %d %d y\n" (intern group) |
(insert (format "%S %d %d y\n" (intern group) |
1203 |
(cdr active) |
(max (or oactive-max (cdr active)) (cdr active)) |
1204 |
(or (car oactive) (car active)))) |
(min (or oactive-min (car active)) (car active)))) |
1205 |
(goto-char (point-max)) |
(goto-char (point-max)) |
1206 |
(while (search-backward "\\." nil t) |
(while (search-backward "\\." nil t) |
1207 |
(delete-char 1)))))) |
(delete-char 1)))))) |
1208 |
|
|
1209 |
(defun gnus-agent-group-path (group) |
(defun gnus-agent-group-path (group) |
1210 |
"Translate GROUP into a file name." |
"Translate GROUP into a file name." |
1211 |
(if nnmail-use-long-file-names |
|
1212 |
(gnus-group-real-name group) |
;; NOTE: This is what nnmail-group-pathname does as of Apr 2003. |
1213 |
(nnheader-translate-file-chars |
;; The two methods must be kept synchronized, which is why |
1214 |
(nnheader-replace-chars-in-string |
;; gnus-agent-group-pathname was added. |
1215 |
(nnheader-replace-duplicate-chars-in-string |
|
1216 |
(nnheader-replace-chars-in-string |
(setq group |
1217 |
(gnus-group-real-name group) |
(nnheader-translate-file-chars |
1218 |
?/ ?_) |
(nnheader-replace-duplicate-chars-in-string |
1219 |
?. ?_) |
(nnheader-replace-chars-in-string |
1220 |
?. ?/)))) |
(gnus-group-real-name group) |
1221 |
|
?/ ?_) |
1222 |
|
?. ?_))) |
1223 |
|
(if (or nnmail-use-long-file-names |
1224 |
(defun gnus-agent-method-p (method) |
(file-directory-p (expand-file-name group (gnus-agent-directory)))) |
1225 |
"Say whether METHOD is covered by the agent." |
group |
1226 |
(member method gnus-agent-covered-methods)) |
(mm-encode-coding-string |
1227 |
|
(nnheader-replace-chars-in-string group ?. ?/) |
1228 |
|
nnmail-pathname-coding-system))) |
1229 |
|
|
1230 |
|
(defun gnus-agent-group-pathname (group) |
1231 |
|
"Translate GROUP into a file name." |
1232 |
|
;; nnagent uses nnmail-group-pathname to read articles while |
1233 |
|
;; unplugged. The agent must, therefore, use the same directory |
1234 |
|
;; while plugged. |
1235 |
|
(let ((gnus-command-method (or gnus-command-method |
1236 |
|
(gnus-find-method-for-group group)))) |
1237 |
|
(nnmail-group-pathname (gnus-group-real-name group) (gnus-agent-directory)))) |
1238 |
|
|
1239 |
(defun gnus-agent-get-function (method) |
(defun gnus-agent-get-function (method) |
1240 |
(if (and (not gnus-plugged) |
(if (gnus-online method) |
1241 |
(gnus-agent-method-p method)) |
(car method) |
1242 |
(progn |
(require 'nnagent) |
1243 |
(require 'nnagent) |
'nnagent)) |
1244 |
'nnagent) |
|
1245 |
(car method))) |
(defun gnus-agent-covered-methods () |
1246 |
|
"Return the subset of methods that are covered by the agent." |
1247 |
|
(delq nil (mapcar #'gnus-server-to-method gnus-agent-covered-methods))) |
1248 |
|
|
1249 |
;;; History functions |
;;; History functions |
1250 |
|
|
1266 |
(nnheader-insert-file-contents file)) |
(nnheader-insert-file-contents file)) |
1267 |
(set (make-local-variable 'gnus-agent-file-name) file)))) |
(set (make-local-variable 'gnus-agent-file-name) file)))) |
1268 |
|
|
|
(defun gnus-agent-save-history () |
|
|
(save-excursion |
|
|
(set-buffer gnus-agent-current-history) |
|
|
(gnus-make-directory (file-name-directory gnus-agent-file-name)) |
|
|
(let ((coding-system-for-write gnus-agent-file-coding-system)) |
|
|
(write-region (1+ (point-min)) (point-max) |
|
|
gnus-agent-file-name nil 'silent)))) |
|
|
|
|
1269 |
(defun gnus-agent-close-history () |
(defun gnus-agent-close-history () |
1270 |
(when (gnus-buffer-live-p gnus-agent-current-history) |
(when (gnus-buffer-live-p gnus-agent-current-history) |
1271 |
(kill-buffer gnus-agent-current-history) |
(kill-buffer gnus-agent-current-history) |
1273 |
(delq (assoc (gnus-agent-method) gnus-agent-history-buffers) |
(delq (assoc (gnus-agent-method) gnus-agent-history-buffers) |
1274 |
gnus-agent-history-buffers)))) |
gnus-agent-history-buffers)))) |
1275 |
|
|
|
(defun gnus-agent-enter-history (id group-arts date) |
|
|
(save-excursion |
|
|
(set-buffer gnus-agent-current-history) |
|
|
(goto-char (point-max)) |
|
|
(let ((p (point))) |
|
|
(insert id "\t" (number-to-string date) "\t") |
|
|
(while group-arts |
|
|
(insert (format "%S" (intern (caar group-arts))) |
|
|
" " (number-to-string (cdr (pop group-arts))) |
|
|
" ")) |
|
|
(insert "\n") |
|
|
(while (search-backward "\\." p t) |
|
|
(delete-char 1))))) |
|
|
|
|
|
(defun gnus-agent-article-in-history-p (id) |
|
|
(save-excursion |
|
|
(set-buffer (gnus-agent-history-buffer)) |
|
|
(goto-char (point-min)) |
|
|
(search-forward (concat "\n" id "\t") nil t))) |
|
|
|
|
|
(defun gnus-agent-history-path (id) |
|
|
(save-excursion |
|
|
(set-buffer (gnus-agent-history-buffer)) |
|
|
(goto-char (point-min)) |
|
|
(when (search-forward (concat "\n" id "\t") nil t) |
|
|
(let ((method (gnus-agent-method))) |
|
|
(let (paths group) |
|
|
(while (not (numberp (setq group (read (current-buffer))))) |
|
|
(push (concat method "/" group) paths)) |
|
|
(nreverse paths)))))) |
|
|
|
|
1276 |
;;; |
;;; |
1277 |
;;; Fetching |
;;; Fetching |
1278 |
;;; |
;;; |
1280 |
(defun gnus-agent-fetch-articles (group articles) |
(defun gnus-agent-fetch-articles (group articles) |
1281 |
"Fetch ARTICLES from GROUP and put them into the Agent." |
"Fetch ARTICLES from GROUP and put them into the Agent." |
1282 |
(when articles |
(when articles |
1283 |
;; Prune off articles that we have already fetched. |
(gnus-agent-load-alist group) |
1284 |
(while (and articles |
(let* ((alist gnus-agent-article-alist) |
1285 |
(cdr (assq (car articles) gnus-agent-article-alist))) |
(headers (if (< (length articles) 2) nil gnus-newsgroup-headers)) |
1286 |
(pop articles)) |
(selected-sets (list nil)) |
1287 |
(let ((arts articles)) |
(current-set-size 0) |
1288 |
(while (cdr arts) |
article |
1289 |
(if (cdr (assq (cadr arts) gnus-agent-article-alist)) |
header-number) |
1290 |
(setcdr arts (cddr arts)) |
;; Check each article |
1291 |
(setq arts (cdr arts))))) |
(while (setq article (pop articles)) |
1292 |
(when articles |
;; Skip alist entries preceeding this article |
1293 |
(let ((dir (concat |
(while (> article (or (caar alist) (1+ article))) |
1294 |
(gnus-agent-directory) |
(setq alist (cdr alist))) |
1295 |
(gnus-agent-group-path group) "/")) |
|
1296 |
(date (time-to-days (current-time))) |
;; Prune off articles that we have already fetched. |
1297 |
(case-fold-search t) |
(unless (and (eq article (caar alist)) |
1298 |
pos crosses id elem) |
(cdar alist)) |
1299 |
(gnus-make-directory dir) |
;; Skip headers preceeding this article |
1300 |
(gnus-message 7 "Fetching articles for %s..." group) |
(while (> article |
1301 |
;; Fetch the articles from the backend. |
(setq header-number |
1302 |
(if (gnus-check-backend-function 'retrieve-articles group) |
(let* ((header (car headers))) |
1303 |
(setq pos (gnus-retrieve-articles articles group)) |
(if header |
1304 |
(with-temp-buffer |
(mail-header-number header) |
1305 |
(let (article) |
(1+ article))))) |
1306 |
(while (setq article (pop articles)) |
(setq headers (cdr headers))) |
1307 |
(when (or |
|
1308 |
(gnus-backlog-request-article group article |
;; Add this article to the current set |
1309 |
nntp-server-buffer) |
(setcar selected-sets (cons article (car selected-sets))) |
1310 |
(gnus-request-article article group)) |
|
1311 |
(goto-char (point-max)) |
;; Update the set size, when the set is too large start a |
1312 |
(push (cons article (point)) pos) |
;; new one. I do this after adding the article as I want at |
1313 |
(insert-buffer-substring nntp-server-buffer))) |
;; least one article in each set. |
1314 |
(copy-to-buffer nntp-server-buffer (point-min) (point-max)) |
(when (< gnus-agent-max-fetch-size |
1315 |
(setq pos (nreverse pos))))) |
(setq current-set-size |
1316 |
;; Then save these articles into the Agent. |
(+ current-set-size |
1317 |
(save-excursion |
(if (= header-number article) |
1318 |
(set-buffer nntp-server-buffer) |
(let ((char-size (mail-header-chars |
1319 |
(while pos |
(car headers)))) |
1320 |
(narrow-to-region (cdar pos) (or (cdadr pos) (point-max))) |
(if (<= char-size 0) |
1321 |
(goto-char (point-min)) |
;; The char size was missing/invalid, |
1322 |
(when (search-forward "\n\n" nil t) |
;; assume a worst-case situation of |
1323 |
(when (search-backward "\nXrefs: " nil t) |
;; 65 char/line. If the line count |
1324 |
;; Handle crossposting. |
;; is missing, arbitrarily assume a |
1325 |
(skip-chars-forward "^ ") |
;; size of 1000 characters. |
1326 |
(skip-chars-forward " ") |
(max (* 65 (mail-header-lines |
1327 |
(setq crosses nil) |
(car headers))) |
1328 |
(while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) +") |
1000) |
1329 |
(push (cons (buffer-substring (match-beginning 1) |
char-size)) |
1330 |
(match-end 1)) |
0)))) |
1331 |
(buffer-substring (match-beginning 2) |
(setcar selected-sets (nreverse (car selected-sets))) |
1332 |
(match-end 2))) |
(setq selected-sets (cons nil selected-sets) |
1333 |
crosses) |
current-set-size 0)))) |
1334 |
(goto-char (match-end 0))) |
|
1335 |
(gnus-agent-crosspost crosses (caar pos)))) |
(when (or (cdr selected-sets) (car selected-sets)) |
1336 |
(goto-char (point-min)) |
(let* ((fetched-articles (list nil)) |
1337 |
(if (not (re-search-forward "^Message-ID: *<\\([^>\n]+\\)>" nil t)) |
(tail-fetched-articles fetched-articles) |
1338 |
(setq id "No-Message-ID-in-article") |
(dir (gnus-agent-group-pathname group)) |
1339 |
(setq id (buffer-substring (match-beginning 1) (match-end 1)))) |
(date (time-to-days (current-time))) |
1340 |
(let ((coding-system-for-write |
(case-fold-search t) |
1341 |
gnus-agent-file-coding-system)) |
pos crosses id) |
1342 |
(write-region (point-min) (point-max) |
|
1343 |
(concat dir (number-to-string (caar pos))) |
(setcar selected-sets (nreverse (car selected-sets))) |
1344 |
nil 'silent)) |
(setq selected-sets (nreverse selected-sets)) |
1345 |
(when (setq elem (assq (caar pos) gnus-agent-article-alist)) |
|
1346 |
(setcdr elem t)) |
(gnus-make-directory dir) |
1347 |
(gnus-agent-enter-history |
(gnus-message 7 "Fetching articles for %s..." group) |
1348 |
id (or crosses (list (cons group (caar pos)))) date) |
|
1349 |
(widen) |
(unwind-protect |
1350 |
(pop pos))) |
(while (setq articles (pop selected-sets)) |
1351 |
(gnus-agent-save-alist group))))) |
;; Fetch the articles from the backend. |
1352 |
|
(if (gnus-check-backend-function 'retrieve-articles group) |
1353 |
|
(setq pos (gnus-retrieve-articles articles group)) |
1354 |
|
(with-temp-buffer |
1355 |
|
(let (article) |
1356 |
|
(while (setq article (pop articles)) |
1357 |
|
(gnus-message 10 "Fetching article %s for %s..." |
1358 |
|
article group) |
1359 |
|
(when (or |
1360 |
|
(gnus-backlog-request-article group article |
1361 |
|
nntp-server-buffer) |
1362 |
|
(gnus-request-article article group)) |
1363 |
|
(goto-char (point-max)) |
1364 |
|
(push (cons article (point)) pos) |
1365 |
|
(insert-buffer-substring nntp-server-buffer))) |
1366 |
|
(copy-to-buffer |
1367 |
|
nntp-server-buffer (point-min) (point-max)) |
1368 |
|
(setq pos (nreverse pos))))) |
1369 |
|
;; Then save these articles into the Agent. |
1370 |
|
(save-excursion |
1371 |
|
(set-buffer nntp-server-buffer) |
1372 |
|
(while pos |
1373 |
|
(narrow-to-region (cdar pos) (or (cdadr pos) (point-max))) |
1374 |
|
(goto-char (point-min)) |
1375 |
|
(unless (eobp) ;; Don't save empty articles. |
1376 |
|
(when (search-forward "\n\n" nil t) |
1377 |
|
(when (search-backward "\nXrefs: " nil t) |
1378 |
|
;; Handle cross posting. |
1379 |
|
(goto-char (match-end 0)) ; move to end of header name |
1380 |
|
(skip-chars-forward "^ ") ; skip server name |
1381 |
|
(skip-chars-forward " ") |
1382 |
|
(setq crosses nil) |
1383 |
|
(while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) *") |
1384 |
|
(push (cons (buffer-substring (match-beginning 1) |
1385 |
|
(match-end 1)) |
1386 |
|
(string-to-int |
1387 |
|
(buffer-substring (match-beginning 2) |
1388 |
|
(match-end 2)))) |
1389 |
|
crosses) |
1390 |
|
(goto-char (match-end 0))) |
1391 |
|
(gnus-agent-crosspost crosses (caar pos) date))) |
1392 |
|
(goto-char (point-min)) |
1393 |
|
(if (not (re-search-forward |
1394 |
|
"^Message-ID: *<\\([^>\n]+\\)>" nil t)) |
1395 |
|
(setq id "No-Message-ID-in-article") |
1396 |
|
(setq id (buffer-substring |
1397 |
|
(match-beginning 1) (match-end 1)))) |
1398 |
|
(let ((coding-system-for-write |
1399 |
|
gnus-agent-file-coding-system)) |
1400 |
|
(write-region (point-min) (point-max) |
1401 |
|
(concat dir (number-to-string (caar pos))) |
1402 |
|
nil 'silent)) |
1403 |
|
|
1404 |
|
(gnus-agent-append-to-list |
1405 |
|
tail-fetched-articles (caar pos))) |
1406 |
|
(widen) |
1407 |
|
(setq pos (cdr pos))))) |
1408 |
|
|
1409 |
|
(gnus-agent-save-alist group (cdr fetched-articles) date) |
1410 |
|
(gnus-message 7 "")) |
1411 |
|
(cdr fetched-articles)))))) |
1412 |
|
|
1413 |
|
(defun gnus-agent-crosspost (crosses article &optional date) |
1414 |
|
(setq date (or date t)) |
1415 |
|
|
|
(defun gnus-agent-crosspost (crosses article) |
|
1416 |
(let (gnus-agent-article-alist group alist beg end) |
(let (gnus-agent-article-alist group alist beg end) |
1417 |
(save-excursion |
(save-excursion |
1418 |
(set-buffer gnus-agent-overview-buffer) |
(set-buffer gnus-agent-overview-buffer) |
1425 |
(unless (setq alist (assoc group gnus-agent-group-alist)) |
(unless (setq alist (assoc group gnus-agent-group-alist)) |
1426 |
(push (setq alist (list group (gnus-agent-load-alist (caar crosses)))) |
(push (setq alist (list group (gnus-agent-load-alist (caar crosses)))) |
1427 |
gnus-agent-group-alist)) |
gnus-agent-group-alist)) |
1428 |
(setcdr alist (cons (cons (cdar crosses) t) (cdr alist))) |
(setcdr alist (cons (cons (cdar crosses) date) (cdr alist))) |
1429 |
(save-excursion |
(save-excursion |
1430 |
(set-buffer (gnus-get-buffer-create (format " *Gnus agent overview %s*" |
(set-buffer (gnus-get-buffer-create (format " *Gnus agent overview %s*" |
1431 |
group))) |
group))) |
1436 |
(gnus-agent-article-name ".overview" group)))) |
(gnus-agent-article-name ".overview" group)))) |
1437 |
(nnheader-find-nov-line (string-to-number (cdar crosses))) |
(nnheader-find-nov-line (string-to-number (cdar crosses))) |
1438 |
(insert (string-to-number (cdar crosses))) |
(insert (string-to-number (cdar crosses))) |
1439 |
(insert-buffer-substring gnus-agent-overview-buffer beg end)) |
(insert-buffer-substring gnus-agent-overview-buffer beg end) |
1440 |
(pop crosses)))) |
(gnus-agent-check-overview-buffer)) |
1441 |
|
(setq crosses (cdr crosses))))) |
1442 |
|
|
1443 |
|
(defun gnus-agent-backup-overview-buffer () |
1444 |
|
(when gnus-newsgroup-name |
1445 |
|
(let ((root (gnus-agent-article-name ".overview" gnus-newsgroup-name)) |
1446 |
|
(cnt 0) |
1447 |
|
name) |
1448 |
|
(while (file-exists-p |
1449 |
|
(setq name (concat root "~" |
1450 |
|
(int-to-string (setq cnt (1+ cnt))) "~")))) |
1451 |
|
(write-region (point-min) (point-max) name nil 'no-msg) |
1452 |
|
(gnus-message 1 "Created backup copy of overview in %s." name))) |
1453 |
|
t) |
1454 |
|
|
1455 |
|
(defun gnus-agent-check-overview-buffer (&optional buffer) |
1456 |
|
"Check the overview file given for sanity. |
1457 |
|
In particular, checks that the file is sorted by article number |
1458 |
|
and that there are no duplicates." |
1459 |
|
(let ((prev-num -1) |
1460 |
|
(backed-up nil)) |
1461 |
|
(save-excursion |
1462 |
|
(when buffer |
1463 |
|
(set-buffer buffer)) |
1464 |
|
(save-restriction |
1465 |
|
(widen) |
1466 |
|
(goto-char (point-min)) |
1467 |
|
|
1468 |
|
(while (< (point) (point-max)) |
1469 |
|
(let ((p (point)) |
1470 |
|
(cur (condition-case nil |
1471 |
|
(read (current-buffer)) |
1472 |
|
(error nil)))) |
1473 |
|
(cond |
1474 |
|
((or (not (integerp cur)) |
1475 |
|
(not (eq (char-after) ?\t))) |
1476 |
|
(or backed-up |
1477 |
|
(setq backed-up (gnus-agent-backup-overview-buffer))) |
1478 |
|
(gnus-message 1 |
1479 |
|
"Overview buffer contains garbage '%s'." |
1480 |
|
(buffer-substring |
1481 |
|
p (gnus-point-at-eol)))) |
1482 |
|
((= cur prev-num) |
1483 |
|
(or backed-up |
1484 |
|
(setq backed-up (gnus-agent-backup-overview-buffer))) |
1485 |
|
(gnus-message 1 |
1486 |
|
"Duplicate overview line for %d" cur) |
1487 |
|
(delete-region (point) (progn (forward-line 1) (point)))) |
1488 |
|
((< cur prev-num) |
1489 |
|
(or backed-up |
1490 |
|
(setq backed-up (gnus-agent-backup-overview-buffer))) |
1491 |
|
(gnus-message 1 "Overview buffer not sorted!") |
1492 |
|
(sort-numeric-fields 1 (point-min) (point-max)) |
1493 |
|
(goto-char (point-min)) |
1494 |
|
(setq prev-num -1)) |
1495 |
|
(t |
1496 |
|
(setq prev-num cur))) |
1497 |
|
(forward-line 1))))))) |
1498 |
|
|
1499 |
(defun gnus-agent-flush-cache () |
(defun gnus-agent-flush-cache () |
1500 |
(save-excursion |
(save-excursion |
1506 |
(gnus-agent-article-name ".overview" |
(gnus-agent-article-name ".overview" |
1507 |
(caar gnus-agent-buffer-alist)) |
(caar gnus-agent-buffer-alist)) |
1508 |
nil 'silent)) |
nil 'silent)) |
1509 |
(pop gnus-agent-buffer-alist)) |
(setq gnus-agent-buffer-alist (cdr gnus-agent-buffer-alist))) |
1510 |
(while gnus-agent-group-alist |
(while gnus-agent-group-alist |
1511 |
(with-temp-file (caar gnus-agent-group-alist) |
(with-temp-file (gnus-agent-article-name |
1512 |
|
".agentview" (caar gnus-agent-group-alist)) |
1513 |
(princ (cdar gnus-agent-group-alist)) |
(princ (cdar gnus-agent-group-alist)) |
1514 |
|
(insert "\n") |
1515 |
|
(princ 1 (current-buffer)) |
1516 |
(insert "\n")) |
(insert "\n")) |
1517 |
(pop gnus-agent-group-alist)))) |
(setq gnus-agent-group-alist (cdr gnus-agent-group-alist))))) |
1518 |
|
|
1519 |
(if (fboundp 'union) |
(defun gnus-agent-find-parameter (group symbol) |
1520 |
(defalias 'gnus-agent-union 'union) |
"Search for GROUPs SYMBOL in the group's parameters, the group's |
1521 |
(defun gnus-agent-union (l1 l2) |
topic parameters, the group's category, or the customizable |
1522 |
"Set union of lists L1 and L2." |
variables. Returns the first non-nil value found." |
1523 |
(cond ((null l1) l2) |
(or (gnus-group-find-parameter group symbol t) |
1524 |
((null l2) l1) |
(gnus-group-parameter-value (cdr (gnus-group-category group)) symbol t) |
1525 |
((equal l1 l2) l1) |
(symbol-value |
1526 |
(t |
(cdr |
1527 |
(or (>= (length l1) (length l2)) |
(assq symbol |
1528 |
(setq l1 (prog1 l2 (setq l2 l1)))) |
'((agent-short-article . gnus-agent-short-article) |
1529 |
(while l2 |
(agent-long-article . gnus-agent-long-article) |
1530 |
(or (memq (car l2) l1) |
(agent-low-score . gnus-agent-low-score) |
1531 |
(push (car l2) l1)) |
(agent-high-score . gnus-agent-high-score) |
1532 |
(pop l2)) |
(agent-days-until-old . gnus-agent-expire-days) |
1533 |
l1)))) |
(agent-enable-expiration |
1534 |
|
. gnus-agent-enable-expiration) |
1535 |
|
(agent-predicate . gnus-agent-predicate))))))) |
1536 |
|
|
1537 |
(defun gnus-agent-fetch-headers (group &optional force) |
(defun gnus-agent-fetch-headers (group &optional force) |
1538 |
(let ((articles (gnus-list-of-unread-articles group)) |
"Fetch interesting headers into the agent. The group's overview |
1539 |
(gnus-decode-encoded-word-function 'identity) |
file will be updated to include the headers while a list of available |
1540 |
(file (gnus-agent-article-name ".overview" group))) |
article numbers will be returned." |
1541 |
;; Add article with marks to list of article headers we want to fetch. |
(let* ((fetch-all (and gnus-agent-consider-all-articles |
1542 |
(dolist (arts (gnus-info-marks (gnus-get-info group))) |
;; Do not fetch all headers if the predicate |
1543 |
(setq articles (gnus-agent-union (gnus-uncompress-sequence (cdr arts)) |
;; implies that we only consider unread articles. |
1544 |
articles))) |
(not (gnus-predicate-implies-unread |
1545 |
(setq articles (sort articles '<)) |
(gnus-agent-find-parameter group |
1546 |
;; Remove known articles. |
'agent-predicate))))) |
1547 |
(when (gnus-agent-load-alist group) |
(articles (if fetch-all |
1548 |
(setq articles (gnus-sorted-intersection |
(gnus-uncompress-range (gnus-active group)) |
1549 |
articles |
(gnus-list-of-unread-articles group))) |
1550 |
(gnus-uncompress-range |
(gnus-decode-encoded-word-function 'identity) |
1551 |
(cons (1+ (caar (last gnus-agent-article-alist))) |
(file (gnus-agent-article-name ".overview" group))) |
1552 |
(cdr (gnus-active group))))))) |
|
1553 |
;; Fetch them. |
(unless fetch-all |
1554 |
(gnus-make-directory (nnheader-translate-file-chars |
;; Add articles with marks to the list of article headers we want to |
1555 |
(file-name-directory file) t)) |
;; fetch. Don't fetch articles solely on the basis of a recent or seen |
1556 |
(when articles |
;; mark, but do fetch recent or seen articles if they have other, more |
1557 |
(gnus-message 7 "Fetching headers for %s..." group) |
;; interesting marks. (We have to fetch articles with boring marks |
1558 |
|
;; because otherwise the agent will remove their marks.) |
1559 |
|
(dolist (arts (gnus-info-marks (gnus-get-info group))) |
1560 |
|
(unless (memq (car arts) '(seen recent killed cache)) |
1561 |
|
(setq articles (gnus-range-add articles (cdr arts))))) |
1562 |
|
(setq articles (sort (gnus-uncompress-sequence articles) '<))) |
1563 |
|
|
1564 |
|
;; At this point, I have the list of articles to consider for |
1565 |
|
;; fetching. This is the list that I'll return to my caller. Some |
1566 |
|
;; of these articles may have already been fetched. That's OK as |
1567 |
|
;; the fetch article code will filter those out. Internally, I'll |
1568 |
|
;; filter this list to just those articles whose headers need to |
1569 |
|
;; be fetched. |
1570 |
|
(let ((articles articles)) |
1571 |
|
;; Remove known articles. |
1572 |
|
(when (and (or gnus-agent-cache |
1573 |
|
(not gnus-plugged)) |
1574 |
|
(gnus-agent-load-alist group)) |
1575 |
|
;; Remove articles marked as downloaded. |
1576 |
|
(if fetch-all |
1577 |
|
;; I want to fetch all headers in the active range. |
1578 |
|
;; Therefore, exclude only those headers that are in the |
1579 |
|
;; article alist. |
1580 |
|
;; NOTE: This is probably NOT what I want to do after |
1581 |
|
;; agent expiration in this group. |
1582 |
|
(setq articles (gnus-agent-uncached-articles articles group)) |
1583 |
|
|
1584 |
|
;; I want to only fetch those headers that have never been |
1585 |
|
;; fetched. Therefore, exclude all headers that are, or |
1586 |
|
;; WERE, in the article alist. |
1587 |
|
(let ((low (1+ (caar (last gnus-agent-article-alist)))) |
1588 |
|
(high (cdr (gnus-active group)))) |
1589 |
|
;; Low can be greater than High when the same group is |
1590 |
|
;; fetched twice in the same session {The first fetch will |
1591 |
|
;; fill the article alist such that (last |
1592 |
|
;; gnus-agent-article-alist) equals (cdr (gnus-active |
1593 |
|
;; group))}. The addition of one(the 1+ above) then |
1594 |
|
;; forces Low to be greater than High. When this happens, |
1595 |
|
;; gnus-list-range-intersection returns nil which |
1596 |
|
;; indicates that no headers need to be fetched. -- Kevin |
1597 |
|
(setq articles (gnus-list-range-intersection |
1598 |
|
articles (list (cons low high))))))) |
1599 |
|
|
1600 |
|
(gnus-message |
1601 |
|
10 "gnus-agent-fetch-headers: undownloaded articles are '%s'" |
1602 |
|
(gnus-compress-sequence articles t)) |
1603 |
|
|
1604 |
(save-excursion |
(save-excursion |
1605 |
(set-buffer nntp-server-buffer) |
(set-buffer nntp-server-buffer) |
1606 |
(unless (eq 'nov (gnus-retrieve-headers articles group)) |
|
1607 |
(nnvirtual-convert-headers)) |
(if articles |
1608 |
;; Save these headers for later processing. |
(progn |
1609 |
(copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) |
(gnus-message 7 "Fetching headers for %s..." group) |
1610 |
(when (file-exists-p file) |
|
1611 |
(gnus-agent-braid-nov group articles file)) |
;; Fetch them. |
1612 |
(let ((coding-system-for-write |
(gnus-make-directory (nnheader-translate-file-chars |
1613 |
gnus-agent-file-coding-system)) |
(file-name-directory file) t)) |
1614 |
(write-region (point-min) (point-max) file nil 'silent)) |
|
1615 |
(gnus-agent-save-alist group articles nil) |
(unless (eq 'nov (gnus-retrieve-headers articles group)) |
1616 |
(gnus-agent-enter-history |
(nnvirtual-convert-headers)) |
1617 |
"last-header-fetched-for-session" |
(gnus-agent-check-overview-buffer) |
1618 |
(list (cons group (nth (- (length articles) 1) articles))) |
;; Move these headers to the overview buffer so that |
1619 |
(time-to-days (current-time))) |
;; gnus-agent-braid-nov can merge them with the contents |
1620 |
articles)))) |
;; of FILE. |
1621 |
|
(copy-to-buffer |
1622 |
|
gnus-agent-overview-buffer (point-min) (point-max)) |
1623 |
|
(when (file-exists-p file) |
1624 |
|
(gnus-agent-braid-nov group articles file)) |
1625 |
|
(let ((coding-system-for-write |
1626 |
|
gnus-agent-file-coding-system)) |
1627 |
|
(gnus-agent-check-overview-buffer) |
1628 |
|
(write-region (point-min) (point-max) file nil 'silent)) |
1629 |
|
(gnus-agent-save-alist group articles nil) |
1630 |
|
articles) |
1631 |
|
(ignore-errors |
1632 |
|
(erase-buffer) |
1633 |
|
(nnheader-insert-file-contents file))))) |
1634 |
|
articles)) |
1635 |
|
|
1636 |
(defsubst gnus-agent-copy-nov-line (article) |
(defsubst gnus-agent-copy-nov-line (article) |
1637 |
(let (b e) |
(let (art b e) |
1638 |
(set-buffer gnus-agent-overview-buffer) |
(set-buffer gnus-agent-overview-buffer) |
1639 |
(setq b (point)) |
(while (and (not (eobp)) |
1640 |
(if (eq article (read (current-buffer))) |
(< (setq art (read (current-buffer))) article)) |
1641 |
(setq e (progn (forward-line 1) (point))) |
(forward-line 1)) |
1642 |
(progn |
(beginning-of-line) |
1643 |
(beginning-of-line) |
(if (or (eobp) |
1644 |
(setq e b))) |
(not (eq article art))) |
1645 |
(set-buffer nntp-server-buffer) |
(set-buffer nntp-server-buffer) |
1646 |
(insert-buffer-substring gnus-agent-overview-buffer b e))) |
(setq b (point)) |
1647 |
|
(setq e (progn (forward-line 1) (point))) |
1648 |
|
(set-buffer nntp-server-buffer) |
1649 |
|
(insert-buffer-substring gnus-agent-overview-buffer b e)))) |
1650 |
|
|
1651 |
(defun gnus-agent-braid-nov (group articles file) |
(defun gnus-agent-braid-nov (group articles file) |
1652 |
(set-buffer gnus-agent-overview-buffer) |
"Merge agent overview data with given file. |
1653 |
(goto-char (point-min)) |
Takes headers for ARTICLES from `gnus-agent-overview-buffer' and the given |
1654 |
(set-buffer nntp-server-buffer) |
FILE and places the combined headers into `nntp-server-buffer'." |
1655 |
(erase-buffer) |
(let (start last) |
1656 |
(nnheader-insert-file-contents file) |
(set-buffer gnus-agent-overview-buffer) |
1657 |
(goto-char (point-max)) |
(goto-char (point-min)) |
1658 |
(if (or (= (point-min) (point-max)) |
(set-buffer nntp-server-buffer) |
1659 |
(progn |
(erase-buffer) |
1660 |
(forward-line -1) |
(nnheader-insert-file-contents file) |
1661 |
(< (read (current-buffer)) (car articles)))) |
(goto-char (point-max)) |
1662 |
;; We have only headers that are after the older headers, |
(forward-line -1) |
1663 |
;; so we just append them. |
(unless (looking-at "[0-9]+\t") |
1664 |
(progn |
;; Remove corrupted lines |
1665 |
(goto-char (point-max)) |
(gnus-message |
1666 |
(insert-buffer-substring gnus-agent-overview-buffer)) |
1 "Overview %s is corrupted. Removing corrupted lines..." file) |
1667 |
;; We do it the hard way. |
(goto-char (point-min)) |
1668 |
(nnheader-find-nov-line (car articles)) |
(while (not (eobp)) |
1669 |
(gnus-agent-copy-nov-line (car articles)) |
(if (looking-at "[0-9]+\t") |
1670 |
(pop articles) |
(forward-line 1) |
1671 |
(while (and articles |
(delete-region (point) (progn (forward-line 1) (point))))) |
1672 |
(not (eobp))) |
(forward-line -1)) |
1673 |
(while (and (not (eobp)) |
(unless (or (= (point-min) (point-max)) |
1674 |
(< (read (current-buffer)) (car articles))) |
(< (setq last (read (current-buffer))) (car articles))) |
1675 |
(forward-line 1)) |
;; We do it the hard way. |
1676 |
(beginning-of-line) |
(when (nnheader-find-nov-line (car articles)) |
1677 |
(unless (eobp) |
;; Replacing existing NOV entry |
1678 |
(gnus-agent-copy-nov-line (car articles)) |
(delete-region (point) (progn (forward-line 1) (point)))) |
1679 |
(setq articles (cdr articles)))) |
(gnus-agent-copy-nov-line (pop articles)) |
1680 |
|
|
1681 |
|
(ignore-errors |
1682 |
|
(while articles |
1683 |
|
(while (let ((art (read (current-buffer)))) |
1684 |
|
(cond ((< art (car articles)) |
1685 |
|
(forward-line 1) |
1686 |
|
t) |
1687 |
|
((= art (car articles)) |
1688 |
|
(beginning-of-line) |
1689 |
|
(delete-region |
1690 |
|
(point) (progn (forward-line 1) (point))) |
1691 |
|
nil) |
1692 |
|
(t |
1693 |
|
(beginning-of-line) |
1694 |
|
nil)))) |
1695 |
|
|
1696 |
|
(gnus-agent-copy-nov-line (pop articles))))) |
1697 |
|
|
1698 |
|
;; Copy the rest lines |
1699 |
|
(set-buffer nntp-server-buffer) |
1700 |
|
(goto-char (point-max)) |
1701 |
(when articles |
(when articles |
1702 |
(let (b e) |
(when last |
1703 |
(set-buffer gnus-agent-overview-buffer) |
(set-buffer gnus-agent-overview-buffer) |
1704 |
(setq b (point) |
(ignore-errors |
1705 |
e (point-max)) |
(while (<= (read (current-buffer)) last) |
1706 |
(set-buffer nntp-server-buffer) |
(forward-line 1))) |
1707 |
(insert-buffer-substring gnus-agent-overview-buffer b e))))) |
(beginning-of-line) |
1708 |
|
(setq start (point)) |
1709 |
|
(set-buffer nntp-server-buffer)) |
1710 |
|
(insert-buffer-substring gnus-agent-overview-buffer start)))) |
1711 |
|
|
1712 |
(defun gnus-agent-load-alist (group &optional dir) |
;; Keeps the compiler from warning about the free variable in |
1713 |
|
;; gnus-agent-read-agentview. |
1714 |
|
(eval-when-compile |
1715 |
|
(defvar gnus-agent-read-agentview)) |
1716 |
|
|
1717 |
|
(defun gnus-agent-load-alist (group) |
1718 |
"Load the article-state alist for GROUP." |
"Load the article-state alist for GROUP." |
1719 |
(setq gnus-agent-article-alist |
;; Bind free variable that's used in `gnus-agent-read-agentview'. |
1720 |
(gnus-agent-read-file |
(let ((gnus-agent-read-agentview group)) |
1721 |
(if dir |
(setq gnus-agent-article-alist |
1722 |
(expand-file-name ".agentview" dir) |
(gnus-cache-file-contents |
1723 |
(gnus-agent-article-name ".agentview" group))))) |
(gnus-agent-article-name ".agentview" group) |
1724 |
|
'gnus-agent-file-loading-cache |
1725 |
|
'gnus-agent-read-agentview)))) |
1726 |
|
|
1727 |
|
;; Save format may be either 1 or 2. Two is the new, compressed |
1728 |
|
;; format that is still being tested. Format 1 is uncompressed but |
1729 |
|
;; known to be reliable. |
1730 |
|
(defconst gnus-agent-article-alist-save-format 2) |
1731 |
|
|
1732 |
|
(defun gnus-agent-read-agentview (file) |
1733 |
|
"Load FILE and do a `read' there." |
1734 |
|
(with-temp-buffer |
1735 |
|
(ignore-errors |
1736 |
|
(nnheader-insert-file-contents file) |
1737 |
|
(goto-char (point-min)) |
1738 |
|
(let ((alist (read (current-buffer))) |
1739 |
|
(version (condition-case nil (read (current-buffer)) |
1740 |
|
(end-of-file 0))) |
1741 |
|
changed-version) |
1742 |
|
|
1743 |
|
(cond |
1744 |
|
((= version 0) |
1745 |
|
(let ((inhibit-quit t) |
1746 |
|
entry) |
1747 |
|
(gnus-agent-open-history) |
1748 |
|
(set-buffer (gnus-agent-history-buffer)) |
1749 |
|
(goto-char (point-min)) |
1750 |
|
(while (not (eobp)) |
1751 |
|
(if (and (looking-at |
1752 |
|
"[^\t\n]+\t\\([0-9]+\\)\t\\([^ \n]+\\) \\([0-9]+\\)") |
1753 |
|
(string= (match-string 2) |
1754 |
|
gnus-agent-read-agentview) |
1755 |
|
(setq entry (assoc (string-to-number (match-string 3)) alist))) |
1756 |
|
(setcdr entry (string-to-number (match-string 1)))) |
1757 |
|
(forward-line 1)) |
1758 |
|
(gnus-agent-close-history) |
1759 |
|
(setq changed-version t))) |
1760 |
|
((= version 1) |
1761 |
|
(setq changed-version (not (= 1 gnus-agent-article-alist-save-format)))) |
1762 |
|
((= version 2) |
1763 |
|
(let (uncomp) |
1764 |
|
(mapcar |
1765 |
|
(lambda (comp-list) |
1766 |
|
(let ((state (car comp-list)) |
1767 |
|
(sequence (gnus-uncompress-sequence |
1768 |
|
(cdr comp-list)))) |
1769 |
|
(mapcar (lambda (article-id) |
1770 |
|
(setq uncomp (cons (cons article-id state) uncomp))) |
1771 |
|
sequence))) |
1772 |
|
alist) |
1773 |
|
(setq alist (sort uncomp 'car-less-than-car))))) |
1774 |
|
(when changed-version |
1775 |
|
(let ((gnus-agent-article-alist alist)) |
1776 |
|
(gnus-agent-save-alist gnus-agent-read-agentview))) |
1777 |
|
alist)))) |
1778 |
|
|
1779 |
(defun gnus-agent-save-alist (group &optional articles state dir) |
(defun gnus-agent-save-alist (group &optional articles state) |
1780 |
"Save the article-state alist for GROUP." |
"Save the article-state alist for GROUP." |
1781 |
(let ((file-name-coding-system nnmail-pathname-coding-system)) |
(let* ((file-name-coding-system nnmail-pathname-coding-system) |
1782 |
(with-temp-file (if dir |
(prev (cons nil gnus-agent-article-alist)) |
1783 |
(expand-file-name ".agentview" dir) |
(all prev) |
1784 |
(gnus-agent-article-name ".agentview" group)) |
print-level print-length item article) |
1785 |
(princ (setq gnus-agent-article-alist |
(while (setq article (pop articles)) |
1786 |
(nconc gnus-agent-article-alist |
(while (and (cdr prev) |
1787 |
(mapcar (lambda (article) (cons article state)) |
(< (caadr prev) article)) |
1788 |
articles))) |
(setq prev (cdr prev))) |
1789 |
(current-buffer)) |
(cond |
1790 |
(insert "\n")))) |
((not (cdr prev)) |
1791 |
|
(setcdr prev (list (cons article state)))) |
1792 |
|
((> (caadr prev) article) |
1793 |
|
(setcdr prev (cons (cons article state) (cdr prev)))) |
1794 |
|
((= (caadr prev) article) |
1795 |
|
(setcdr (cadr prev) state))) |
1796 |
|
(setq prev (cdr prev))) |
1797 |
|
(setq gnus-agent-article-alist (cdr all)) |
1798 |
|
|
1799 |
|
(gnus-agent-set-local group |
1800 |
|
(caar gnus-agent-article-alist) |
1801 |
|
(caar (last gnus-agent-article-alist))) |
1802 |
|
|
1803 |
|
(gnus-make-directory (gnus-agent-article-name "" group)) |
1804 |
|
(with-temp-file (gnus-agent-article-name ".agentview" group) |
1805 |
|
(cond ((eq gnus-agent-article-alist-save-format 1) |
1806 |
|
(princ gnus-agent-article-alist (current-buffer))) |
1807 |
|
((eq gnus-agent-article-alist-save-format 2) |
1808 |
|
(let ((compressed nil)) |
1809 |
|
(mapcar (lambda (pair) |
1810 |
|
(let* ((article-id (car pair)) |
1811 |
|
(day-of-download (cdr pair)) |
1812 |
|
(comp-list (assq day-of-download compressed))) |
1813 |
|
(if comp-list |
1814 |
|
(setcdr comp-list |
1815 |
|
(cons article-id (cdr comp-list))) |
1816 |
|
(setq compressed |
1817 |
|
(cons (list day-of-download article-id) |
1818 |
|
compressed))) |
1819 |
|
nil)) gnus-agent-article-alist) |
1820 |
|
(mapcar (lambda (comp-list) |
1821 |
|
(setcdr comp-list |
1822 |
|
(gnus-compress-sequence |
1823 |
|
(nreverse (cdr comp-list))))) |
1824 |
|
compressed) |
1825 |
|
(princ compressed (current-buffer))))) |
1826 |
|
(insert "\n") |
1827 |
|
(princ gnus-agent-article-alist-save-format (current-buffer)) |
1828 |
|
(insert "\n")))) |
1829 |
|
|
1830 |
|
(defvar gnus-agent-article-local nil) |
1831 |
|
(defvar gnus-agent-file-loading-local nil) |
1832 |
|
|
1833 |
|
(defun gnus-agent-load-local (&optional method) |
1834 |
|
"Load the METHOD'S local file. The local file contains min/max |
1835 |
|
article counts for each of the method's subscribed groups." |
1836 |
|
(let ((gnus-command-method (or method gnus-command-method))) |
1837 |
|
(setq gnus-agent-article-local |
1838 |
|
(gnus-cache-file-contents |
1839 |
|
(gnus-agent-lib-file "local") |
1840 |
|
'gnus-agent-file-loading-local |
1841 |
|
'gnus-agent-read-and-cache-local)))) |
1842 |
|
|
1843 |
|
(defun gnus-agent-read-and-cache-local (file) |
1844 |
|
"Load and read FILE then bind its contents to |
1845 |
|
gnus-agent-article-local. If that variable had `dirty' (also known as |
1846 |
|
modified) original contents, they are first saved to their own file." |
1847 |
|
|
1848 |
|
(if (and gnus-agent-article-local |
1849 |
|
(symbol-value (intern "+dirty" gnus-agent-article-local))) |
1850 |
|
(gnus-agent-save-local)) |
1851 |
|
(gnus-agent-read-local file)) |
1852 |
|
|
1853 |
|
(defun gnus-agent-read-local (file) |
1854 |
|
"Load FILE and do a `read' there." |
1855 |
|
(let ((my-obarray (gnus-make-hashtable (count-lines (point-min) |
1856 |
|
(point-max)))) |
1857 |
|
(line 1)) |
1858 |
|
(with-temp-buffer |
1859 |
|
(condition-case nil |
1860 |
|
(nnheader-insert-file-contents file) |
1861 |
|
(file-error)) |
1862 |
|
|
1863 |
|
(goto-char (point-min)) |
1864 |
|
;; Skip any comments at the beginning of the file (the only place where they may appear) |
1865 |
|
(while (= (following-char) ?\;) |
1866 |
|
(forward-line 1) |
1867 |
|
(setq line (1+ line))) |
1868 |
|
|
1869 |
|
(while (not (eobp)) |
1870 |
|
(condition-case err |
1871 |
|
(let (group |
1872 |
|
min |
1873 |
|
max |
1874 |
|
(cur (current-buffer))) |
1875 |
|
(setq group (read cur) |
1876 |
|
min (read cur) |
1877 |
|
max (read cur)) |
1878 |
|
|
1879 |
|
(when (stringp group) |
1880 |
|
(setq group (intern group my-obarray))) |
1881 |
|
|
1882 |
|
;; NOTE: The '+ 0' ensure that min and max are both numerics. |
1883 |
|
(set group (cons (+ 0 min) (+ 0 max)))) |
1884 |
|
(error |
1885 |
|
(gnus-message 3 "Warning - invalid agent local: %s on line %d: " |
1886 |
|
file line (error-message-string err)))) |
1887 |
|
(forward-line 1) |
1888 |
|
(setq line (1+ line)))) |
1889 |
|
|
1890 |
|
(set (intern "+dirty" my-obarray) nil) |
1891 |
|
(set (intern "+method" my-obarray) gnus-command-method) |
1892 |
|
my-obarray)) |
1893 |
|
|
1894 |
|
(defun gnus-agent-save-local (&optional force) |
1895 |
|
"Save gnus-agent-article-local under it method's agent.lib directory." |
1896 |
|
(let ((my-obarray gnus-agent-article-local)) |
1897 |
|
(when (and my-obarray |
1898 |
|
(or force (symbol-value (intern "+dirty" my-obarray)))) |
1899 |
|
(let* ((gnus-command-method (symbol-value (intern "+method" my-obarray))) |
1900 |
|
;; NOTE: gnus-command-method is used within gnus-agent-lib-file. |
1901 |
|
(dest (gnus-agent-lib-file "local"))) |
1902 |
|
(gnus-make-directory (gnus-agent-lib-file "")) |
1903 |
|
(with-temp-file dest |
1904 |
|
(let ((gnus-command-method (symbol-value (intern "+method" my-obarray))) |
1905 |
|
(file-name-coding-system nnmail-pathname-coding-system) |
1906 |
|
(coding-system-for-write |
1907 |
|
gnus-agent-file-coding-system) |
1908 |
|
print-level print-length item article |
1909 |
|
(standard-output (current-buffer))) |
1910 |
|
(mapatoms (lambda (symbol) |
1911 |
|
(cond ((not (boundp symbol)) |
1912 |
|
nil) |
1913 |
|
((member (symbol-name symbol) '("+dirty" "+method")) |
1914 |
|
nil) |
1915 |
|
(t |
1916 |
|
(prin1 symbol) |
1917 |
|
(let ((range (symbol-value symbol))) |
1918 |
|
(princ " ") |
1919 |
|
(princ (car range)) |
1920 |
|
(princ " ") |
1921 |
|
(princ (cdr range)) |
1922 |
|
(princ "\n"))))) |
1923 |
|
my-obarray))))))) |
1924 |
|
|
1925 |
|
(defun gnus-agent-get-local (group) |
1926 |
|
(let* ((gmane (gnus-group-real-name group)) |
1927 |
|
(gnus-command-method (gnus-find-method-for-group group)) |
1928 |
|
(local (gnus-agent-load-local)) |
1929 |
|
(symb (intern gmane local)) |
1930 |
|
(minmax (and (boundp symb) (symbol-value symb)))) |
1931 |
|
(unless minmax |
1932 |
|
;; Bind these so that gnus-agent-load-alist doesn't change the |
1933 |
|
;; current alist (i.e. gnus-agent-article-alist) |
1934 |
|
(let* ((gnus-agent-article-alist gnus-agent-article-alist) |
1935 |
|
(gnus-agent-file-loading-cache gnus-agent-file-loading-cache) |
1936 |
|
(alist (gnus-agent-load-alist group))) |
1937 |
|
(when alist |
1938 |
|
(setq minmax |
1939 |
|
(cons (caar alist) |
1940 |
|
(caar (last alist)))) |
1941 |
|
(gnus-agent-set-local group (car minmax) (cdr minmax) |
1942 |
|
gmane gnus-command-method local)))) |
1943 |
|
minmax)) |
1944 |
|
|
1945 |
|
(defun gnus-agent-set-local (group min max &optional gmane method local) |
1946 |
|
(let* ((gmane (or gmane (gnus-group-real-name group))) |
1947 |
|
(gnus-command-method (or method (gnus-find-method-for-group group))) |
1948 |
|
(local (or local (gnus-agent-load-local))) |
1949 |
|
(symb (intern gmane local)) |
1950 |
|
(minmax (and (boundp symb) (symbol-value symb)))) |
1951 |
|
|
1952 |
|
(if (cond ((and minmax |
1953 |
|
(or (not (eq min (car minmax))) |
1954 |
|
(not (eq max (cdr minmax))))) |
1955 |
|
(setcar minmax min) |
1956 |
|
(setcdr minmax max) |
1957 |
|
t) |
1958 |
|
(minmax |
1959 |
|
nil) |
1960 |
|
((and min max) |
1961 |
|
(set symb (cons min max)) |
1962 |
|
t)) |
1963 |
|
(set (intern "+dirty" local) t)))) |
1964 |
|
|
1965 |
(defun gnus-agent-article-name (article group) |
(defun gnus-agent-article-name (article group) |
1966 |
(expand-file-name (if (stringp article) article (string-to-number article)) |
(expand-file-name article |
1967 |
(file-name-as-directory |
(file-name-as-directory |
1968 |
(expand-file-name (gnus-agent-group-path group) |
(gnus-agent-group-pathname group)))) |
|
(gnus-agent-directory))))) |
|
1969 |
|
|
1970 |
(defun gnus-agent-batch-confirmation (msg) |
(defun gnus-agent-batch-confirmation (msg) |
1971 |
"Show error message and return t." |
"Show error message and return t." |
1988 |
(error "No servers are covered by the Gnus agent")) |
(error "No servers are covered by the Gnus agent")) |
1989 |
(unless gnus-plugged |
(unless gnus-plugged |
1990 |
(error "Can't fetch articles while Gnus is unplugged")) |
(error "Can't fetch articles while Gnus is unplugged")) |
1991 |
(let ((methods gnus-agent-covered-methods) |
(let ((methods (gnus-agent-covered-methods)) |
1992 |
groups group gnus-command-method) |
groups group gnus-command-method) |
1993 |
(save-excursion |
(save-excursion |
1994 |
(while methods |
(while methods |
1995 |
(condition-case err |
(setq gnus-command-method (car methods)) |
1996 |
(progn |
(when (and (or (gnus-server-opened gnus-command-method) |
1997 |
(setq gnus-command-method (car methods)) |
(gnus-open-server gnus-command-method)) |
1998 |
(when (or (gnus-server-opened gnus-command-method) |
(gnus-online gnus-command-method)) |
1999 |
(gnus-open-server gnus-command-method)) |
(setq groups (gnus-groups-from-server (car methods))) |
2000 |
(setq groups (gnus-groups-from-server (car methods))) |
(gnus-agent-with-fetch |
2001 |
(gnus-agent-with-fetch |
(while (setq group (pop groups)) |
2002 |
(while (setq group (pop groups)) |
(when (<= (gnus-group-level group) |
2003 |
(when (<= (gnus-group-level group) gnus-agent-handle-level) |
gnus-agent-handle-level) |
2004 |
(gnus-agent-fetch-group-1 group gnus-command-method)))))) |
(if (or debug-on-error debug-on-quit) |
2005 |
(error |
(gnus-agent-fetch-group-1 |
2006 |
(unless (funcall gnus-agent-confirmation-function |
group gnus-command-method) |
2007 |
(format "Error (%s). Continue? " err)) |
(condition-case err |
2008 |
(error "Cannot fetch articles into the Gnus agent"))) |
(gnus-agent-fetch-group-1 |
2009 |
(quit |
group gnus-command-method) |
2010 |
(unless (funcall gnus-agent-confirmation-function |
(error |
2011 |
(format "Quit (%s). Continue? " err)) |
(unless (funcall gnus-agent-confirmation-function |
2012 |
(signal 'quit "Cannot fetch articles into the Gnus agent.")))) |
(format "Error %s. Continue? " |
2013 |
(pop methods)) |
(error-message-string err))) |
2014 |
|
(error "Cannot fetch articles into the Gnus agent"))) |
2015 |
|
(quit |
2016 |
|
(unless (funcall gnus-agent-confirmation-function |
2017 |
|
(format |
2018 |
|
"Quit fetching session %s. Continue? " |
2019 |
|
(error-message-string err))) |
2020 |
|
(signal 'quit |
2021 |
|
"Cannot fetch articles into the Gnus agent"))))))))) |
2022 |
|
(setq methods (cdr methods))) |
2023 |
|
(gnus-run-hooks 'gnus-agent-fetched-hook) |
2024 |
(gnus-message 6 "Finished fetching articles into the Gnus agent")))) |
(gnus-message 6 "Finished fetching articles into the Gnus agent")))) |
2025 |
|
|
2026 |
(defun gnus-agent-fetch-group-1 (group method) |
(defun gnus-agent-fetch-group-1 (group method) |
2027 |
"Fetch GROUP." |
"Fetch GROUP." |
2028 |
(let ((gnus-command-method method) |
(let ((gnus-command-method method) |
2029 |
(gnus-newsgroup-name group) |
(gnus-newsgroup-name group) |
2030 |
gnus-newsgroup-dependencies gnus-newsgroup-headers |
(gnus-newsgroup-dependencies gnus-newsgroup-dependencies) |
2031 |
gnus-newsgroup-scored gnus-headers gnus-score |
(gnus-newsgroup-headers gnus-newsgroup-headers) |
2032 |
gnus-use-cache articles arts |
(gnus-newsgroup-scored gnus-newsgroup-scored) |
2033 |
category predicate info marks score-param |
(gnus-use-cache gnus-use-cache) |
2034 |
(gnus-summary-expunge-below gnus-summary-expunge-below) |
(gnus-summary-expunge-below gnus-summary-expunge-below) |
2035 |
(gnus-summary-mark-below gnus-summary-mark-below) |
(gnus-summary-mark-below gnus-summary-mark-below) |
2036 |
(gnus-orphan-score gnus-orphan-score) |
(gnus-orphan-score gnus-orphan-score) |
2037 |
;; Maybe some other gnus-summary local variables should also |
;; Maybe some other gnus-summary local variables should also |
2038 |
;; be put here. |
;; be put here. |
2039 |
|
|
2040 |
|
gnus-headers |
2041 |
|
gnus-score |
2042 |
|
articles arts |
2043 |
|
category predicate info marks score-param |
2044 |
) |
) |
2045 |
(unless (gnus-check-group group) |
(unless (gnus-check-group group) |
2046 |
(error "Can't open server for %s" group)) |
(error "Can't open server for %s" group)) |
2047 |
|
|
2048 |
;; Fetch headers. |
;; Fetch headers. |
2049 |
(when (and (or (gnus-active group) (gnus-activate-group group)) |
(when (or gnus-newsgroup-active |
2050 |
(setq articles (gnus-agent-fetch-headers group)) |
(gnus-active group) |
2051 |
(let ((nntp-server-buffer gnus-agent-overview-buffer)) |
(gnus-activate-group group)) |
2052 |
;; Parse them and see which articles we want to fetch. |
(let ((marked-articles gnus-newsgroup-downloadable)) |
2053 |
(setq gnus-newsgroup-dependencies |
;; Identify the articles marked for download |
2054 |
(make-vector (length articles) 0)) |
(unless gnus-newsgroup-active |
2055 |
(setq gnus-newsgroup-headers |
;; The variable gnus-newsgroup-active was selected as I need |
2056 |
(gnus-get-newsgroup-headers-xover articles nil nil |
;; a gnus-summary local variable that is NOT bound to any |
2057 |
group)) |
;; value (its global value should default to nil). |
2058 |
;; `gnus-agent-overview-buffer' may be killed for |
(dolist (mark gnus-agent-download-marks) |
2059 |
;; timeout reason. If so, recreate it. |
(let ((arts (cdr (assq mark (gnus-info-marks |
2060 |
(gnus-agent-create-buffer))) |
(setq info (gnus-get-info group))))))) |
2061 |
(setq category (gnus-group-category group)) |
(when arts |
2062 |
(setq predicate |
(setq marked-articles (nconc (gnus-uncompress-range arts) |
2063 |
(gnus-get-predicate |
marked-articles)) |
2064 |
(or (gnus-group-find-parameter group 'agent-predicate t) |
)))) |
2065 |
(cadr category)))) |
(setq marked-articles (sort marked-articles '<)) |
2066 |
(if (memq (caaddr predicate) '(gnus-agent-true gnus-agent-false)) |
|
2067 |
;; Simple implementation |
;; Fetch any new articles from the server |
2068 |
(setq arts |
(setq articles (gnus-agent-fetch-headers group)) |
2069 |
(and (eq (caaddr predicate) 'gnus-agent-true) articles)) |
|
2070 |
(setq arts nil) |
;; Merge new articles with marked |
2071 |
(setq score-param |
(setq articles (sort (append marked-articles articles) '<)) |
2072 |
(or (gnus-group-get-parameter group 'agent-score t) |
|
2073 |
(caddr category))) |
(when articles |
2074 |
;; Translate score-param into real one |
;; Parse them and see which articles we want to fetch. |
2075 |
(cond |
(setq gnus-newsgroup-dependencies |
2076 |
((not score-param)) |
(or gnus-newsgroup-dependencies |
2077 |
((eq score-param 'file) |
(make-vector (length articles) 0))) |
2078 |
(setq score-param (gnus-all-score-files group))) |
(setq gnus-newsgroup-headers |
2079 |
((stringp (car score-param))) |
(or gnus-newsgroup-headers |
2080 |
(t |
(gnus-get-newsgroup-headers-xover articles nil nil |
2081 |
(setq score-param (list (list score-param))))) |
group))) |
2082 |
(when score-param |
;; `gnus-agent-overview-buffer' may be killed for |
2083 |
(gnus-score-headers score-param)) |
;; timeout reason. If so, recreate it. |
2084 |
(while (setq gnus-headers (pop gnus-newsgroup-headers)) |
(gnus-agent-create-buffer) |
2085 |
(setq gnus-score |
|
2086 |
(or (cdr (assq (mail-header-number gnus-headers) |
;; Figure out how to select articles in this group |
2087 |
gnus-newsgroup-scored)) |
(setq category (gnus-group-category group)) |
2088 |
gnus-summary-default-score)) |
|
2089 |
(when (funcall predicate) |
(setq predicate |
2090 |
(push (mail-header-number gnus-headers) |
(gnus-get-predicate |
2091 |
arts)))) |
(gnus-agent-find-parameter group 'agent-predicate))) |
2092 |
;; Fetch the articles. |
|
2093 |
(when arts |
;; If the selection predicate requires scoring, score each header |
2094 |
(gnus-agent-fetch-articles group arts))) |
(unless (memq predicate '(gnus-agent-true gnus-agent-false)) |
2095 |
;; Perhaps we have some additional articles to fetch. |
(let ((score-param |
2096 |
(setq arts (assq 'download (gnus-info-marks |
(gnus-agent-find-parameter group 'agent-score-file))) |
2097 |
(setq info (gnus-get-info group))))) |
;; Translate score-param into real one |
2098 |
(when (cdr arts) |
(cond |
2099 |
(gnus-agent-fetch-articles |
((not score-param)) |
2100 |
group (gnus-uncompress-range (cdr arts))) |
((eq score-param 'file) |
2101 |
(setq marks (delq arts (gnus-info-marks info))) |
(setq score-param (gnus-all-score-files group))) |
2102 |
(gnus-info-set-marks info marks) |
((stringp (car score-param))) |
2103 |
(gnus-dribble-enter |
(t |
2104 |
(concat "(gnus-group-set-info '" |
(setq score-param (list (list score-param))))) |
2105 |
(gnus-prin1-to-string info) |
(when score-param |
2106 |
")"))))) |
(gnus-score-headers score-param)))) |
2107 |
|
|
2108 |
|
(unless (and (eq predicate 'gnus-agent-false) |
2109 |
|
(not marked-articles)) |
2110 |
|
(let ((arts (list nil))) |
2111 |
|
(let ((arts-tail arts) |
2112 |
|
(alist (gnus-agent-load-alist group)) |
2113 |
|
(marked-articles marked-articles) |
2114 |
|
(gnus-newsgroup-headers gnus-newsgroup-headers)) |
2115 |
|
(while (setq gnus-headers (pop gnus-newsgroup-headers)) |
2116 |
|
(let ((num (mail-header-number gnus-headers))) |
2117 |
|
;; Determine if this article is already in the cache |
2118 |
|
(while (and alist |
2119 |
|
(> num (caar alist))) |
2120 |
|
(setq alist (cdr alist))) |
2121 |
|
|
2122 |
|
(unless (and (eq num (caar alist)) |
2123 |
|
(cdar alist)) |
2124 |
|
|
2125 |
|
;; Determine if this article was marked for download. |
2126 |
|
(while (and marked-articles |
2127 |
|
(> num (car marked-articles))) |
2128 |
|
(setq marked-articles |
2129 |
|
(cdr marked-articles))) |
2130 |
|
|
2131 |
|
;; When this article is marked, or selected by the |
2132 |
|
;; predicate, add it to the download list |
2133 |
|
(when (or (eq num (car marked-articles)) |
2134 |
|
(let ((gnus-score |
2135 |
|
(or (cdr |
2136 |
|
(assq num gnus-newsgroup-scored)) |
2137 |
|
gnus-summary-default-score)) |
2138 |
|
(gnus-agent-long-article |
2139 |
|
(gnus-agent-find-parameter |
2140 |
|
group 'agent-long-article)) |
2141 |
|
(gnus-agent-short-article |
2142 |
|
(gnus-agent-find-parameter |
2143 |
|
group 'agent-short-article)) |
2144 |
|
(gnus-agent-low-score |
2145 |
|
(gnus-agent-find-parameter |
2146 |
|
group 'agent-low-score)) |
2147 |
|
(gnus-agent-high-score |
2148 |
|
(gnus-agent-find-parameter |
2149 |
|
group 'agent-high-score)) |
2150 |
|
(gnus-agent-expire-days |
2151 |
|
(gnus-agent-find-parameter |
2152 |
|
group 'agent-days-until-old))) |
2153 |
|
(funcall predicate))) |
2154 |
|
(gnus-agent-append-to-list arts-tail num)))))) |
2155 |
|
|
2156 |
|
(let (fetched-articles) |
2157 |
|
;; Fetch all selected articles |
2158 |
|
(setq gnus-newsgroup-undownloaded |
2159 |
|
(gnus-sorted-ndifference |
2160 |
|
gnus-newsgroup-undownloaded |
2161 |
|
(setq fetched-articles |
2162 |
|
(if (cdr arts) |
2163 |
|
(gnus-agent-fetch-articles group (cdr arts)) |
2164 |
|
nil)))) |
2165 |
|
|
2166 |
|
(let ((unfetched-articles |
2167 |
|
(gnus-sorted-ndifference (cdr arts) fetched-articles))) |
2168 |
|
(if gnus-newsgroup-active |
2169 |
|
;; Update the summary buffer |
2170 |
|
(progn |
2171 |
|
(dolist (article marked-articles) |
2172 |
|
(gnus-summary-set-agent-mark article t)) |
2173 |
|
(dolist (article fetched-articles) |
2174 |
|
(if gnus-agent-mark-unread-after-downloaded |
2175 |
|
(gnus-summary-mark-article |
2176 |
|
article gnus-unread-mark)) |
2177 |
|
(when (gnus-summary-goto-subject article nil t) |
2178 |
|
(gnus-summary-update-download-mark article))) |
2179 |
|
(dolist (article unfetched-articles) |
2180 |
|
(gnus-summary-mark-article |
2181 |
|
article gnus-canceled-mark))) |
2182 |
|
|
2183 |
|
;; Update the group buffer. |
2184 |
|
|
2185 |
|
;; When some, or all, of the marked articles came |
2186 |
|
;; from the download mark. Remove that mark. I |
2187 |
|
;; didn't do this earlier as I only want to remove |
2188 |
|
;; the marks after the fetch is completed. |
2189 |
|
|
2190 |
|
(dolist (mark gnus-agent-download-marks) |
2191 |
|
(when (eq mark 'download) |
2192 |
|
(let ((marked-arts |
2193 |
|
(assq mark (gnus-info-marks |
2194 |
|
(setq info (gnus-get-info group)))))) |
2195 |
|
(when (cdr marked-arts) |
2196 |
|
(setq marks |
2197 |
|
(delq marked-arts (gnus-info-marks info))) |
2198 |
|
(gnus-info-set-marks info marks))))) |
2199 |
|
(let ((read (gnus-info-read |
2200 |
|
(or info (setq info (gnus-get-info group)))))) |
2201 |
|
(gnus-info-set-read |
2202 |
|
info (gnus-add-to-range read unfetched-articles))) |
2203 |
|
|
2204 |
|
(gnus-group-update-group group t) |
2205 |
|
(sit-for 0) |
2206 |
|
|
2207 |
|
(gnus-dribble-enter |
2208 |
|
(concat "(gnus-group-set-info '" |
2209 |
|
(gnus-prin1-to-string info) |
2210 |
|
")")))))))))))) |
2211 |
|
|
2212 |
;;; |
;;; |
2213 |
;;; Agent Category Mode |
;;; Agent Category Mode |
2217 |
"Hook run in `gnus-category-mode' buffers.") |
"Hook run in `gnus-category-mode' buffers.") |
2218 |
|
|
2219 |
(defvar gnus-category-line-format " %(%20c%): %g\n" |
(defvar gnus-category-line-format " %(%20c%): %g\n" |
2220 |
"Format of category lines.") |
"Format of category lines. |
2221 |
|
|
2222 |
|
Valid specifiers include: |
2223 |
|
%c Topic name (string) |
2224 |
|
%g The number of groups in the topic (integer) |
2225 |
|
|
2226 |
|
General format specifiers can also be used. See Info node |
2227 |
|
`(gnus)Formatting Variables'.") |
2228 |
|
|
2229 |
(defvar gnus-category-mode-line-format "Gnus: %%b" |
(defvar gnus-category-mode-line-format "Gnus: %%b" |
2230 |
"The format specification for the category mode line.") |
"The format specification for the category mode line.") |
2231 |
|
|
2232 |
|
(defvar gnus-agent-predicate 'false |
2233 |
|
"The selection predicate used when no other source is available.") |
2234 |
|
|
2235 |
(defvar gnus-agent-short-article 100 |
(defvar gnus-agent-short-article 100 |
2236 |
"Articles that have fewer lines than this are short.") |
"Articles that have fewer lines than this are short.") |
2237 |
|
|
2271 |
"k" gnus-category-kill |
"k" gnus-category-kill |
2272 |
"c" gnus-category-copy |
"c" gnus-category-copy |
2273 |
"a" gnus-category-add |
"a" gnus-category-add |
2274 |
|
"e" gnus-agent-customize-category |
2275 |
"p" gnus-category-edit-predicate |
"p" gnus-category-edit-predicate |
2276 |
"g" gnus-category-edit-groups |
"g" gnus-category-edit-groups |
2277 |
"s" gnus-category-edit-score |
"s" gnus-category-edit-score |
2292 |
["Add" gnus-category-add t] |
["Add" gnus-category-add t] |
2293 |
["Kill" gnus-category-kill t] |
["Kill" gnus-category-kill t] |
2294 |
["Copy" gnus-category-copy t] |
["Copy" gnus-category-copy t] |
2295 |
|
["Edit category" gnus-agent-customize-category t] |
2296 |
["Edit predicate" gnus-category-edit-predicate t] |
["Edit predicate" gnus-category-edit-predicate t] |
2297 |
["Edit score" gnus-category-edit-score t] |
["Edit score" gnus-category-edit-score t] |
2298 |
["Edit groups" gnus-category-edit-groups t] |
["Edit groups" gnus-category-edit-groups t] |
2306 |
All normal editing commands are switched off. |
All normal editing commands are switched off. |
2307 |
\\<gnus-category-mode-map> |
\\<gnus-category-mode-map> |
2308 |
For more in-depth information on this mode, read the manual |
For more in-depth information on this mode, read the manual |
2309 |
(`\\[gnus-info-find-node]'). |
\(`\\[gnus-info-find-node]'). |
2310 |
|
|
2311 |
The following commands are available: |
The following commands are available: |
2312 |
|
|
2329 |
(defalias 'gnus-category-position-point 'gnus-goto-colon) |
(defalias 'gnus-category-position-point 'gnus-goto-colon) |
2330 |
|
|
2331 |
(defun gnus-category-insert-line (category) |
(defun gnus-category-insert-line (category) |
2332 |
(let* ((gnus-tmp-name (car category)) |
(let* ((gnus-tmp-name (format "%s" (car category))) |
2333 |
(gnus-tmp-groups (length (cadddr category)))) |
(gnus-tmp-groups (length (gnus-agent-cat-groups category)))) |
2334 |
(beginning-of-line) |
(beginning-of-line) |
2335 |
(gnus-add-text-properties |
(gnus-add-text-properties |
2336 |
(point) |
(point) |
2364 |
(gnus-category-position-point))) |
(gnus-category-position-point))) |
2365 |
|
|
2366 |
(defun gnus-category-name () |
(defun gnus-category-name () |
2367 |
(or (get-text-property (gnus-point-at-bol) 'gnus-category) |
(or (intern (get-text-property (gnus-point-at-bol) 'gnus-category)) |
2368 |
(error "No category on the current line"))) |
(error "No category on the current line"))) |
2369 |
|
|
2370 |
(defun gnus-category-read () |
(defun gnus-category-read () |
2371 |
"Read the category alist." |
"Read the category alist." |
2372 |
(setq gnus-category-alist |
(setq gnus-category-alist |
2373 |
(or (gnus-agent-read-file |
(or |
2374 |
(nnheader-concat gnus-agent-directory "lib/categories")) |
(with-temp-buffer |
2375 |
(list (list 'default 'short nil nil))))) |
(ignore-errors |
2376 |
|
(nnheader-insert-file-contents (nnheader-concat gnus-agent-directory "lib/categories")) |
2377 |
|
(goto-char (point-min)) |
2378 |
|
;; This code isn't temp, it will be needed so long as |
2379 |
|
;; anyone may be migrating from an older version. |
2380 |
|
|
2381 |
|
;; Once we're certain that people will not revert to an |
2382 |
|
;; earlier version, we can take out the old-list code in |
2383 |
|
;; gnus-category-write. |
2384 |
|
(let* ((old-list (read (current-buffer))) |
2385 |
|
(new-list (ignore-errors (read (current-buffer))))) |
2386 |
|
(if new-list |
2387 |
|
new-list |
2388 |
|
;; Convert from a positional list to an alist. |
2389 |
|
(mapcar |
2390 |
|
(lambda (c) |
2391 |
|
(setcdr c |
2392 |
|
(delq nil |
2393 |
|
(gnus-mapcar |
2394 |
|
(lambda (valu symb) |
2395 |
|
(if valu |
2396 |
|
(cons symb valu))) |
2397 |
|
(cdr c) |
2398 |
|
'(agent-predicate agent-score-file agent-groups)))) |
2399 |
|
c) |
2400 |
|
old-list))))) |
2401 |
|
(list (gnus-agent-cat-make 'default 'short))))) |
2402 |
|
|
2403 |
(defun gnus-category-write () |
(defun gnus-category-write () |
2404 |
"Write the category alist." |
"Write the category alist." |
2406 |
gnus-category-group-cache nil) |
gnus-category-group-cache nil) |
2407 |
(gnus-make-directory (nnheader-concat gnus-agent-directory "lib")) |
(gnus-make-directory (nnheader-concat gnus-agent-directory "lib")) |
2408 |
(with-temp-file (nnheader-concat gnus-agent-directory "lib/categories") |
(with-temp-file (nnheader-concat gnus-agent-directory "lib/categories") |
2409 |
|
;; This prin1 is temporary. It exists so that people can revert |
2410 |
|
;; to an earlier version of gnus-agent. |
2411 |
|
(prin1 (mapcar (lambda (c) |
2412 |
|
(list (car c) |
2413 |
|
(cdr (assoc 'agent-predicate c)) |
2414 |
|
(cdr (assoc 'agent-score-file c)) |
2415 |
|
(cdr (assoc 'agent-groups c)))) |
2416 |
|
gnus-category-alist) |
2417 |
|
(current-buffer)) |
2418 |
|
(newline) |
2419 |
(prin1 gnus-category-alist (current-buffer)))) |
(prin1 gnus-category-alist (current-buffer)))) |
2420 |
|
|
2421 |
(defun gnus-category-edit-predicate (category) |
(defun gnus-category-edit-predicate (category) |
2423 |
(interactive (list (gnus-category-name))) |
(interactive (list (gnus-category-name))) |
2424 |
(let ((info (assq category gnus-category-alist))) |
(let ((info (assq category gnus-category-alist))) |
2425 |
(gnus-edit-form |
(gnus-edit-form |
2426 |
(cadr info) (format "Editing the predicate for category %s" category) |
(gnus-agent-cat-predicate info) |
2427 |
|
(format "Editing the select predicate for category %s" category) |
2428 |
`(lambda (predicate) |
`(lambda (predicate) |
2429 |
(setcar (cdr (assq ',category gnus-category-alist)) predicate) |
;; Avoid run-time execution of setf form |
2430 |
|
;; (setf (gnus-agent-cat-predicate (assq ',category gnus-category-alist)) |
2431 |
|
;; predicate) |
2432 |
|
;; use its expansion instead: |
2433 |
|
(gnus-agent-cat-set-property (assq ',category gnus-category-alist) |
2434 |
|
'agent-predicate predicate) |
2435 |
|
|
2436 |
(gnus-category-write) |
(gnus-category-write) |
2437 |
(gnus-category-list))))) |
(gnus-category-list))))) |
2438 |
|
|
2441 |
(interactive (list (gnus-category-name))) |
(interactive (list (gnus-category-name))) |
2442 |
(let ((info (assq category gnus-category-alist))) |
(let ((info (assq category gnus-category-alist))) |
2443 |
(gnus-edit-form |
(gnus-edit-form |
2444 |
(caddr info) |
(gnus-agent-cat-score-file info) |
2445 |
(format "Editing the score expression for category %s" category) |
(format "Editing the score expression for category %s" category) |
2446 |
`(lambda (groups) |
`(lambda (score-file) |
2447 |
(setcar (cddr (assq ',category gnus-category-alist)) groups) |
;; Avoid run-time execution of setf form |
2448 |
|
;; (setf (gnus-agent-cat-score-file (assq ',category gnus-category-alist)) |
2449 |
|
;; score-file) |
2450 |
|
;; use its expansion instead: |
2451 |
|
(gnus-agent-cat-set-property (assq ',category gnus-category-alist) |
2452 |
|
'agent-score-file score-file) |
2453 |
|
|
2454 |
(gnus-category-write) |
(gnus-category-write) |
2455 |
(gnus-category-list))))) |
(gnus-category-list))))) |
2456 |
|
|
2459 |
(interactive (list (gnus-category-name))) |
(interactive (list (gnus-category-name))) |
2460 |
(let ((info (assq category gnus-category-alist))) |
(let ((info (assq category gnus-category-alist))) |
2461 |
(gnus-edit-form |
(gnus-edit-form |
2462 |
(cadddr info) (format "Editing the group list for category %s" category) |
(gnus-agent-cat-groups info) |
2463 |
|
(format "Editing the group list for category %s" category) |
2464 |
`(lambda (groups) |
`(lambda (groups) |
2465 |
(setcar (nthcdr 3 (assq ',category gnus-category-alist)) groups) |
;; Avoid run-time execution of setf form |
2466 |
|
;; (setf (gnus-agent-cat-groups (assq ',category gnus-category-alist)) |
2467 |
|
;; groups) |
2468 |
|
;; use its expansion instead: |
2469 |
|
(gnus-agent-set-cat-groups (assq ',category gnus-category-alist) |
2470 |
|
groups) |
2471 |
|
|
2472 |
(gnus-category-write) |
(gnus-category-write) |
2473 |
(gnus-category-list))))) |
(gnus-category-list))))) |
2474 |
|
|
2485 |
"Copy the current category." |
"Copy the current category." |
2486 |
(interactive (list (gnus-category-name) (intern (read-string "New name: ")))) |
(interactive (list (gnus-category-name) (intern (read-string "New name: ")))) |
2487 |
(let ((info (assq category gnus-category-alist))) |
(let ((info (assq category gnus-category-alist))) |
2488 |
(push (list to (gnus-copy-sequence (cadr info)) |
(push (let ((newcat (gnus-copy-sequence info))) |
2489 |
(gnus-copy-sequence (caddr info)) nil) |
(setf (gnus-agent-cat-name newcat) to) |
2490 |
|
(setf (gnus-agent-cat-groups newcat) nil) |
2491 |
|
newcat) |
2492 |
gnus-category-alist) |
gnus-category-alist) |
2493 |
(gnus-category-write) |
(gnus-category-write) |
2494 |
(gnus-category-list))) |
(gnus-category-list))) |
2498 |
(interactive "SCategory name: ") |
(interactive "SCategory name: ") |
2499 |
(when (assq category gnus-category-alist) |
(when (assq category gnus-category-alist) |
2500 |
(error "Category %s already exists" category)) |
(error "Category %s already exists" category)) |
2501 |
(push (list category 'false nil nil) |
(push (gnus-agent-cat-make category) |
2502 |
gnus-category-alist) |
gnus-category-alist) |
2503 |
(gnus-category-write) |
(gnus-category-write) |
2504 |
(gnus-category-list)) |
(gnus-category-list)) |
2523 |
(long . gnus-agent-long-p) |
(long . gnus-agent-long-p) |
2524 |
(low . gnus-agent-low-scored-p) |
(low . gnus-agent-low-scored-p) |
2525 |
(high . gnus-agent-high-scored-p) |
(high . gnus-agent-high-scored-p) |
2526 |
|
(read . gnus-agent-read-p) |
2527 |
(true . gnus-agent-true) |
(true . gnus-agent-true) |
2528 |
(false . gnus-agent-false)) |
(false . gnus-agent-false)) |
2529 |
"Mapping from short score predicate symbols to predicate functions.") |
"Mapping from short score predicate symbols to predicate functions.") |
2555 |
"Say whether an article has a high score or not." |
"Say whether an article has a high score or not." |
2556 |
(> gnus-score gnus-agent-high-score)) |
(> gnus-score gnus-agent-high-score)) |
2557 |
|
|
2558 |
(defun gnus-category-make-function (cat) |
(defun gnus-agent-read-p () |
2559 |
"Make a function from category CAT." |
"Say whether an article is read or not." |
2560 |
`(lambda () ,(gnus-category-make-function-1 cat))) |
(gnus-member-of-range (mail-header-number gnus-headers) |
2561 |
|
(gnus-info-read (gnus-get-info gnus-newsgroup-name)))) |
2562 |
|
|
2563 |
|
(defun gnus-category-make-function (predicate) |
2564 |
|
"Make a function from PREDICATE." |
2565 |
|
(let ((func (gnus-category-make-function-1 predicate))) |
2566 |
|
(if (and (= (length func) 1) |
2567 |
|
(symbolp (car func))) |
2568 |
|
(car func) |
2569 |
|
(gnus-byte-compile `(lambda () ,func))))) |
2570 |
|
|
2571 |
(defun gnus-agent-true () |
(defun gnus-agent-true () |
2572 |
"Return t." |
"Return t." |
2576 |
"Return nil." |
"Return nil." |
2577 |
nil) |
nil) |
2578 |
|
|
2579 |
(defun gnus-category-make-function-1 (cat) |
(defun gnus-category-make-function-1 (predicate) |
2580 |
"Make a function from category CAT." |
"Make a function from PREDICATE." |
2581 |
(cond |
(cond |
2582 |
;; Functions are just returned as is. |
;; Functions are just returned as is. |
2583 |
((or (symbolp cat) |
((or (symbolp predicate) |
2584 |
(gnus-functionp cat)) |
(functionp predicate)) |
2585 |
`(,(or (cdr (assq cat gnus-category-predicate-alist)) |
`(,(or (cdr (assq predicate gnus-category-predicate-alist)) |
2586 |
cat))) |
predicate))) |
2587 |
;; More complex category. |
;; More complex predicate. |
2588 |
((consp cat) |
((consp predicate) |
2589 |
`(,(cond |
`(,(cond |
2590 |
((memq (car cat) '(& and)) |
((memq (car predicate) '(& and)) |
2591 |
'and) |
'and) |
2592 |
((memq (car cat) '(| or)) |
((memq (car predicate) '(| or)) |
2593 |
'or) |
'or) |
2594 |
((memq (car cat) gnus-category-not) |
((memq (car predicate) gnus-category-not) |
2595 |
'not)) |
'not)) |
2596 |
,@(mapcar 'gnus-category-make-function-1 (cdr cat)))) |
,@(mapcar 'gnus-category-make-function-1 (cdr predicate)))) |
2597 |
(t |
(t |
2598 |
(error "Unknown category type: %s" cat)))) |
(error "Unknown predicate type: %s" predicate)))) |
2599 |
|
|
2600 |
(defun gnus-get-predicate (predicate) |
(defun gnus-get-predicate (predicate) |
2601 |
"Return the predicate for CATEGORY." |
"Return the function implementing PREDICATE." |
2602 |
(or (cdr (assoc predicate gnus-category-predicate-cache)) |
(or (cdr (assoc predicate gnus-category-predicate-cache)) |
2603 |
(cdar (push (cons predicate |
(let ((func (gnus-category-make-function predicate))) |
2604 |
(gnus-category-make-function predicate)) |
(setq gnus-category-predicate-cache |
2605 |
gnus-category-predicate-cache)))) |
(nconc gnus-category-predicate-cache |
2606 |
|
(list (cons predicate func)))) |
2607 |
|
func))) |
2608 |
|
|
2609 |
|
(defun gnus-predicate-implies-unread (predicate) |
2610 |
|
"Say whether PREDICATE implies unread articles only. |
2611 |
|
It is okay to miss some cases, but there must be no false positives. |
2612 |
|
That is, if this predicate returns true, then indeed the predicate must |
2613 |
|
return only unread articles." |
2614 |
|
(eq t (gnus-function-implies-unread-1 |
2615 |
|
(gnus-category-make-function-1 predicate)))) |
2616 |
|
|
2617 |
|
(defun gnus-function-implies-unread-1 (function) |
2618 |
|
"Recursively evaluate a predicate function to determine whether it can select |
2619 |
|
any read articles. Returns t if the function is known to never |
2620 |
|
return read articles, nil when it is known to always return read |
2621 |
|
articles, and t_nil when the function may return both read and unread |
2622 |
|
articles." |
2623 |
|
(let ((func (car function)) |
2624 |
|
(args (mapcar 'gnus-function-implies-unread-1 (cdr function)))) |
2625 |
|
(cond ((eq func 'and) |
2626 |
|
(cond ((memq t args) ; if any argument returns only unread articles |
2627 |
|
;; then that argument constrains the result to only unread articles. |
2628 |
|
t) |
2629 |
|
((memq 't_nil args) ; if any argument is indeterminate |
2630 |
|
;; then the result is indeterminate |
2631 |
|
't_nil))) |
2632 |
|
((eq func 'or) |
2633 |
|
(cond ((memq nil args) ; if any argument returns read articles |
2634 |
|
;; then that argument ensures that the results includes read articles. |
2635 |
|
nil) |
2636 |
|
((memq 't_nil args) ; if any argument is indeterminate |
2637 |
|
;; then that argument ensures that the results are indeterminate |
2638 |
|
't_nil) |
2639 |
|
(t ; if all arguments return only unread articles |
2640 |
|
;; then the result returns only unread articles |
2641 |
|
t))) |
2642 |
|
((eq func 'not) |
2643 |
|
(cond ((eq (car args) 't_nil) ; if the argument is indeterminate |
2644 |
|
; then the result is indeterminate |
2645 |
|
(car args)) |
2646 |
|
(t ; otherwise |
2647 |
|
; toggle the result to be the opposite of the argument |
2648 |
|
(not (car args))))) |
2649 |
|
((eq func 'gnus-agent-read-p) |
2650 |
|
nil) ; The read predicate NEVER returns unread articles |
2651 |
|
((eq func 'gnus-agent-false) |
2652 |
|
t) ; The false predicate returns t as the empty set excludes all read articles |
2653 |
|
((eq func 'gnus-agent-true) |
2654 |
|
nil) ; The true predicate ALWAYS returns read articles |
2655 |
|
((catch 'found-match |
2656 |
|
(let ((alist gnus-category-predicate-alist)) |
2657 |
|
(while alist |
2658 |
|
(if (eq func (cdar alist)) |
2659 |
|
(throw 'found-match t) |
2660 |
|
(setq alist (cdr alist)))))) |
2661 |
|
't_nil) ; All other predicates return read and unread articles |
2662 |
|
(t |
2663 |
|
(error "Unknown predicate function: %s" function))))) |
2664 |
|
|
2665 |
(defun gnus-group-category (group) |
(defun gnus-group-category (group) |
2666 |
"Return the category GROUP belongs to." |
"Return the category GROUP belongs to." |
2669 |
(let ((cs gnus-category-alist) |
(let ((cs gnus-category-alist) |
2670 |
groups cat) |
groups cat) |
2671 |
(while (setq cat (pop cs)) |
(while (setq cat (pop cs)) |
2672 |
(setq groups (cadddr cat)) |
(setq groups (gnus-agent-cat-groups cat)) |
2673 |
(while groups |
(while groups |
2674 |
(gnus-sethash (pop groups) cat gnus-category-group-cache))))) |
(gnus-sethash (pop groups) cat gnus-category-group-cache))))) |
2675 |
(or (gnus-gethash group gnus-category-group-cache) |
(or (gnus-gethash group gnus-category-group-cache) |
2676 |
(assq 'default gnus-category-alist))) |
(assq 'default gnus-category-alist))) |
2677 |
|
|
2678 |
(defun gnus-agent-expire () |
(defun gnus-agent-expire-group (group &optional articles force) |
2679 |
"Expire all old articles." |
"Expire all old articles in GROUP. |
2680 |
|
If you want to force expiring of certain articles, this function can |
2681 |
|
take ARTICLES, and FORCE parameters as well. |
2682 |
|
|
2683 |
|
The articles on which the expiration process runs are selected as follows: |
2684 |
|
if ARTICLES is null, all read and unmarked articles. |
2685 |
|
if ARTICLES is t, all articles. |
2686 |
|
if ARTICLES is a list, just those articles. |
2687 |
|
FORCE is equivalent to setting the expiration predicates to true." |
2688 |
|
(interactive |
2689 |
|
(list (let ((def (or (gnus-group-group-name) |
2690 |
|
gnus-newsgroup-name))) |
2691 |
|
(let ((select (read-string (if def |
2692 |
|
(concat "Group Name (" |
2693 |
|
def "): ") |
2694 |
|
"Group Name: ")))) |
2695 |
|
(if (and (equal "" select) |
2696 |
|
def) |
2697 |
|
def |
2698 |
|
select))))) |
2699 |
|
|
2700 |
|
(if (not group) |
2701 |
|
(gnus-agent-expire articles group force) |
2702 |
|
(let ( ;; Bind gnus-agent-expire-stats to enable tracking of |
2703 |
|
;; expiration statistics of this single group |
2704 |
|
(gnus-agent-expire-stats (list 0 0 0.0))) |
2705 |
|
(if (or (not (eq articles t)) |
2706 |
|
(yes-or-no-p |
2707 |
|
(concat "Are you sure that you want to " |
2708 |
|
"expire all articles in " group "."))) |
2709 |
|
(let ((gnus-command-method (gnus-find-method-for-group group)) |
2710 |
|
(overview (gnus-get-buffer-create " *expire overview*")) |
2711 |
|
orig) |
2712 |
|
(unwind-protect |
2713 |
|
(let ((active-file (gnus-agent-lib-file "active"))) |
2714 |
|
(when (file-exists-p active-file) |
2715 |
|
(with-temp-buffer |
2716 |
|
(nnheader-insert-file-contents active-file) |
2717 |
|
(gnus-active-to-gnus-format |
2718 |
|
gnus-command-method |
2719 |
|
(setq orig (gnus-make-hashtable |
2720 |
|
(count-lines (point-min) (point-max)))))) |
2721 |
|
(save-excursion |
2722 |
|
(gnus-agent-expire-group-1 |
2723 |
|
group overview (gnus-gethash-safe group orig) |
2724 |
|
articles force)))) |
2725 |
|
(kill-buffer overview)))) |
2726 |
|
(gnus-message 4 (gnus-agent-expire-done-message))))) |
2727 |
|
|
2728 |
|
(defun gnus-agent-expire-group-1 (group overview active articles force) |
2729 |
|
;; Internal function - requires caller to have set |
2730 |
|
;; gnus-command-method, initialized overview buffer, and to have |
2731 |
|
;; provided a non-nil active |
2732 |
|
|
2733 |
|
(let ((dir (gnus-agent-group-pathname group))) |
2734 |
|
(when (boundp 'gnus-agent-expire-current-dirs) |
2735 |
|
(set 'gnus-agent-expire-current-dirs |
2736 |
|
(cons dir |
2737 |
|
(symbol-value 'gnus-agent-expire-current-dirs)))) |
2738 |
|
|
2739 |
|
(if (and (not force) |
2740 |
|
(eq 'DISABLE (gnus-agent-find-parameter group |
2741 |
|
'agent-enable-expiration))) |
2742 |
|
(gnus-message 5 "Expiry skipping over %s" group) |
2743 |
|
(gnus-message 5 "Expiring articles in %s" group) |
2744 |
|
(gnus-agent-load-alist group) |
2745 |
|
(let* ((stats (if (boundp 'gnus-agent-expire-stats) |
2746 |
|
;; Use the list provided by my caller |
2747 |
|
(symbol-value 'gnus-agent-expire-stats) |
2748 |
|
;; otherwise use my own temporary list |
2749 |
|
(list 0 0 0.0))) |
2750 |
|
(info (gnus-get-info group)) |
2751 |
|
(alist gnus-agent-article-alist) |
2752 |
|
(day (- (time-to-days (current-time)) |
2753 |
|
(gnus-agent-find-parameter group 'agent-days-until-old))) |
2754 |
|
(specials (if (and alist |
2755 |
|
(not force)) |
2756 |
|
;; This could be a bit of a problem. I need to |
2757 |
|
;; keep the last article to avoid refetching |
2758 |
|
;; headers when using nntp in the backend. At |
2759 |
|
;; the same time, if someone uses a backend |
2760 |
|
;; that supports article moving then I may have |
2761 |
|
;; to remove the last article to complete the |
2762 |
|
;; move. Right now, I'm going to assume that |
2763 |
|
;; FORCE overrides specials. |
2764 |
|
(list (caar (last alist))))) |
2765 |
|
(unreads ;; Articles that are excluded from the |
2766 |
|
;; expiration process |
2767 |
|
(cond (gnus-agent-expire-all |
2768 |
|
;; All articles are marked read by global decree |
2769 |
|
nil) |
2770 |
|
((eq articles t) |
2771 |
|
;; All articles are marked read by function |
2772 |
|
;; parameter |
2773 |
|
nil) |
2774 |
|
((not articles) |
2775 |
|
;; Unread articles are marked protected from |
2776 |
|
;; expiration Don't call |
2777 |
|
;; gnus-list-of-unread-articles as it returns |
2778 |
|
;; articles that have not been fetched into the |
2779 |
|
;; agent. |
2780 |
|
(ignore-errors |
2781 |
|
(gnus-agent-unread-articles group))) |
2782 |
|
(t |
2783 |
|
;; All articles EXCEPT those named by the caller |
2784 |
|
;; are protected from expiration |
2785 |
|
(gnus-sorted-difference |
2786 |
|
(gnus-uncompress-range |
2787 |
|
(cons (caar alist) |
2788 |
|
(caar (last alist)))) |
2789 |
|
(sort articles '<))))) |
2790 |
|
(marked ;; More articles that are excluded from the |
2791 |
|
;; expiration process |
2792 |
|
(cond (gnus-agent-expire-all |
2793 |
|
;; All articles are unmarked by global decree |
2794 |
|
nil) |
2795 |
|
((eq articles t) |
2796 |
|
;; All articles are unmarked by function |
2797 |
|
;; parameter |
2798 |
|
nil) |
2799 |
|
(articles |
2800 |
|
;; All articles may as well be unmarked as the |
2801 |
|
;; unreads list already names the articles we are |
2802 |
|
;; going to keep |
2803 |
|
nil) |
2804 |
|
(t |
2805 |
|
;; Ticked and/or dormant articles are excluded |
2806 |
|
;; from expiration |
2807 |
|
(nconc |
2808 |
|
(gnus-uncompress-range |
2809 |
|
(cdr (assq 'tick (gnus-info-marks info)))) |
2810 |
|
(gnus-uncompress-range |
2811 |
|
(cdr (assq 'dormant |
2812 |
|
(gnus-info-marks info)))))))) |
2813 |
|
(nov-file (concat dir ".overview")) |
2814 |
|
(cnt 0) |
2815 |
|
(completed -1) |
2816 |
|
dlist |
2817 |
|
type) |
2818 |
|
|
2819 |
|
;; The normal article alist contains elements that look like |
2820 |
|
;; (article# . fetch_date) I need to combine other |
2821 |
|
;; information with this list. For example, a flag indicating |
2822 |
|
;; that a particular article MUST BE KEPT. To do this, I'm |
2823 |
|
;; going to transform the elements to look like (article# |
2824 |
|
;; fetch_date keep_flag NOV_entry_marker) Later, I'll reverse |
2825 |
|
;; the process to generate the expired article alist. |
2826 |
|
|
2827 |
|
;; Convert the alist elements to (article# fetch_date nil |
2828 |
|
;; nil). |
2829 |
|
(setq dlist (mapcar (lambda (e) |
2830 |
|
(list (car e) (cdr e) nil nil)) alist)) |
2831 |
|
|
2832 |
|
;; Convert the keep lists to elements that look like (article# |
2833 |
|
;; nil keep_flag nil) then append it to the expanded dlist |
2834 |
|
;; These statements are sorted by ascending precidence of the |
2835 |
|
;; keep_flag. |
2836 |
|
(setq dlist (nconc dlist |
2837 |
|
(mapcar (lambda (e) |
2838 |
|
(list e nil 'unread nil)) |
2839 |
|
unreads))) |
2840 |
|
(setq dlist (nconc dlist |
2841 |
|
(mapcar (lambda (e) |
2842 |
|
(list e nil 'marked nil)) |
2843 |
|
marked))) |
2844 |
|
(setq dlist (nconc dlist |
2845 |
|
(mapcar (lambda (e) |
2846 |
|
(list e nil 'special nil)) |
2847 |
|
specials))) |
2848 |
|
|
2849 |
|
(set-buffer overview) |
2850 |
|
(erase-buffer) |
2851 |
|
(buffer-disable-undo) |
2852 |
|
(when (file-exists-p nov-file) |
2853 |
|
(gnus-message 7 "gnus-agent-expire: Loading overview...") |
2854 |
|
(nnheader-insert-file-contents nov-file) |
2855 |
|
(goto-char (point-min)) |
2856 |
|
|
2857 |
|
(let (p) |
2858 |
|
(while (< (setq p (point)) (point-max)) |
2859 |
|
(condition-case nil |
2860 |
|
;; If I successfully read an integer (the plus zero |
2861 |
|
;; ensures a numeric type), prepend a marker entry |
2862 |
|
;; to the list |
2863 |
|
(push (list (+ 0 (read (current-buffer))) nil nil |
2864 |
|
(set-marker (make-marker) p)) |
2865 |
|
dlist) |
2866 |
|
(error |
2867 |
|
(gnus-message 1 "gnus-agent-expire: read error \ |
2868 |
|
occurred when reading expression at %s in %s. Skipping to next \ |
2869 |
|
line." (point) nov-file))) |
2870 |
|
;; Whether I succeeded, or failed, it doesn't matter. |
2871 |
|
;; Move to the next line then try again. |
2872 |
|
(forward-line 1))) |
2873 |
|
|
2874 |
|
(gnus-message |
2875 |
|
7 "gnus-agent-expire: Loading overview... Done")) |
2876 |
|
(set-buffer-modified-p nil) |
2877 |
|
|
2878 |
|
;; At this point, all of the information is in dlist. The |
2879 |
|
;; only problem is that much of it is spread across multiple |
2880 |
|
;; entries. Sort then MERGE!! |
2881 |
|
(gnus-message 7 "gnus-agent-expire: Sorting entries... ") |
2882 |
|
;; If two entries have the same article-number then sort by |
2883 |
|
;; ascending keep_flag. |
2884 |
|
(let ((special 0) |
2885 |
|
(marked 1) |
2886 |
|
(unread 2)) |
2887 |
|
(setq dlist |
2888 |
|
(sort dlist |
2889 |
|
(lambda (a b) |
2890 |
|
(cond ((< (nth 0 a) (nth 0 b)) |
2891 |
|
t) |
2892 |
|
((> (nth 0 a) (nth 0 b)) |
2893 |
|
nil) |
2894 |
|
(t |
2895 |
|
(let ((a (or (symbol-value (nth 2 a)) |
2896 |
|
3)) |
2897 |
|
(b (or (symbol-value (nth 2 b)) |
2898 |
|
3))) |
2899 |
|
(<= a b)))))))) |
2900 |
|
(gnus-message 7 "gnus-agent-expire: Sorting entries... Done") |
2901 |
|
(gnus-message 7 "gnus-agent-expire: Merging entries... ") |
2902 |
|
(let ((dlist dlist)) |
2903 |
|
(while (cdr dlist) ; I'm not at the end-of-list |
2904 |
|
(if (eq (caar dlist) (caadr dlist)) |
2905 |
|
(let ((first (cdr (car dlist))) |
2906 |
|
(secnd (cdr (cadr dlist)))) |
2907 |
|
(setcar first (or (car first) |
2908 |
|
(car secnd))) ; fetch_date |
2909 |
|
(setq first (cdr first) |
2910 |
|
secnd (cdr secnd)) |
2911 |
|
(setcar first (or (car first) |
2912 |
|
(car secnd))) ; Keep_flag |
2913 |
|
(setq first (cdr first) |
2914 |
|
secnd (cdr secnd)) |
2915 |
|
(setcar first (or (car first) |
2916 |
|
(car secnd))) ; NOV_entry_marker |
2917 |
|
|
2918 |
|
(setcdr dlist (cddr dlist))) |
2919 |
|
(setq dlist (cdr dlist))))) |
2920 |
|
(gnus-message 7 "gnus-agent-expire: Merging entries... Done") |
2921 |
|
|
2922 |
|
(let* ((len (float (length dlist))) |
2923 |
|
(alist (list nil)) |
2924 |
|
(tail-alist alist)) |
2925 |
|
(while dlist |
2926 |
|
(let ((new-completed (truncate (* 100.0 |
2927 |
|
(/ (setq cnt (1+ cnt)) |
2928 |
|
len)))) |
2929 |
|
message-log-max) |
2930 |
|
(when (> new-completed completed) |
2931 |
|
(setq completed new-completed) |
2932 |
|
(gnus-message 7 "%3d%% completed..." completed))) |
2933 |
|
(let* ((entry (car dlist)) |
2934 |
|
(article-number (nth 0 entry)) |
2935 |
|
(fetch-date (nth 1 entry)) |
2936 |
|
(keep (nth 2 entry)) |
2937 |
|
(marker (nth 3 entry))) |
2938 |
|
|
2939 |
|
(cond |
2940 |
|
;; Kept articles are unread, marked, or special. |
2941 |
|
(keep |
2942 |
|
(gnus-agent-message 10 |
2943 |
|
"gnus-agent-expire: %s:%d: Kept %s article%s." |
2944 |
|
group article-number keep (if fetch-date " and file" "")) |
2945 |
|
(when fetch-date |
2946 |
|
(unless (file-exists-p |
2947 |
|
(concat dir (number-to-string |
2948 |
|
article-number))) |
2949 |
|
(setf (nth 1 entry) nil) |
2950 |
|
(gnus-agent-message 3 "gnus-agent-expire cleared \ |
2951 |
|
download flag on %s:%d as the cached article file is missing." |
2952 |
|
group (caar dlist))) |
2953 |
|
(unless marker |
2954 |
|
(gnus-message 1 "gnus-agent-expire detected a \ |
2955 |
|
missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) |
2956 |
|
(gnus-agent-append-to-list |
2957 |
|
tail-alist |
2958 |
|
(cons article-number fetch-date))) |
2959 |
|
|
2960 |
|
;; The following articles are READ, UNMARKED, and |
2961 |
|
;; ORDINARY. See if they can be EXPIRED!!! |
2962 |
|
((setq type |
2963 |
|
(cond |
2964 |
|
((not (integerp fetch-date)) |
2965 |
|
'read) ;; never fetched article (may expire |
2966 |
|
;; right now) |
2967 |
|
((not (file-exists-p |
2968 |
|
(concat dir (number-to-string |
2969 |
|
article-number)))) |
2970 |
|
(setf (nth 1 entry) nil) |
2971 |
|
'externally-expired) ;; Can't find the cached |
2972 |
|
;; article. Handle case |
2973 |
|
;; as though this article |
2974 |
|
;; was never fetched. |
2975 |
|
|
2976 |
|
;; We now have the arrival day, so we see |
2977 |
|
;; whether it's old enough to be expired. |
2978 |
|
((< fetch-date day) |
2979 |
|
'expired) |
2980 |
|
(force |
2981 |
|
'forced))) |
2982 |
|
|
2983 |
|
;; I found some reason to expire this entry. |
2984 |
|
|
2985 |
|
(let ((actions nil)) |
2986 |
|
(when (memq type '(forced expired)) |
2987 |
|
(ignore-errors ; Just being paranoid. |
2988 |
|
(let ((file-name (concat dir (number-to-string |
2989 |
|
article-number)))) |
2990 |
|
(incf (nth 2 stats) (nth 7 (file-attributes file-name))) |
2991 |
|
(incf (nth 1 stats)) |
2992 |
|
(delete-file file-name)) |
2993 |
|
(push "expired cached article" actions)) |
2994 |
|
(setf (nth 1 entry) nil) |
2995 |
|
) |
2996 |
|
|
2997 |
|
(when marker |
2998 |
|
(push "NOV entry removed" actions) |
2999 |
|
(goto-char marker) |
3000 |
|
|
3001 |
|
(incf (nth 0 stats)) |
3002 |
|
|
3003 |
|
(let ((from (gnus-point-at-bol)) |
3004 |
|
(to (progn (forward-line 1) (point)))) |
3005 |
|
(incf (nth 2 stats) (- to from)) |
3006 |
|
(delete-region from to))) |
3007 |
|
|
3008 |
|
;; If considering all articles is set, I can only |
3009 |
|
;; expire article IDs that are no longer in the |
3010 |
|
;; active range (That is, articles that preceed the |
3011 |
|
;; first article in the new alist). |
3012 |
|
(if (and gnus-agent-consider-all-articles |
3013 |
|
(>= article-number (car active))) |
3014 |
|
;; I have to keep this ID in the alist |
3015 |
|
(gnus-agent-append-to-list |
3016 |
|
tail-alist (cons article-number fetch-date)) |
3017 |
|
(push (format "Removed %s article number from \ |
3018 |
|
article alist" type) actions)) |
3019 |
|
|
3020 |
|
(when actions |
3021 |
|
(gnus-agent-message 8 "gnus-agent-expire: %s:%d: %s" |
3022 |
|
group article-number |
3023 |
|
(mapconcat 'identity actions ", "))))) |
3024 |
|
(t |
3025 |
|
(gnus-agent-message |
3026 |
|
10 "gnus-agent-expire: %s:%d: Article kept as \ |
3027 |
|
expiration tests failed." group article-number) |
3028 |
|
(gnus-agent-append-to-list |
3029 |
|
tail-alist (cons article-number fetch-date))) |
3030 |
|
) |
3031 |
|
|
3032 |
|
;; Clean up markers as I want to recycle this buffer |
3033 |
|
;; over several groups. |
3034 |
|
(when marker |
3035 |
|
(set-marker marker nil)) |
3036 |
|
|
3037 |
|
(setq dlist (cdr dlist)))) |
3038 |
|
|
3039 |
|
(setq alist (cdr alist)) |
3040 |
|
|
3041 |
|
(let ((inhibit-quit t)) |
3042 |
|
(unless (equal alist gnus-agent-article-alist) |
3043 |
|
(setq gnus-agent-article-alist alist) |
3044 |
|
(gnus-agent-save-alist group)) |
3045 |
|
|
3046 |
|
(when (buffer-modified-p) |
3047 |
|
(let ((coding-system-for-write |
3048 |
|
gnus-agent-file-coding-system)) |
3049 |
|
(gnus-make-directory dir) |
3050 |
|
(write-region (point-min) (point-max) nov-file nil |
3051 |
|
'silent) |
3052 |
|
;; clear the modified flag as that I'm not confused by |
3053 |
|
;; its status on the next pass through this routine. |
3054 |
|
(set-buffer-modified-p nil))) |
3055 |
|
|
3056 |
|
(when (eq articles t) |
3057 |
|
(gnus-summary-update-info)))))))) |
3058 |
|
|
3059 |
|
(defun gnus-agent-expire (&optional articles group force) |
3060 |
|
"Expire all old articles. |
3061 |
|
If you want to force expiring of certain articles, this function can |
3062 |
|
take ARTICLES, GROUP and FORCE parameters as well. |
3063 |
|
|
3064 |
|
The articles on which the expiration process runs are selected as follows: |
3065 |
|
if ARTICLES is null, all read and unmarked articles. |
3066 |
|
if ARTICLES is t, all articles. |
3067 |
|
if ARTICLES is a list, just those articles. |
3068 |
|
Setting GROUP will limit expiration to that group. |
3069 |
|
FORCE is equivalent to setting the expiration predicates to true." |
3070 |
(interactive) |
(interactive) |
3071 |
(let ((methods gnus-agent-covered-methods) |
|
3072 |
(day (- (time-to-days (current-time)) gnus-agent-expire-days)) |
(if group |
3073 |
gnus-command-method sym group articles |
(gnus-agent-expire-group group articles force) |
3074 |
history overview file histories elem art nov-file low info |
(if (or (not (eq articles t)) |
3075 |
unreads marked article orig lowest highest) |
(yes-or-no-p "Are you sure that you want to expire all \ |
3076 |
(save-excursion |
articles in every agentized group.")) |
3077 |
(setq overview (gnus-get-buffer-create " *expire overview*")) |
(let ((methods (gnus-agent-covered-methods)) |
3078 |
(while (setq gnus-command-method (pop methods)) |
;; Bind gnus-agent-expire-current-dirs to enable tracking |
3079 |
(when (file-exists-p (gnus-agent-lib-file "active")) |
;; of agent directories. |
3080 |
(with-temp-buffer |
(gnus-agent-expire-current-dirs nil) |
3081 |
(nnheader-insert-file-contents (gnus-agent-lib-file "active")) |
;; Bind gnus-agent-expire-stats to enable tracking of |
3082 |
(gnus-active-to-gnus-format |
;; expiration statistics across all groups |
3083 |
gnus-command-method |
(gnus-agent-expire-stats (list 0 0 0.0)) |
3084 |
(setq orig (gnus-make-hashtable |
gnus-command-method overview orig) |
3085 |
(count-lines (point-min) (point-max)))))) |
(setq overview (gnus-get-buffer-create " *expire overview*")) |
3086 |
(let ((expiry-hashtb (gnus-make-hashtable 1023))) |
(unwind-protect |
3087 |
(gnus-agent-open-history) |
(while (setq gnus-command-method (pop methods)) |
3088 |
(set-buffer |
(let ((active-file (gnus-agent-lib-file "active"))) |
3089 |
(setq gnus-agent-current-history |
(when (file-exists-p active-file) |
3090 |
(setq history (gnus-agent-history-buffer)))) |
(with-temp-buffer |
3091 |
(goto-char (point-min)) |
(nnheader-insert-file-contents active-file) |
3092 |
(when (> (buffer-size) 1) |
(gnus-active-to-gnus-format |
3093 |
(goto-char (point-min)) |
gnus-command-method |
3094 |
(while (not (eobp)) |
(setq orig (gnus-make-hashtable |
3095 |
(skip-chars-forward "^\t") |
(count-lines (point-min) (point-max)))))) |
3096 |
(if (> (read (current-buffer)) day) |
(dolist (expiring-group (gnus-groups-from-server |
3097 |
;; New article; we don't expire it. |
gnus-command-method)) |
3098 |
(forward-line 1) |
(let* ((active |
3099 |
;; Old article. Schedule it for possible nuking. |
(gnus-gethash-safe expiring-group orig))) |
3100 |
(while (not (eolp)) |
|
3101 |
(setq sym (let ((obarray expiry-hashtb) s) |
(when active |
3102 |
(setq s (read (current-buffer))) |
(save-excursion |
3103 |
(if (stringp s) (intern s) s))) |
(gnus-agent-expire-group-1 |
3104 |
(if (boundp sym) |
expiring-group overview active articles force)))))))) |
3105 |
(set sym (cons (cons (read (current-buffer)) (point)) |
(kill-buffer overview)) |
3106 |
(symbol-value sym))) |
(gnus-agent-expire-unagentized-dirs) |
3107 |
(set sym (list (cons (read (current-buffer)) (point))))) |
(gnus-message 4 (gnus-agent-expire-done-message)))))) |
3108 |
(skip-chars-forward " ")) |
|
3109 |
(forward-line 1))) |
(defun gnus-agent-expire-done-message () |
3110 |
;; We now have all articles that can possibly be expired. |
(if (and (> gnus-verbose 4) |
3111 |
(mapatoms |
(boundp 'gnus-agent-expire-stats)) |
3112 |
(lambda (sym) |
(let* ((stats (symbol-value 'gnus-agent-expire-stats)) |
3113 |
(setq group (symbol-name sym) |
(size (nth 2 stats)) |
3114 |
articles (sort (symbol-value sym) 'car-less-than-car) |
(units '(B KB MB GB))) |
3115 |
low (car (gnus-active group)) |
(while (and (> size 1024.0) |
3116 |
info (gnus-get-info group) |
(cdr units)) |
3117 |
unreads (ignore-errors |
(setq size (/ size 1024.0) |
3118 |
(gnus-list-of-unread-articles group)) |
units (cdr units))) |
3119 |
marked (nconc |
|
3120 |
(gnus-uncompress-range |
(format "Expiry recovered %d NOV entries, deleted %d files,\ |
3121 |
(cdr (assq 'tick (gnus-info-marks info)))) |
and freed %f %s." |
3122 |
(gnus-uncompress-range |
(nth 0 stats) |
3123 |
(cdr (assq 'dormant |
(nth 1 stats) |
3124 |
(gnus-info-marks info))))) |
size (car units))) |
3125 |
nov-file (gnus-agent-article-name ".overview" group) |
"Expiry...done")) |
3126 |
lowest nil |
|
3127 |
highest nil) |
(defun gnus-agent-expire-unagentized-dirs () |
3128 |
(gnus-agent-load-alist group) |
(when (and gnus-agent-expire-unagentized-dirs |
3129 |
(gnus-message 5 "Expiring articles in %s" group) |
(boundp 'gnus-agent-expire-current-dirs)) |
3130 |
(set-buffer overview) |
(let* ((keep (gnus-make-hashtable)) |
3131 |
(erase-buffer) |
;; Formally bind gnus-agent-expire-current-dirs so that the |
3132 |
(when (file-exists-p nov-file) |
;; compiler will not complain about free references. |
3133 |
(nnheader-insert-file-contents nov-file)) |
(gnus-agent-expire-current-dirs |
3134 |
(goto-char (point-min)) |
(symbol-value 'gnus-agent-expire-current-dirs)) |
3135 |
(setq article 0) |
dir) |
3136 |
(while (setq elem (pop articles)) |
|
3137 |
(setq article (car elem)) |
(gnus-sethash gnus-agent-directory t keep) |
3138 |
(when (or (null low) |
(while gnus-agent-expire-current-dirs |
3139 |
(< article low) |
(setq dir (pop gnus-agent-expire-current-dirs)) |
3140 |
gnus-agent-expire-all |
(when (and (stringp dir) |
3141 |
(and (not (memq article unreads)) |
(file-directory-p dir)) |
3142 |
(not (memq article marked)))) |
(while (not (gnus-gethash dir keep)) |
3143 |
;; Find and nuke the NOV line. |
(gnus-sethash dir t keep) |
3144 |
(while (and (not (eobp)) |
(setq dir (file-name-directory (directory-file-name dir)))))) |
3145 |
(or (not (numberp |
|
3146 |
(setq art (read (current-buffer))))) |
(let* (to-remove |
3147 |
(< art article))) |
checker |
3148 |
(if (and (numberp art) |
(checker |
3149 |
(file-exists-p |
(function |
3150 |
(gnus-agent-article-name |
(lambda (d) |
3151 |
(number-to-string art) group))) |
"Given a directory, check it and its subdirectories for |
3152 |
(progn |
membership in the keep hash. If it isn't found, add |
3153 |
(unless lowest |
it to to-remove." |
3154 |
(setq lowest art)) |
(let ((files (directory-files d)) |
3155 |
(setq highest art) |
file) |
3156 |
(forward-line 1)) |
(while (setq file (pop files)) |
3157 |
;; Remove old NOV lines that have no articles. |
(cond ((equal file ".") ; Ignore self |
3158 |
(gnus-delete-line))) |
nil) |
3159 |
(if (or (eobp) |
((equal file "..") ; Ignore parent |
3160 |
(/= art article)) |
nil) |
3161 |
(beginning-of-line) |
((equal file ".overview") |
3162 |
(gnus-delete-line)) |
;; Directory must contain .overview to be |
3163 |
;; Nuke the article. |
;; agent's cache of a group. |
3164 |
(when (file-exists-p |
(let ((d (file-name-as-directory d)) |
3165 |
(setq file (gnus-agent-article-name |
r) |
3166 |
(number-to-string article) |
;; Search ancestor's for last directory NOT |
3167 |
group))) |
;; found in keep hash. |
3168 |
(delete-file file)) |
(while (not (gnus-gethash |
3169 |
;; Schedule the history line for nuking. |
(setq d (file-name-directory d)) keep)) |
3170 |
(push (cdr elem) histories))) |
(setq r d |
3171 |
(gnus-make-directory (file-name-directory nov-file)) |
d (directory-file-name d))) |
3172 |
(let ((coding-system-for-write |
;; if ANY ancestor was NOT in keep hash and |
3173 |
gnus-agent-file-coding-system)) |
;; it it's already in to-remove, add it to |
3174 |
(write-region (point-min) (point-max) nov-file nil 'silent)) |
;; to-remove. |
3175 |
;; Delete the unwanted entries in the alist. |
(if (and r |
3176 |
(setq gnus-agent-article-alist |
(not (member r to-remove))) |
3177 |
(sort gnus-agent-article-alist 'car-less-than-car)) |
(push r to-remove)))) |
3178 |
(let* ((alist gnus-agent-article-alist) |
((file-directory-p (setq file (nnheader-concat d file))) |
3179 |
(prev (cons nil alist)) |
(funcall checker file))))))))) |
3180 |
(first prev) |
(funcall checker (expand-file-name gnus-agent-directory)) |
3181 |
expired) |
|
3182 |
(while (and alist |
(when (and to-remove |
3183 |
(<= (caar alist) article)) |
(or gnus-expert-user |
3184 |
(if (or (not (cdar alist)) |
(gnus-y-or-n-p |
3185 |
(not (file-exists-p |
"gnus-agent-expire has identified local directories that are\ |
3186 |
(gnus-agent-article-name |
not currently required by any agentized group. Do you wish to consider\ |
3187 |
(number-to-string |
deleting them?"))) |
3188 |
(caar alist)) |
(while to-remove |
3189 |
group)))) |
(let ((dir (pop to-remove))) |
3190 |
(progn |
(if (gnus-y-or-n-p (format "Delete %s? " dir)) |
3191 |
(push (caar alist) expired) |
(let* (delete-recursive |
3192 |
(setcdr prev (setq alist (cdr alist)))) |
(delete-recursive |
3193 |
(setq prev alist |
(function |
3194 |
alist (cdr alist)))) |
(lambda (f-or-d) |
3195 |
(setq gnus-agent-article-alist (cdr first)) |
(ignore-errors |
3196 |
(gnus-agent-save-alist group) |
(if (file-directory-p f-or-d) |
3197 |
;; Mark all articles up to the first article |
(condition-case nil |
3198 |
;; in `gnus-article-alist' as read. |
(delete-directory f-or-d) |
3199 |
(when (and info (caar gnus-agent-article-alist)) |
(file-error |
3200 |
(setcar (nthcdr 2 info) |
(mapcar (lambda (f) |
3201 |
(gnus-range-add |
(or (member f '("." "..")) |
3202 |
(nth 2 info) |
(funcall delete-recursive |
3203 |
(cons 1 (- (caar gnus-agent-article-alist) 1))))) |
(nnheader-concat |
3204 |
;; Maybe everything has been expired from `gnus-article-alist' |
f-or-d f)))) |
3205 |
;; and so the above marking as read could not be conducted, |
(directory-files f-or-d)) |
3206 |
;; or there are expired article within the range of the alist. |
(delete-directory f-or-d))) |
3207 |
(when (and info |
(delete-file f-or-d))))))) |
3208 |
expired |
(funcall delete-recursive dir)))))))))) |
|
(or (not (caar gnus-agent-article-alist)) |
|
|
(> (car expired) |
|
|
(caar gnus-agent-article-alist)))) |
|
|
(setcar (nthcdr 2 info) |
|
|
(gnus-add-to-range |
|
|
(nth 2 info) |
|
|
(nreverse expired)))) |
|
|
(gnus-dribble-enter |
|
|
(concat "(gnus-group-set-info '" |
|
|
(gnus-prin1-to-string info) |
|
|
")"))) |
|
|
(when lowest |
|
|
(if (gnus-gethash group orig) |
|
|
(setcar (gnus-gethash group orig) lowest) |
|
|
(gnus-sethash group (cons lowest highest) orig)))) |
|
|
expiry-hashtb) |
|
|
(set-buffer history) |
|
|
(setq histories (nreverse (sort histories '<))) |
|
|
(while histories |
|
|
(goto-char (pop histories)) |
|
|
(gnus-delete-line)) |
|
|
(gnus-agent-save-history) |
|
|
(gnus-agent-close-history) |
|
|
(gnus-write-active-file |
|
|
(gnus-agent-lib-file "active") orig)) |
|
|
(gnus-message 4 "Expiry...done"))))))) |
|
3209 |
|
|
3210 |
;;;###autoload |
;;;###autoload |
3211 |
(defun gnus-agent-batch () |
(defun gnus-agent-batch () |
3212 |
|
"Start Gnus, send queue and fetch session." |
3213 |
(interactive) |
(interactive) |
3214 |
(let ((init-file-user "") |
(let ((init-file-user "") |
3215 |
(gnus-always-read-dribble-file t)) |
(gnus-always-read-dribble-file t)) |
3216 |
(gnus)) |
(gnus)) |
3217 |
(gnus-group-send-drafts) |
(let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation)) |
3218 |
(gnus-agent-fetch-session)) |
(gnus-group-send-queue) |
3219 |
|
(gnus-agent-fetch-session))) |
3220 |
|
|
3221 |
|
(defun gnus-agent-unread-articles (group) |
3222 |
|
(let* ((read (gnus-info-read (gnus-get-info group))) |
3223 |
|
(known (gnus-agent-load-alist group)) |
3224 |
|
(unread (list nil)) |
3225 |
|
(tail-unread unread)) |
3226 |
|
(while (and known read) |
3227 |
|
(let ((candidate (car (pop known)))) |
3228 |
|
(while (let* ((range (car read)) |
3229 |
|
(min (if (numberp range) range (car range))) |
3230 |
|
(max (if (numberp range) range (cdr range)))) |
3231 |
|
(cond ((or (not min) |
3232 |
|
(< candidate min)) |
3233 |
|
(gnus-agent-append-to-list tail-unread candidate) |
3234 |
|
nil) |
3235 |
|
((> candidate max) |
3236 |
|
(setq read (cdr read)) |
3237 |
|
;; return t so that I always loop one more |
3238 |
|
;; time. If I just iterated off the end of |
3239 |
|
;; read, min will become nil and the current |
3240 |
|
;; candidate will be added to the unread list. |
3241 |
|
t)))))) |
3242 |
|
(while known |
3243 |
|
(gnus-agent-append-to-list tail-unread (car (pop known)))) |
3244 |
|
(cdr unread))) |
3245 |
|
|
3246 |
|
(defun gnus-agent-uncached-articles (articles group &optional cached-header) |
3247 |
|
"Restrict ARTICLES to numbers already fetched. |
3248 |
|
Returns a sublist of ARTICLES that excludes thos article ids in GROUP |
3249 |
|
that have already been fetched. |
3250 |
|
If CACHED-HEADER is nil, articles are only excluded if the article itself |
3251 |
|
has been fetched." |
3252 |
|
|
3253 |
|
;; Logically equivalent to: (gnus-sorted-difference articles (mapcar |
3254 |
|
;; 'car gnus-agent-article-alist)) |
3255 |
|
|
3256 |
|
;; Functionally, I don't need to construct a temp list using mapcar. |
3257 |
|
|
3258 |
|
(if (and (or gnus-agent-cache (not gnus-plugged)) |
3259 |
|
(gnus-agent-load-alist group)) |
3260 |
|
(let* ((ref gnus-agent-article-alist) |
3261 |
|
(arts articles) |
3262 |
|
(uncached (list nil)) |
3263 |
|
(tail-uncached uncached)) |
3264 |
|
(while (and ref arts) |
3265 |
|
(let ((v1 (car arts)) |
3266 |
|
(v2 (caar ref))) |
3267 |
|
(cond ((< v1 v2) ; v1 does not appear in the reference list |
3268 |
|
(gnus-agent-append-to-list tail-uncached v1) |
3269 |
|
(setq arts (cdr arts))) |
3270 |
|
((= v1 v2) |
3271 |
|
(unless (or cached-header (cdar ref)) ; v1 is already cached |
3272 |
|
(gnus-agent-append-to-list tail-uncached v1)) |
3273 |
|
(setq arts (cdr arts)) |
3274 |
|
(setq ref (cdr ref))) |
3275 |
|
(t ; reference article (v2) preceeds the list being filtered |
3276 |
|
(setq ref (cdr ref)))))) |
3277 |
|
(while arts |
3278 |
|
(gnus-agent-append-to-list tail-uncached (pop arts))) |
3279 |
|
(cdr uncached)) |
3280 |
|
;; if gnus-agent-load-alist fails, no articles are cached. |
3281 |
|
articles)) |
3282 |
|
|
3283 |
|
(defun gnus-agent-retrieve-headers (articles group &optional fetch-old) |
3284 |
|
(save-excursion |
3285 |
|
(gnus-agent-create-buffer) |
3286 |
|
(let ((gnus-decode-encoded-word-function 'identity) |
3287 |
|
(file (gnus-agent-article-name ".overview" group)) |
3288 |
|
cached-articles uncached-articles) |
3289 |
|
(gnus-make-directory (nnheader-translate-file-chars |
3290 |
|
(file-name-directory file) t)) |
3291 |
|
|
3292 |
|
;; Populate temp buffer with known headers |
3293 |
|
(when (file-exists-p file) |
3294 |
|
(with-current-buffer gnus-agent-overview-buffer |
3295 |
|
(erase-buffer) |
3296 |
|
(let ((nnheader-file-coding-system |
3297 |
|
gnus-agent-file-coding-system)) |
3298 |
|
(nnheader-insert-nov-file file (car articles))))) |
3299 |
|
|
3300 |
|
(if (setq uncached-articles (gnus-agent-uncached-articles articles group |
3301 |
|
t)) |
3302 |
|
(progn |
3303 |
|
;; Populate nntp-server-buffer with uncached headers |
3304 |
|
(set-buffer nntp-server-buffer) |
3305 |
|
(erase-buffer) |
3306 |
|
(cond ((not (eq 'nov (let (gnus-agent) ; Turn off agent |
3307 |
|
(gnus-retrieve-headers |
3308 |
|
uncached-articles group fetch-old)))) |
3309 |
|
(nnvirtual-convert-headers)) |
3310 |
|
((eq 'nntp (car gnus-current-select-method)) |
3311 |
|
;; The author of gnus-get-newsgroup-headers-xover |
3312 |
|
;; reports that the XOVER command is commonly |
3313 |
|
;; unreliable. The problem is that recently |
3314 |
|
;; posted articles may not be entered into the |
3315 |
|
;; NOV database in time to respond to my XOVER |
3316 |
|
;; query. |
3317 |
|
;; |
3318 |
|
;; I'm going to use his assumption that the NOV |
3319 |
|
;; database is updated in order of ascending |
3320 |
|
;; article ID. Therefore, a response containing |
3321 |
|
;; article ID N implies that all articles from 1 |
3322 |
|
;; to N-1 are up-to-date. Therefore, missing |
3323 |
|
;; articles in that range have expired. |
3324 |
|
|
3325 |
|
(set-buffer nntp-server-buffer) |
3326 |
|
(let* ((fetched-articles (list nil)) |
3327 |
|
(tail-fetched-articles fetched-articles) |
3328 |
|
(min (cond ((numberp fetch-old) |
3329 |
|
(max 1 (- (car articles) fetch-old))) |
3330 |
|
(fetch-old |
3331 |
|
1) |
3332 |
|
(t |
3333 |
|
(car articles)))) |
3334 |
|
(max (car (last articles)))) |
3335 |
|
|
3336 |
|
;; Get the list of articles that were fetched |
3337 |
|
(goto-char (point-min)) |
3338 |
|
(let ((pm (point-max))) |
3339 |
|
(while (< (point) pm) |
3340 |
|
(when (looking-at "[0-9]+\t") |
3341 |
|
(gnus-agent-append-to-list |
3342 |
|
tail-fetched-articles |
3343 |
|
(read (current-buffer)))) |
3344 |
|
(forward-line 1))) |
3345 |
|
|
3346 |
|
;; Clip this list to the headers that will |
3347 |
|
;; actually be returned |
3348 |
|
(setq fetched-articles (gnus-list-range-intersection |
3349 |
|
(cdr fetched-articles) |
3350 |
|
(cons min max))) |
3351 |
|
|
3352 |
|
;; Clip the uncached articles list to exclude |
3353 |
|
;; IDs after the last FETCHED header. The |
3354 |
|
;; excluded IDs may be fetchable using HEAD. |
3355 |
|
(if (car tail-fetched-articles) |
3356 |
|
(setq uncached-articles |
3357 |
|
(gnus-list-range-intersection |
3358 |
|
uncached-articles |
3359 |
|
(cons (car uncached-articles) |
3360 |
|
(car tail-fetched-articles))))) |
3361 |
|
|
3362 |
|
;; Create the list of articles that were |
3363 |
|
;; "successfully" fetched. Success, in this |
3364 |
|
;; case, means that the ID should not be |
3365 |
|
;; fetched again. In the case of an expired |
3366 |
|
;; article, the header will not be fetched. |
3367 |
|
(setq uncached-articles |
3368 |
|
(gnus-sorted-nunion fetched-articles |
3369 |
|
uncached-articles)) |
3370 |
|
))) |
3371 |
|
|
3372 |
|
;; Erase the temp buffer |
3373 |
|
(set-buffer gnus-agent-overview-buffer) |
3374 |
|
(erase-buffer) |
3375 |
|
|
3376 |
|
;; Copy the nntp-server-buffer to the temp buffer |
3377 |
|
(set-buffer nntp-server-buffer) |
3378 |
|
(copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) |
3379 |
|
|
3380 |
|
;; Merge the temp buffer with the known headers (found on |
3381 |
|
;; disk in FILE) into the nntp-server-buffer |
3382 |
|
(when (and uncached-articles (file-exists-p file)) |
3383 |
|
(gnus-agent-braid-nov group uncached-articles file)) |
3384 |
|
|
3385 |
|
;; Save the new set of known headers to FILE |
3386 |
|
(set-buffer nntp-server-buffer) |
3387 |
|
(let ((coding-system-for-write |
3388 |
|
gnus-agent-file-coding-system)) |
3389 |
|
(gnus-agent-check-overview-buffer) |
3390 |
|
(write-region (point-min) (point-max) file nil 'silent)) |
3391 |
|
|
3392 |
|
;; Update the group's article alist to include the newly |
3393 |
|
;; fetched articles. |
3394 |
|
(gnus-agent-load-alist group) |
3395 |
|
(gnus-agent-save-alist group uncached-articles nil) |
3396 |
|
) |
3397 |
|
|
3398 |
|
;; Copy the temp buffer to the nntp-server-buffer |
3399 |
|
(set-buffer nntp-server-buffer) |
3400 |
|
(erase-buffer) |
3401 |
|
(insert-buffer-substring gnus-agent-overview-buffer))) |
3402 |
|
|
3403 |
|
(if (and fetch-old |
3404 |
|
(not (numberp fetch-old))) |
3405 |
|
t ; Don't remove anything. |
3406 |
|
(nnheader-nov-delete-outside-range |
3407 |
|
(if fetch-old (max 1 (- (car articles) fetch-old)) |
3408 |
|
(car articles)) |
3409 |
|
(car (last articles))) |
3410 |
|
t) |
3411 |
|
|
3412 |
|
'nov)) |
3413 |
|
|
3414 |
|
(defun gnus-agent-request-article (article group) |
3415 |
|
"Retrieve ARTICLE in GROUP from the agent cache." |
3416 |
|
(when (and gnus-agent |
3417 |
|
(or gnus-agent-cache |
3418 |
|
(not gnus-plugged)) |
3419 |
|
(numberp article)) |
3420 |
|
(let* ((gnus-command-method (gnus-find-method-for-group group)) |
3421 |
|
(file (gnus-agent-article-name (number-to-string article) group)) |
3422 |
|
(buffer-read-only nil)) |
3423 |
|
(when (and (file-exists-p file) |
3424 |
|
(> (nth 7 (file-attributes file)) 0)) |
3425 |
|
(erase-buffer) |
3426 |
|
(gnus-kill-all-overlays) |
3427 |
|
(let ((coding-system-for-read gnus-cache-coding-system)) |
3428 |
|
(insert-file-contents file)) |
3429 |
|
t)))) |
3430 |
|
|
3431 |
|
(defun gnus-agent-regenerate-group (group &optional reread) |
3432 |
|
"Regenerate GROUP. |
3433 |
|
If REREAD is t, all articles in the .overview are marked as unread. |
3434 |
|
If REREAD is a list, the specified articles will be marked as unread. |
3435 |
|
In addition, their NOV entries in .overview will be refreshed using |
3436 |
|
the articles' current headers. |
3437 |
|
If REREAD is not nil, downloaded articles are marked as unread." |
3438 |
|
(interactive |
3439 |
|
(list (let ((def (or (gnus-group-group-name) |
3440 |
|
gnus-newsgroup-name))) |
3441 |
|
(let ((select (read-string (if def |
3442 |
|
(concat "Group Name (" |
3443 |
|
def "): ") |
3444 |
|
"Group Name: ")))) |
3445 |
|
(if (and (equal "" select) |
3446 |
|
def) |
3447 |
|
def |
3448 |
|
select))) |
3449 |
|
(catch 'mark |
3450 |
|
(while (let (c |
3451 |
|
(cursor-in-echo-area t) |
3452 |
|
(echo-keystrokes 0)) |
3453 |
|
(message "Mark as unread: (n)one / (a)ll / all (d)ownloaded articles? (n) ") |
3454 |
|
(setq c (read-char-exclusive)) |
3455 |
|
|
3456 |
|
(cond ((or (eq c ?\r) (eq c ?n) (eq c ?N)) |
3457 |
|
(throw 'mark nil)) |
3458 |
|
((or (eq c ?a) (eq c ?A)) |
3459 |
|
(throw 'mark t)) |
3460 |
|
((or (eq c ?d) (eq c ?D)) |
3461 |
|
(throw 'mark 'some))) |
3462 |
|
(gnus-message 3 "Ignoring unexpected input") |
3463 |
|
(sit-for 1) |
3464 |
|
t))))) |
3465 |
|
|
3466 |
|
(when group |
3467 |
|
(gnus-message 5 "Regenerating in %s" group) |
3468 |
|
(let* ((gnus-command-method (or gnus-command-method |
3469 |
|
(gnus-find-method-for-group group))) |
3470 |
|
(file (gnus-agent-article-name ".overview" group)) |
3471 |
|
(dir (file-name-directory file)) |
3472 |
|
point |
3473 |
|
(downloaded (if (file-exists-p dir) |
3474 |
|
(sort (mapcar (lambda (name) (string-to-int name)) |
3475 |
|
(directory-files dir nil "^[0-9]+$" t)) |
3476 |
|
'>) |
3477 |
|
(progn (gnus-make-directory dir) nil))) |
3478 |
|
dl nov-arts |
3479 |
|
alist header |
3480 |
|
regenerated) |
3481 |
|
|
3482 |
|
(mm-with-unibyte-buffer |
3483 |
|
(if (file-exists-p file) |
3484 |
|
(let ((nnheader-file-coding-system |
3485 |
|
gnus-agent-file-coding-system)) |
3486 |
|
(nnheader-insert-file-contents file))) |
3487 |
|
(set-buffer-modified-p nil) |
3488 |
|
|
3489 |
|
;; Load the article IDs found in the overview file. As a |
3490 |
|
;; side-effect, validate the file contents. |
3491 |
|
(let ((load t)) |
3492 |
|
(while load |
3493 |
|
(setq load nil) |
3494 |
|
(goto-char (point-min)) |
3495 |
|
(while (< (point) (point-max)) |
3496 |
|
(cond ((and (looking-at "[0-9]+\t") |
3497 |
|
(<= (- (match-end 0) (match-beginning 0)) 9)) |
3498 |
|
(push (read (current-buffer)) nov-arts) |
3499 |
|
(forward-line 1) |
3500 |
|
(let ((l1 (car nov-arts)) |
3501 |
|
(l2 (cadr nov-arts))) |
3502 |
|
(cond ((and (listp reread) (memq l1 reread)) |
3503 |
|
(gnus-delete-line) |
3504 |
|
(setq nov-arts (cdr nov-arts)) |
3505 |
|
(gnus-message 4 "gnus-agent-regenerate-group: NOV\ |
3506 |
|
entry of article %s deleted." l1)) |
3507 |
|
((not l2) |
3508 |
|
nil) |
3509 |
|
((< l1 l2) |
3510 |
|
(gnus-message 3 "gnus-agent-regenerate-group: NOV\ |
3511 |
|
entries are NOT in ascending order.") |
3512 |
|
;; Don't sort now as I haven't verified |
3513 |
|
;; that every line begins with a number |
3514 |
|
(setq load t)) |
3515 |
|
((= l1 l2) |
3516 |
|
(forward-line -1) |
3517 |
|
(gnus-message 4 "gnus-agent-regenerate-group: NOV\ |
3518 |
|
entries contained duplicate of article %s. Duplicate deleted." l1) |
3519 |
|
(gnus-delete-line) |
3520 |
|
(setq nov-arts (cdr nov-arts)))))) |
3521 |
|
(t |
3522 |
|
(gnus-message 1 "gnus-agent-regenerate-group: NOV\ |
3523 |
|
entries contained line that did not begin with an article number. Deleted\ |
3524 |
|
line.") |
3525 |
|
(gnus-delete-line)))) |
3526 |
|
(when load |
3527 |
|
(gnus-message 5 "gnus-agent-regenerate-group: Sorting NOV\ |
3528 |
|
entries into ascending order.") |
3529 |
|
(sort-numeric-fields 1 (point-min) (point-max)) |
3530 |
|
(setq nov-arts nil)))) |
3531 |
|
(gnus-agent-check-overview-buffer) |
3532 |
|
|
3533 |
|
;; Construct a new article alist whose nodes match every header |
3534 |
|
;; in the .overview file. As a side-effect, missing headers are |
3535 |
|
;; reconstructed from the downloaded article file. |
3536 |
|
(while (or downloaded nov-arts) |
3537 |
|
(cond ((and downloaded |
3538 |
|
(or (not nov-arts) |
3539 |
|
(> (car downloaded) (car nov-arts)))) |
3540 |
|
;; This entry is missing from the overview file |
3541 |
|
(gnus-message 3 "Regenerating NOV %s %d..." group |
3542 |
|
(car downloaded)) |
3543 |
|
(let ((file (concat dir (number-to-string (car downloaded))))) |
3544 |
|
(mm-with-unibyte-buffer |
3545 |
|
(nnheader-insert-file-contents file) |
3546 |
|
(nnheader-remove-body) |
3547 |
|
(setq header (nnheader-parse-naked-head))) |
3548 |
|
(mail-header-set-number header (car downloaded)) |
3549 |
|
(if nov-arts |
3550 |
|
(let ((key (concat "^" (int-to-string (car nov-arts)) |
3551 |
|
"\t"))) |
3552 |
|
(or (re-search-backward key nil t) |
3553 |
|
(re-search-forward key)) |
3554 |
|
(forward-line 1)) |
3555 |
|
(goto-char (point-min))) |
3556 |
|
(nnheader-insert-nov header)) |
3557 |
|
(setq nov-arts (cons (car downloaded) nov-arts))) |
3558 |
|
((eq (car downloaded) (car nov-arts)) |
3559 |
|
;; This entry in the overview has been downloaded |
3560 |
|
(push (cons (car downloaded) |
3561 |
|
(time-to-days |
3562 |
|
(nth 5 (file-attributes |
3563 |
|
(concat dir (number-to-string |
3564 |
|
(car downloaded))))))) alist) |
3565 |
|
(setq downloaded (cdr downloaded)) |
3566 |
|
(setq nov-arts (cdr nov-arts))) |
3567 |
|
(t |
3568 |
|
;; This entry in the overview has not been downloaded |
3569 |
|
(push (cons (car nov-arts) nil) alist) |
3570 |
|
(setq nov-arts (cdr nov-arts))))) |
3571 |
|
|
3572 |
|
;; When gnus-agent-consider-all-articles is set, |
3573 |
|
;; gnus-agent-regenerate-group should NOT remove article IDs from |
3574 |
|
;; the alist. Those IDs serve as markers to indicate that an |
3575 |
|
;; attempt has been made to fetch that article's header. |
3576 |
|
|
3577 |
|
;; When gnus-agent-consider-all-articles is NOT set, |
3578 |
|
;; gnus-agent-regenerate-group can remove the article ID of every |
3579 |
|
;; article (with the exception of the last ID in the list - it's |
3580 |
|
;; special) that no longer appears in the overview. In this |
3581 |
|
;; situtation, the last article ID in the list implies that it, |
3582 |
|
;; and every article ID preceeding it, have been fetched from the |
3583 |
|
;; server. |
3584 |
|
|
3585 |
|
(if gnus-agent-consider-all-articles |
3586 |
|
;; Restore all article IDs that were not found in the overview file. |
3587 |
|
(let* ((n (cons nil alist)) |
3588 |
|
(merged n) |
3589 |
|
(o (gnus-agent-load-alist group))) |
3590 |
|
(while o |
3591 |
|
(let ((nID (caadr n)) |
3592 |
|
(oID (caar o))) |
3593 |
|
(cond ((not nID) |
3594 |
|
(setq n (setcdr n (list (list oID)))) |
3595 |
|
(setq o (cdr o))) |
3596 |
|
((< oID nID) |
3597 |
|
(setcdr n (cons (list oID) (cdr n))) |
3598 |
|
(setq o (cdr o))) |
3599 |
|
((= oID nID) |
3600 |
|
(setq o (cdr o)) |
3601 |
|
(setq n (cdr n))) |
3602 |
|
(t |
3603 |
|
(setq n (cdr n)))))) |
3604 |
|
(setq alist (cdr merged))) |
3605 |
|
;; Restore the last article ID if it is not already in the new alist |
3606 |
|
(let ((n (last alist)) |
3607 |
|
(o (last (gnus-agent-load-alist group)))) |
3608 |
|
(cond ((not o) |
3609 |
|
nil) |
3610 |
|
((not n) |
3611 |
|
(push (cons (caar o) nil) alist)) |
3612 |
|
((< (caar n) (caar o)) |
3613 |
|
(setcdr n (list (car o))))))) |
3614 |
|
|
3615 |
|
(let ((inhibit-quit t)) |
3616 |
|
(if (setq regenerated (buffer-modified-p)) |
3617 |
|
(let ((coding-system-for-write gnus-agent-file-coding-system)) |
3618 |
|
(write-region (point-min) (point-max) file nil 'silent))) |
3619 |
|
|
3620 |
|
(setq regenerated (or regenerated |
3621 |
|
(and reread gnus-agent-article-alist) |
3622 |
|
(not (equal alist gnus-agent-article-alist)))) |
3623 |
|
|
3624 |
|
(setq gnus-agent-article-alist alist) |
3625 |
|
|
3626 |
|
(when regenerated |
3627 |
|
(gnus-agent-save-alist group) |
3628 |
|
|
3629 |
|
;; I have to alter the group's active range NOW as |
3630 |
|
;; gnus-make-ascending-articles-unread will use it to |
3631 |
|
;; recalculate the number of unread articles in the group |
3632 |
|
|
3633 |
|
(let ((group (gnus-group-real-name group)) |
3634 |
|
(group-active (or (gnus-active group) |
3635 |
|
(gnus-activate-group group)))) |
3636 |
|
(gnus-agent-possibly-alter-active group group-active))))) |
3637 |
|
|
3638 |
|
(when (and reread gnus-agent-article-alist) |
3639 |
|
(gnus-make-ascending-articles-unread |
3640 |
|
group |
3641 |
|
(if (listp reread) |
3642 |
|
reread |
3643 |
|
(delq nil (mapcar (function (lambda (c) |
3644 |
|
(cond ((eq reread t) |
3645 |
|
(car c)) |
3646 |
|
((cdr c) |
3647 |
|
(car c))))) |
3648 |
|
gnus-agent-article-alist)))) |
3649 |
|
|
3650 |
|
(when (gnus-buffer-live-p gnus-group-buffer) |
3651 |
|
(gnus-group-update-group group t) |
3652 |
|
(sit-for 0))) |
3653 |
|
|
3654 |
|
(gnus-message 5 nil) |
3655 |
|
regenerated))) |
3656 |
|
|
3657 |
|
;;;###autoload |
3658 |
|
(defun gnus-agent-regenerate (&optional clean reread) |
3659 |
|
"Regenerate all agent covered files. |
3660 |
|
If CLEAN, obsolete (ignore)." |
3661 |
|
(interactive "P") |
3662 |
|
(let (regenerated) |
3663 |
|
(gnus-message 4 "Regenerating Gnus agent files...") |
3664 |
|
(dolist (gnus-command-method (gnus-agent-covered-methods)) |
3665 |
|
(dolist (group (gnus-groups-from-server gnus-command-method)) |
3666 |
|
(setq regenerated (or (gnus-agent-regenerate-group group reread) |
3667 |
|
regenerated)))) |
3668 |
|
(gnus-message 4 "Regenerating Gnus agent files...done") |
3669 |
|
|
3670 |
|
regenerated)) |
3671 |
|
|
3672 |
|
(defun gnus-agent-go-online (&optional force) |
3673 |
|
"Switch servers into online status." |
3674 |
|
(interactive (list t)) |
3675 |
|
(dolist (server gnus-opened-servers) |
3676 |
|
(when (eq (nth 1 server) 'offline) |
3677 |
|
(if (if (eq force 'ask) |
3678 |
|
(gnus-y-or-n-p |
3679 |
|
(format "Switch %s:%s into online status? " |
3680 |
|
(caar server) (cadar server))) |
3681 |
|
force) |
3682 |
|
(setcar (nthcdr 1 server) 'close))))) |
3683 |
|
|
3684 |
|
(defun gnus-agent-toggle-group-plugged (group) |
3685 |
|
"Toggle the status of the server of the current group." |
3686 |
|
(interactive (list (gnus-group-group-name))) |
3687 |
|
(let* ((method (gnus-find-method-for-group group)) |
3688 |
|
(status (cadr (assoc method gnus-opened-servers)))) |
3689 |
|
(if (eq status 'offline) |
3690 |
|
(gnus-server-set-status method 'closed) |
3691 |
|
(gnus-close-server method) |
3692 |
|
(gnus-server-set-status method 'offline)) |
3693 |
|
(message "Turn %s:%s from %s to %s." (car method) (cadr method) |
3694 |
|
(if (eq status 'offline) 'offline 'online) |
3695 |
|
(if (eq status 'offline) 'online 'offline)))) |
3696 |
|
|
3697 |
|
(defun gnus-agent-group-covered-p (group) |
3698 |
|
(gnus-agent-method-p (gnus-group-method group))) |
3699 |
|
|
3700 |
|
(add-hook 'gnus-group-prepare-hook |
3701 |
|
(lambda () |
3702 |
|
'gnus-agent-do-once |
3703 |
|
|
3704 |
|
(when (listp gnus-agent-expire-days) |
3705 |
|
(beep) |
3706 |
|
(beep) |
3707 |
|
(gnus-message 1 "WARNING: gnus-agent-expire-days no longer\ |
3708 |
|
supports being set to a list.")(sleep-for 3) |
3709 |
|
(gnus-message 1 "Change your configuration to set it to an\ |
3710 |
|
integer.")(sleep-for 3) |
3711 |
|
(gnus-message 1 "I am now setting group parameters on each\ |
3712 |
|
group to match the configuration that the list offered.") |
3713 |
|
|
3714 |
|
(save-excursion |
3715 |
|
(let ((groups (gnus-group-listed-groups))) |
3716 |
|
(while groups |
3717 |
|
(let* ((group (pop groups)) |
3718 |
|
(days gnus-agent-expire-days) |
3719 |
|
(day (catch 'found |
3720 |
|
(while days |
3721 |
|
(when (eq 0 (string-match |
3722 |
|
(caar days) |
3723 |
|
group)) |
3724 |
|
(throw 'found (cadar days))) |
3725 |
|
(setq days (cdr days))) |
3726 |
|
nil))) |
3727 |
|
(when day |
3728 |
|
(gnus-group-set-parameter group 'agent-days-until-old |
3729 |
|
day)))))) |
3730 |
|
|
3731 |
|
(let ((h gnus-group-prepare-hook)) |
3732 |
|
(while h |
3733 |
|
(let ((func (pop h))) |
3734 |
|
(when (and (listp func) |
3735 |
|
(eq (cadr (caddr func)) 'gnus-agent-do-once)) |
3736 |
|
(remove-hook 'gnus-group-prepare-hook func) |
3737 |
|
(setq h nil))))) |
3738 |
|
|
3739 |
|
(gnus-message 1 "I have finished setting group parameters on\ |
3740 |
|
each group. You may now customize your groups and/or topics to control the\ |
3741 |
|
agent.")))) |
3742 |
|
|
3743 |
(provide 'gnus-agent) |
(provide 'gnus-agent) |
3744 |
|
|