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