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