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