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