HCoop / bpt / emacs.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Move lisp/emacs-lisp/authors.el to admin/
[bpt/emacs.git] / lisp / gnus / gnus-agent.el
CommitLineData
df80b09f 1;;; gnus-agent.el --- unplugged support for Gnus
e84b4b86 2
ba318903 3;; Copyright (C) 1997-2014 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))
c2e9e9ef 495 (when (derived-mode-p '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
c2e9e9ef 884 (let ((gnus-command-method old-command-method))
54506618
MB		 885 (gnus-agent-group-pathname old-group))))
886 (new-command-method (gnus-find-method-for-group new-group))
887 (new-path (directory-file-name
c2e9e9ef 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
c2e9e9ef 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)
c2e9e9ef
SM		 924 ;; FIXME: Does gnus-agent-get-local have any useful side-effect?
925 (gnus-agent-get-local group real-group command-method)
926 (gnus-agent-set-local group
927 nil nil
928 real-group command-method))))
54506618 929
df80b09f
LMI		 930;;;
931;;; Server mode commands
932;;;
933
23f87bed 934(defun gnus-agent-add-server ()
df80b09f 935 "Enroll SERVER in the agent program."
23f87bed
MB		 936 (interactive)
937 (let* ((server (gnus-server-server-name))
938 (named-server (gnus-server-named-server))
939 (method (and server
940 (gnus-server-get-method nil server))))
941 (unless server
942 (error "No server on the current line"))
943
944 (when (gnus-agent-method-p method)
df80b09f 945 (error "Server already in the agent program"))
23f87bed
MB		 946
947 (push named-server gnus-agent-covered-methods)
948
949 (setq gnus-agent-method-p-cache nil)
950 (gnus-server-update-server server)
df80b09f 951 (gnus-agent-write-servers)
23f87bed 952 (gnus-message 1 "Entered %s into the Agent" server)))
df80b09f 953
23f87bed 954(defun gnus-agent-remove-server ()
df80b09f 955 "Remove SERVER from the agent program."
23f87bed
MB		 956 (interactive)
957 (let* ((server (gnus-server-server-name))
958 (named-server (gnus-server-named-server)))
959 (unless server
960 (error "No server on the current line"))
961
962 (unless (member named-server gnus-agent-covered-methods)
df80b09f 963 (error "Server not in the agent program"))
23f87bed 964
bf247b6e 965 (setq gnus-agent-covered-methods
23f87bed
MB		 966 (delete named-server gnus-agent-covered-methods)
967 gnus-agent-method-p-cache nil)
968
969 (gnus-server-update-server server)
df80b09f 970 (gnus-agent-write-servers)
23f87bed 971 (gnus-message 1 "Removed %s from the agent" server)))
df80b09f
LMI		 972
973(defun gnus-agent-read-servers ()
974 "Read the alist of covered servers."
bf247b6e 975 (setq gnus-agent-covered-methods
23f87bed
MB		 976 (gnus-agent-read-file
977 (nnheader-concat gnus-agent-directory "lib/servers"))
978 gnus-agent-method-p-cache nil)
979
980 ;; I am called so early in start-up that I can not validate server
981 ;; names. When that is the case, I skip the validation. That is
982 ;; alright as the gnus startup code calls the validate methods
983 ;; directly.
984 (if gnus-server-alist
985 (gnus-agent-read-servers-validate)))
986
987(defun gnus-agent-read-servers-validate ()
988 (mapcar (lambda (server-or-method)
989 (let* ((server (if (stringp server-or-method)
990 server-or-method
991 (gnus-method-to-server server-or-method)))
992 (method (gnus-server-to-method server)))
993 (if method
994 (unless (member server gnus-agent-covered-methods)
995 (push server gnus-agent-covered-methods)
996 (setq gnus-agent-method-p-cache nil))
4478e074 997 (gnus-message 8 "Ignoring disappeared server `%s'" server))))
23f87bed
MB		 998 (prog1 gnus-agent-covered-methods
999 (setq gnus-agent-covered-methods nil))))
1000
1001(defun gnus-agent-read-servers-validate-native (native-method)
df80b09f 1002 (setq gnus-agent-covered-methods
23f87bed
MB		 1003 (mapcar (lambda (method)
1004 (if (or (not method)
1005 (equal method native-method))
1006 "native"
1007 method)) gnus-agent-covered-methods)))
df80b09f
LMI		 1008
1009(defun gnus-agent-write-servers ()
1010 "Write the alist of covered servers."
16409b0b
GM		 1011 (gnus-make-directory (nnheader-concat gnus-agent-directory "lib"))
1012 (let ((coding-system-for-write nnheader-file-coding-system)
1013 (file-name-coding-system nnmail-pathname-coding-system))
1014 (with-temp-file (nnheader-concat gnus-agent-directory "lib/servers")
23f87bed
MB		 1015 (prin1 gnus-agent-covered-methods
1016 (current-buffer)))))
df80b09f
LMI		 1017
1018;;;
1019;;; Summary commands
1020;;;
1021
1022(defun gnus-agent-mark-article (n &optional unmark)
1023 "Mark the next N articles as downloadable.
1024If N is negative, mark backward instead. If UNMARK is non-nil, remove
1025the mark instead. The difference between N and the actual number of
1026articles marked is returned."
1027 (interactive "p")
1028 (let ((backward (< n 0))
1029 (n (abs n)))
1030 (while (and
1031 (> n 0)
1032 (progn
1033 (gnus-summary-set-agent-mark
1034 (gnus-summary-article-number) unmark)
1035 (zerop (gnus-summary-next-subject (if backward -1 1) nil t))))
1036 (setq n (1- n)))
1037 (when (/= 0 n)
1038 (gnus-message 7 "No more articles"))
1039 (gnus-summary-recenter)
1040 (gnus-summary-position-point)
1041 n))
1042
1043(defun gnus-agent-unmark-article (n)
1044 "Remove the downloadable mark from the next N articles.
1045If N is negative, unmark backward instead. The difference between N and
1046the actual number of articles unmarked is returned."
1047 (interactive "p")
1048 (gnus-agent-mark-article n t))
1049
1050(defun gnus-agent-toggle-mark (n)
1051 "Toggle the downloadable mark from the next N articles.
1052If N is negative, toggle backward instead. The difference between N and
1053the actual number of articles toggled is returned."
1054 (interactive "p")
1055 (gnus-agent-mark-article n 'toggle))
1056
1057(defun gnus-summary-set-agent-mark (article &optional unmark)
23f87bed
MB		 1058 "Mark ARTICLE as downloadable. If UNMARK is nil, article is marked.
1059When UNMARK is t, the article is unmarked. For any other value, the
1060article's mark is toggled."
1061 (let ((unmark (cond ((eq nil unmark)
1062 nil)
1063 ((eq t unmark)
1064 t)
1065 (t
1066 (memq article gnus-newsgroup-downloadable)))))
1067 (when (gnus-summary-goto-subject article nil t)
1068 (gnus-summary-update-mark
1069 (if unmark
1070 (progn
1071 (setq gnus-newsgroup-downloadable
1072 (delq article gnus-newsgroup-downloadable))
1073 (gnus-article-mark article))
1074 (setq gnus-newsgroup-downloadable
1075 (gnus-add-to-sorted-list gnus-newsgroup-downloadable article))
1076 gnus-downloadable-mark)
1077 'unread))))
df80b09f 1078
54506618 1079;;;###autoload
df80b09f 1080(defun gnus-agent-get-undownloaded-list ()
23f87bed 1081 "Construct list of articles that have not been downloaded."
df80b09f 1082 (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name)))
23f87bed
MB		 1083 (when (set (make-local-variable 'gnus-newsgroup-agentized)
1084 (gnus-agent-method-p gnus-command-method))
1085 (let* ((alist (gnus-agent-load-alist gnus-newsgroup-name))
1086 (headers (sort (mapcar (lambda (h)
1087 (mail-header-number h))
1088 gnus-newsgroup-headers) '<))
1089 (cached (and gnus-use-cache gnus-newsgroup-cached))
1090 (undownloaded (list nil))
1091 (tail-undownloaded undownloaded)
1092 (unfetched (list nil))
1093 (tail-unfetched unfetched))
1094 (while (and alist headers)
1095 (let ((a (caar alist))
1096 (h (car headers)))
1097 (cond ((< a h)
1098 ;; Ignore IDs in the alist that are not being
1099 ;; displayed in the summary.
1100 (setq alist (cdr alist)))
1101 ((> a h)
1102 ;; Headers that are not in the alist should be
c5e87d10 1103 ;; fictitious (see nnagent-retrieve-headers); they
23f87bed
MB		 1104 ;; imply that this article isn't in the agent.
1105 (gnus-agent-append-to-list tail-undownloaded h)
1106 (gnus-agent-append-to-list tail-unfetched h)
bf247b6e 1107 (setq headers (cdr headers)))
23f87bed
MB		 1108 ((cdar alist)
1109 (setq alist (cdr alist))
1110 (setq headers (cdr headers))
1111 nil ; ignore already downloaded
1112 )
1113 (t
1114 (setq alist (cdr alist))
1115 (setq headers (cdr headers))
bf247b6e 1116
23f87bed
MB		 1117 ;; This article isn't in the agent. Check to see
1118 ;; if it is in the cache. If it is, it's been
1119 ;; downloaded.
1120 (while (and cached (< (car cached) a))
1121 (setq cached (cdr cached)))
1122 (unless (equal a (car cached))
1123 (gnus-agent-append-to-list tail-undownloaded a))))))
1124
1125 (while headers
1126 (let ((num (pop headers)))
1127 (gnus-agent-append-to-list tail-undownloaded num)
1128 (gnus-agent-append-to-list tail-unfetched num)))
1129
1130 (setq gnus-newsgroup-undownloaded (cdr undownloaded)
1131 gnus-newsgroup-unfetched (cdr unfetched))))))
df80b09f
LMI		 1132
1133(defun gnus-agent-catchup ()
23f87bed
MB		 1134 "Mark as read all unhandled articles.
1135An article is unhandled if it is neither cached, nor downloaded, nor
1136downloadable."
df80b09f
LMI		 1137 (interactive)
1138 (save-excursion
23f87bed
MB		 1139 (let ((articles gnus-newsgroup-undownloaded))
1140 (when (or gnus-newsgroup-downloadable
1141 gnus-newsgroup-cached)
1142 (setq articles (gnus-sorted-ndifference
1143 (gnus-sorted-ndifference
1144 (gnus-copy-sequence articles)
1145 gnus-newsgroup-downloadable)
1146 gnus-newsgroup-cached)))
1147
1148 (while articles
1149 (gnus-summary-mark-article
1150 (pop articles) gnus-catchup-mark)))
1151 (gnus-summary-position-point)))
1152
1153(defun gnus-agent-summary-fetch-series ()
e7719ea1 1154 "Fetch the process-marked articles into the Agent."
23f87bed
MB		 1155 (interactive)
1156 (when gnus-newsgroup-processable
1157 (setq gnus-newsgroup-downloadable
1158 (let* ((dl gnus-newsgroup-downloadable)
58090a8d
MB		 1159 (processable (sort (gnus-copy-sequence gnus-newsgroup-processable) '<))
1160 (gnus-newsgroup-downloadable processable))
1161 (gnus-agent-summary-fetch-group)
23f87bed 1162
58090a8d
MB		 1163 ;; For each article that I processed that is no longer
1164 ;; undownloaded, remove its processable mark.
1165
655591a7 1166 (mapc #'gnus-summary-remove-process-mark
58090a8d
MB		 1167 (gnus-sorted-ndifference gnus-newsgroup-processable gnus-newsgroup-undownloaded))
1168
97610156 1169 ;; The preceding call to (gnus-agent-summary-fetch-group)
58090a8d
MB		 1170 ;; updated the temporary gnus-newsgroup-downloadable to
1171 ;; remove each article successfully fetched. Now, I
1172 ;; update the real gnus-newsgroup-downloadable to only
1173 ;; include undownloaded articles.
1174 (gnus-sorted-ndifference dl (gnus-sorted-ndifference processable gnus-newsgroup-undownloaded))))))
23f87bed
MB		 1175
1176(defun gnus-agent-summary-fetch-group (&optional all)
1177 "Fetch the downloadable articles in the group.
1178Optional arg ALL, if non-nil, means to fetch all articles."
1179 (interactive "P")
1180 (let ((articles
1181 (if all gnus-newsgroup-articles
1182 gnus-newsgroup-downloadable))
1183 (gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))
1184 fetched-articles)
1185 (gnus-agent-while-plugged
1186 (unless articles
1187 (error "No articles to download"))
1188 (gnus-agent-with-fetch
1189 (setq gnus-newsgroup-undownloaded
1190 (gnus-sorted-ndifference
1191 gnus-newsgroup-undownloaded
1192 (setq fetched-articles
1193 (gnus-agent-fetch-articles
1194 gnus-newsgroup-name articles)))))
1195 (save-excursion
1196 (dolist (article articles)
bf247b6e 1197 (let ((was-marked-downloadable
23f87bed
MB		 1198 (memq article gnus-newsgroup-downloadable)))
1199 (cond (gnus-agent-mark-unread-after-downloaded
1200 (setq gnus-newsgroup-downloadable
1201 (delq article gnus-newsgroup-downloadable))
e7719ea1
G		 1202 (when (and (not (member article gnus-newsgroup-dormant))
1203 (not (member article gnus-newsgroup-marked)))
1204 (gnus-summary-mark-article article gnus-unread-mark)))
23f87bed
MB		 1205 (was-marked-downloadable
1206 (gnus-summary-set-agent-mark article t)))
1207 (when (gnus-summary-goto-subject article nil t)
1208 (gnus-summary-update-download-mark article))))))
1209 fetched-articles))
1210
1211(defun gnus-agent-fetch-selected-article ()
1212 "Fetch the current article as it is selected.
1213This can be added to `gnus-select-article-hook' or
1214`gnus-mark-article-hook'."
1215 (let ((gnus-command-method gnus-current-select-method))
1216 (when (and gnus-plugged (gnus-agent-method-p gnus-command-method))
1217 (when (gnus-agent-fetch-articles
1218 gnus-newsgroup-name
1219 (list gnus-current-article))
1220 (setq gnus-newsgroup-undownloaded
1221 (delq gnus-current-article gnus-newsgroup-undownloaded))
1222 (gnus-summary-update-download-mark gnus-current-article)))))
df80b09f
LMI		 1223
1224;;;
1225;;; Internal functions
1226;;;
1227
54506618
MB		 1228(defun gnus-agent-synchronize-group-flags (group actions server)
1229"Update a plugged group by performing the indicated actions."
1230 (let* ((gnus-command-method (gnus-server-to-method server))
1231 (info
1232 ;; This initializer is required as gnus-request-set-mark
1233 ;; calls gnus-group-real-name to strip off the host name
1234 ;; before calling the backend. Now that the backend is
1235 ;; trying to call gnus-request-set-mark, I have to
1236 ;; reconstruct the original group name.
1237 (or (gnus-get-info group)
bf247b6e
KS		 1238 (gnus-get-info
1239 (setq group (gnus-group-full-name
54506618
MB		 1240 group gnus-command-method))))))
1241 (gnus-request-set-mark group actions)
1242
1243 (when info
1244 (dolist (action actions)
1245 (let ((range (nth 0 action))
1246 (what (nth 1 action))
1247 (marks (nth 2 action)))
1248 (dolist (mark marks)
1249 (cond ((eq mark 'read)
bf247b6e 1250 (gnus-info-set-read
54506618
MB		 1251 info
1252 (funcall (if (eq what 'add)
1253 'gnus-range-add
1254 'gnus-remove-from-range)
1255 (gnus-info-read info)
1256 range))
bf247b6e 1257 (gnus-get-unread-articles-in-group
54506618
MB		 1258 info
1259 (gnus-active (gnus-info-group info))))
1260 ((memq mark '(tick))
1261 (let ((info-marks (assoc mark (gnus-info-marks info))))
1262 (unless info-marks
1263 (gnus-info-set-marks info (cons (setq info-marks (list mark)) (gnus-info-marks info))))
1264 (setcdr info-marks (funcall (if (eq what 'add)
1265 'gnus-range-add
1266 'gnus-remove-from-range)
1267 (cdr info-marks)
58090a8d
MB		 1268 range))))))))
1269
1270 ;;Marks can be synchronized at any time by simply toggling from
1271 ;;unplugged to plugged. If that is what is happening right now, make
1272 ;;sure that the group buffer is up to date.
1273 (when (gnus-buffer-live-p gnus-group-buffer)
1274 (gnus-group-update-group group t)))
54506618
MB		 1275 nil))
1276
89b163db
G		 1277(defun gnus-agent-save-active (method &optional groups-p)
1278 "Sync the agent's active file with the current buffer.
1279Pass non-nil for GROUPS-P if the buffer starts out in groups format.
1280Regardless, both the file and the buffer end up in active format
1281if METHOD is agentized; otherwise the function is a no-op."
df80b09f
LMI		 1282 (when (gnus-agent-method-p method)
1283 (let* ((gnus-command-method method)
16409b0b 1284 (new (gnus-make-hashtable (count-lines (point-min) (point-max))))
df80b09f 1285 (file (gnus-agent-lib-file "active")))
89b163db
G		 1286 (if groups-p
1287 (gnus-groups-to-gnus-format nil new)
1288 (gnus-active-to-gnus-format nil new))
16409b0b
GM		 1289 (gnus-agent-write-active file new)
1290 (erase-buffer)
01c52d31
MB		 1291 (let ((nnheader-file-coding-system gnus-agent-file-coding-system))
1292 (nnheader-insert-file-contents file)))))
16409b0b
GM		 1293
1294(defun gnus-agent-write-active (file new)
df80b09f 1295 (gnus-make-directory (file-name-directory file))
23f87bed
MB		 1296 (let ((nnmail-active-file-coding-system gnus-agent-file-coding-system))
1297 ;; The hashtable contains real names of groups. However, do NOT
1298 ;; add the foreign server prefix as gnus-active-to-gnus-format
1299 ;; will add it while reading the file.
1300 (gnus-write-active-file file new nil)))
1301
54506618 1302;;;###autoload
23f87bed
MB		 1303(defun gnus-agent-possibly-alter-active (group active &optional info)
1304 "Possibly expand a group's active range to include articles
1305downloaded into the agent."
1306 (let* ((gnus-command-method (or gnus-command-method
1307 (gnus-find-method-for-group group))))
1308 (when (gnus-agent-method-p gnus-command-method)
1309 (let* ((local (gnus-agent-get-local group))
1310 (active-min (or (car active) 0))
1311 (active-max (or (cdr active) 0))
1312 (agent-min (or (car local) active-min))
1313 (agent-max (or (cdr local) active-max)))
1314
1315 (when (< agent-min active-min)
1316 (setcar active agent-min))
1317
1318 (when (> agent-max active-max)
1319 (setcdr active agent-max))
1320
1321 (when (and info (< agent-max (- active-min 100)))
1322 ;; I'm expanding the active range by such a large amount
1323 ;; that there is a gap of more than 100 articles between the
1324 ;; last article known to the agent and the first article
1325 ;; currently available on the server. This gap contains
1326 ;; articles that have been lost, mark them as read so that
1327 ;; gnus doesn't waste resources trying to fetch them.
1328
1329 ;; NOTE: I don't do this for smaller gaps (< 100) as I don't
1330 ;; want to modify the local file everytime someone restarts
1331 ;; gnus. The small gap will cause a tiny performance hit
1332 ;; when gnus tries, and fails, to retrieve the articles.
1333 ;; Still that should be smaller than opening a buffer,
1334 ;; printing this list to the buffer, and then writing it to a
1335 ;; file.
1336
1337 (let ((read (gnus-info-read info)))
bf247b6e
KS		 1338 (gnus-info-set-read
1339 info
1340 (gnus-range-add
1341 read
1342 (list (cons (1+ agent-max)
23f87bed
MB		 1343 (1- active-min))))))
1344
1345 ;; Lie about the agent's local range for this group to
1346 ;; disable the set read each time this server is opened.
1347 ;; NOTE: Opening this group will restore the valid local
1348 ;; range but it will also expand the local range to
53964682 1349 ;; encompass the new active range.
23f87bed 1350 (gnus-agent-set-local group agent-min (1- active-min)))))))
df80b09f
LMI		 1351
1352(defun gnus-agent-save-group-info (method group active)
23f87bed 1353 "Update a single group's active range in the agent's copy of the server's active file."
df80b09f 1354 (when (gnus-agent-method-p method)
54506618 1355 (let* ((gnus-command-method (or method gnus-command-method))
16409b0b
GM		 1356 (coding-system-for-write nnheader-file-coding-system)
1357 (file-name-coding-system nnmail-pathname-coding-system)
1358 (file (gnus-agent-lib-file "active"))
23f87bed 1359 oactive-min oactive-max)
df80b09f 1360 (gnus-make-directory (file-name-directory file))
16409b0b
GM		 1361 (with-temp-file file
1362 ;; Emacs got problem to match non-ASCII group in multibyte buffer.
a1506d29 1363 (mm-disable-multibyte)
df80b09f 1364 (when (file-exists-p file)
23f87bed
MB		 1365 (nnheader-insert-file-contents file)
1366
1367 (goto-char (point-min))
1368 (when (re-search-forward
1369 (concat "^" (regexp-quote group) " ") nil t)
1370 (save-excursion
58090a8d 1371 (setq oactive-max (read (current-buffer)) ;; max
23f87bed
MB		 1372 oactive-min (read (current-buffer)))) ;; min
1373 (gnus-delete-line)))
54506618
MB		 1374 (when active
1375 (insert (format "%S %d %d y\n" (intern group)
1376 (max (or oactive-max (cdr active)) (cdr active))
1377 (min (or oactive-min (car active)) (car active))))
1378 (goto-char (point-max))
1379 (while (search-backward "\\." nil t)
1380 (delete-char 1)))))))
1381
1382(defun gnus-agent-get-group-info (method group)
1383 "Get a single group's active range in the agent's copy of the server's active file."
1384 (when (gnus-agent-method-p method)
1385 (let* ((gnus-command-method (or method gnus-command-method))
1386 (coding-system-for-write nnheader-file-coding-system)
1387 (file-name-coding-system nnmail-pathname-coding-system)
1388 (file (gnus-agent-lib-file "active"))
1389 oactive-min oactive-max)
1390 (gnus-make-directory (file-name-directory file))
1391 (with-temp-buffer
1392 ;; Emacs got problem to match non-ASCII group in multibyte buffer.
1393 (mm-disable-multibyte)
1394 (when (file-exists-p file)
1395 (nnheader-insert-file-contents file)
1396
1397 (goto-char (point-min))
1398 (when (re-search-forward
1399 (concat "^" (regexp-quote group) " ") nil t)
1400 (save-excursion
1401 (setq oactive-max (read (current-buffer)) ;; max
1402 oactive-min (read (current-buffer))) ;; min
1403 (cons oactive-min oactive-max))))))))
df80b09f 1404
01c52d31
MB		 1405(defvar gnus-agent-decoded-group-names nil
1406 "Alist of non-ASCII group names and decoded ones.")
1407
1408(defun gnus-agent-decoded-group-name (group)
1409 "Return a decoded group name of GROUP."
1410 (or (cdr (assoc group gnus-agent-decoded-group-names))
1411 (if (string-match "[^\000-\177]" group)
1412 (let ((decoded (gnus-group-decoded-name group)))
1413 (push (cons group decoded) gnus-agent-decoded-group-names)
1414 decoded)
1415 group)))
1416
df80b09f 1417(defun gnus-agent-group-path (group)
35ef97a5 1418 "Translate GROUP into a file name."
23f87bed
MB		 1419
1420 ;; NOTE: This is what nnmail-group-pathname does as of Apr 2003.
1421 ;; The two methods must be kept synchronized, which is why
1422 ;; gnus-agent-group-pathname was added.
1423
1424 (setq group
1425 (nnheader-translate-file-chars
1426 (nnheader-replace-duplicate-chars-in-string
bf247b6e 1427 (nnheader-replace-chars-in-string
01c52d31 1428 (gnus-group-real-name (gnus-agent-decoded-group-name group))
23f87bed
MB		 1429 ?/ ?_)
1430 ?. ?_)))
1431 (if (or nnmail-use-long-file-names
1432 (file-directory-p (expand-file-name group (gnus-agent-directory))))
1433 group
01c52d31 1434 (nnheader-replace-chars-in-string group ?. ?/)))
23f87bed
MB		 1435
1436(defun gnus-agent-group-pathname (group)
1437 "Translate GROUP into a file name."
1438 ;; nnagent uses nnmail-group-pathname to read articles while
1439 ;; unplugged. The agent must, therefore, use the same directory
1440 ;; while plugged.
01c52d31
MB		 1441 (nnmail-group-pathname
1442 (gnus-group-real-name (gnus-agent-decoded-group-name group))
1443 (if gnus-command-method
1444 (gnus-agent-directory)
1445 (let ((gnus-command-method (gnus-find-method-for-group group)))
1446 (gnus-agent-directory)))))
df80b09f
LMI		 1447
1448(defun gnus-agent-get-function (method)
23f87bed
MB		 1449 (if (gnus-online method)
1450 (car method)
1451 (require 'nnagent)
1452 'nnagent))
1453
1454(defun gnus-agent-covered-methods ()
1455 "Return the subset of methods that are covered by the agent."
1456 (delq nil (mapcar #'gnus-server-to-method gnus-agent-covered-methods)))
df80b09f
LMI		 1457
1458;;; History functions
1459
1460(defun gnus-agent-history-buffer ()
1461 (cdr (assoc (gnus-agent-method) gnus-agent-history-buffers)))
1462
1463(defun gnus-agent-open-history ()
1464 (save-excursion
1465 (push (cons (gnus-agent-method)
1466 (set-buffer (gnus-get-buffer-create
1467 (format " *Gnus agent %s history*"
1468 (gnus-agent-method)))))
1469 gnus-agent-history-buffers)
16409b0b 1470 (mm-disable-multibyte) ;; everything is binary
df80b09f
LMI		 1471 (erase-buffer)
1472 (insert "\n")
1473 (let ((file (gnus-agent-lib-file "history")))
1474 (when (file-exists-p file)
16409b0b 1475 (nnheader-insert-file-contents file))
df80b09f
LMI		 1476 (set (make-local-variable 'gnus-agent-file-name) file))))
1477
df80b09f
LMI		 1478(defun gnus-agent-close-history ()
1479 (when (gnus-buffer-live-p gnus-agent-current-history)
1480 (kill-buffer gnus-agent-current-history)
1481 (setq gnus-agent-history-buffers
1482 (delq (assoc (gnus-agent-method) gnus-agent-history-buffers)
1483 gnus-agent-history-buffers))))
1484
df80b09f
LMI		 1485;;;
1486;;; Fetching
1487;;;
1488
1489(defun gnus-agent-fetch-articles (group articles)
1490 "Fetch ARTICLES from GROUP and put them into the Agent."
cc21c235
G		 1491 (when (and articles
1492 (gnus-online (gnus-group-method group)))
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)
c2e9e9ef 1551 pos crosses
01c52d31 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))
23f87bed
MB		 1605 (let ((coding-system-for-write
1606 gnus-agent-file-coding-system))
1607 (write-region (point-min) (point-max)
1608 (concat dir (number-to-string (caar pos)))
1609 nil 'silent))
1610
1611 (gnus-agent-append-to-list
1612 tail-fetched-articles (caar pos)))
1613 (widen)
1614 (setq pos (cdr pos)))))
1615
1616 (gnus-agent-save-alist group (cdr fetched-articles) date)
01c52d31
MB		 1617 (gnus-agent-update-files-total-fetched-for group (cdr fetched-articles))
1618
23f87bed
MB		 1619 (gnus-message 7 ""))
1620 (cdr fetched-articles))))))
1621
54506618
MB		 1622(defun gnus-agent-unfetch-articles (group articles)
1623 "Delete ARTICLES that were fetched from GROUP into the agent."
1624 (when articles
01c52d31
MB		 1625 (gnus-agent-with-refreshed-group
1626 group
1627 (gnus-agent-load-alist group)
1628 (let* ((alist (cons nil gnus-agent-article-alist))
1629 (articles (sort articles #'<))
1630 (next-possibility alist)
1631 (delete-this (pop articles)))
1632 (while (and (cdr next-possibility) delete-this)
1633 (let ((have-this (caar (cdr next-possibility))))
1634 (cond
1635 ((< delete-this have-this)
1636 (setq delete-this (pop articles)))
1637 ((= delete-this have-this)
1638 (let ((timestamp (cdar (cdr next-possibility))))
1639 (when timestamp
1640 (let* ((file-name (concat (gnus-agent-group-pathname group)
1641 (number-to-string have-this)))
1642 (size-file
1643 (float (or (and gnus-agent-total-fetched-hashtb
1644 (nth 7 (file-attributes file-name)))
1645 0)))
1646 (file-name-coding-system
1647 nnmail-pathname-coding-system))
1648 (delete-file file-name)
1649 (gnus-agent-update-files-total-fetched-for
1650 group (- size-file)))))
1651
1652 (setcdr next-possibility (cddr next-possibility)))
1653 (t
1654 (setq next-possibility (cdr next-possibility))))))
1655 (setq gnus-agent-article-alist (cdr alist))
1656 (gnus-agent-save-alist group)))))
54506618 1657
23f87bed
MB		 1658(defun gnus-agent-crosspost (crosses article &optional date)
1659 (setq date (or date t))
1660
df80b09f 1661 (let (gnus-agent-article-alist group alist beg end)
20a673b2 1662 (with-current-buffer gnus-agent-overview-buffer
df80b09f
LMI		 1663 (when (nnheader-find-nov-line article)
1664 (forward-word 1)
1665 (setq beg (point))
1666 (setq end (progn (forward-line 1) (point)))))
1667 (while crosses
1668 (setq group (caar crosses))
1669 (unless (setq alist (assoc group gnus-agent-group-alist))
1670 (push (setq alist (list group (gnus-agent-load-alist (caar crosses))))
1671 gnus-agent-group-alist))
23f87bed 1672 (setcdr alist (cons (cons (cdar crosses) date) (cdr alist)))
20a673b2
KY		 1673 (with-current-buffer (gnus-get-buffer-create
1674 (format " *Gnus agent overview %s*"group))
df80b09f
LMI		 1675 (when (= (point-max) (point-min))
1676 (push (cons group (current-buffer)) gnus-agent-buffer-alist)
1677 (ignore-errors
01c52d31
MB		 1678 (let ((file-name-coding-system nnmail-pathname-coding-system))
1679 (nnheader-insert-file-contents
1680 (gnus-agent-article-name ".overview" group)))))
df80b09f
LMI		 1681 (nnheader-find-nov-line (string-to-number (cdar crosses)))
1682 (insert (string-to-number (cdar crosses)))
23f87bed
MB		 1683 (insert-buffer-substring gnus-agent-overview-buffer beg end)
1684 (gnus-agent-check-overview-buffer))
1685 (setq crosses (cdr crosses)))))
1686
1687(defun gnus-agent-backup-overview-buffer ()
1688 (when gnus-newsgroup-name
1689 (let ((root (gnus-agent-article-name ".overview" gnus-newsgroup-name))
1690 (cnt 0)
01c52d31
MB		 1691 name
1692 (file-name-coding-system nnmail-pathname-coding-system))
23f87bed
MB		 1693 (while (file-exists-p
1694 (setq name (concat root "~"
1695 (int-to-string (setq cnt (1+ cnt))) "~"))))
1696 (write-region (point-min) (point-max) name nil 'no-msg)
1697 (gnus-message 1 "Created backup copy of overview in %s." name)))
1698 t)
1699
1700(defun gnus-agent-check-overview-buffer (&optional buffer)
1701 "Check the overview file given for sanity.
1702In particular, checks that the file is sorted by article number
1703and that there are no duplicates."
1704 (let ((prev-num -1)
1705 (backed-up nil))
1706 (save-excursion
1707 (when buffer
1708 (set-buffer buffer))
1709 (save-restriction
1710 (widen)
1711 (goto-char (point-min))
1712
1713 (while (< (point) (point-max))
1714 (let ((p (point))
1715 (cur (condition-case nil
1716 (read (current-buffer))
1717 (error nil))))
1718 (cond
1719 ((or (not (integerp cur))
1720 (not (eq (char-after) ?\t)))
1721 (or backed-up
1722 (setq backed-up (gnus-agent-backup-overview-buffer)))
1723 (gnus-message 1
1724 "Overview buffer contains garbage '%s'."
1725 (buffer-substring
01c52d31 1726 p (point-at-eol))))
23f87bed
MB		 1727 ((= cur prev-num)
1728 (or backed-up
1729 (setq backed-up (gnus-agent-backup-overview-buffer)))
1730 (gnus-message 1
1731 "Duplicate overview line for %d" cur)
54506618 1732 (delete-region p (progn (forward-line 1) (point))))
23f87bed
MB		 1733 ((< cur prev-num)
1734 (or backed-up
1735 (setq backed-up (gnus-agent-backup-overview-buffer)))
1736 (gnus-message 1 "Overview buffer not sorted!")
1737 (sort-numeric-fields 1 (point-min) (point-max))
1738 (goto-char (point-min))
1739 (setq prev-num -1))
1740 (t
1741 (setq prev-num cur)))
1742 (forward-line 1)))))))
df80b09f 1743
01c52d31
MB		 1744(defun gnus-agent-flush-server (&optional server-or-method)
1745 "Flush all agent index files for every subscribed group within
1746 the given SERVER-OR-METHOD. When called with nil, the current
1747 value of gnus-command-method identifies the server."
1748 (let* ((gnus-command-method (if server-or-method
1749 (gnus-server-to-method server-or-method)
1750 gnus-command-method))
1751 (alist gnus-newsrc-alist))
1752 (while alist
1753 (let ((entry (pop alist)))
1754 (when (gnus-methods-equal-p gnus-command-method (gnus-info-method entry))
c9fc72fa 1755 (gnus-agent-flush-group (gnus-info-group entry)))))))
01c52d31
MB		 1756
1757(defun gnus-agent-flush-group (group)
1758 "Flush the agent's index files such that the GROUP no longer
1759appears to have any local content. The actual content, the
1760article files, may then be deleted using gnus-agent-expire-group.
1761If flushing was a mistake, the gnus-agent-regenerate-group method
1762provides an undo mechanism by reconstructing the index files from
1763the article files."
1764 (interactive (list (gnus-agent-read-group)))
1765
1766 (let* ((gnus-command-method (or gnus-command-method
1767 (gnus-find-method-for-group group)))
1768 (overview (gnus-agent-article-name ".overview" group))
1769 (agentview (gnus-agent-article-name ".agentview" group))
1770 (file-name-coding-system nnmail-pathname-coding-system))
1771
1772 (if (file-exists-p overview)
1773 (delete-file overview))
1774 (if (file-exists-p agentview)
1775 (delete-file agentview))
1776
1777 (gnus-agent-update-view-total-fetched-for group nil gnus-command-method)
1778 (gnus-agent-update-view-total-fetched-for group t gnus-command-method)
1779
1780 ;(gnus-agent-set-local group nil nil)
1781 ;(gnus-agent-save-local t)
1782 (gnus-agent-save-group-info nil group nil)))
1783
df80b09f 1784(defun gnus-agent-flush-cache ()
01c52d31
MB		 1785 "Flush the agent's index files such that the group no longer
1786appears to have any local content. The actual content, the
1787article files, is then deleted using gnus-agent-expire-group. The
1788gnus-agent-regenerate-group method provides an undo mechanism by
1789reconstructing the index files from the article files."
1790 (interactive)
df80b09f 1791 (save-excursion
01c52d31
MB		 1792 (let ((file-name-coding-system nnmail-pathname-coding-system))
1793 (while gnus-agent-buffer-alist
1794 (set-buffer (cdar gnus-agent-buffer-alist))
1795 (let ((coding-system-for-write gnus-agent-file-coding-system))
1796 (write-region (point-min) (point-max)
1797 (gnus-agent-article-name ".overview"
1798 (caar gnus-agent-buffer-alist))
1799 nil 'silent))
1800 (setq gnus-agent-buffer-alist (cdr gnus-agent-buffer-alist)))
1801 (while gnus-agent-group-alist
1802 (with-temp-file (gnus-agent-article-name
1803 ".agentview" (caar gnus-agent-group-alist))
1804 (princ (cdar gnus-agent-group-alist))
1805 (insert "\n")
1806 (princ 1 (current-buffer))
1807 (insert "\n"))
1808 (setq gnus-agent-group-alist (cdr gnus-agent-group-alist))))))
23f87bed 1809
54506618 1810;;;###autoload
23f87bed
MB		 1811(defun gnus-agent-find-parameter (group symbol)
1812 "Search for GROUPs SYMBOL in the group's parameters, the group's
1813topic parameters, the group's category, or the customizable
1814variables. Returns the first non-nil value found."
1815 (or (gnus-group-find-parameter group symbol t)
1816 (gnus-group-parameter-value (cdr (gnus-group-category group)) symbol t)
1817 (symbol-value
1818 (cdr
1819 (assq symbol
1820 '((agent-short-article . gnus-agent-short-article)
1821 (agent-long-article . gnus-agent-long-article)
1822 (agent-low-score . gnus-agent-low-score)
1823 (agent-high-score . gnus-agent-high-score)
1824 (agent-days-until-old . gnus-agent-expire-days)
1825 (agent-enable-expiration
1826 . gnus-agent-enable-expiration)
1827 (agent-predicate . gnus-agent-predicate)))))))
16409b0b 1828
c2e9e9ef 1829(defun gnus-agent-fetch-headers (group)
23f87bed
MB		 1830 "Fetch interesting headers into the agent. The group's overview
1831file will be updated to include the headers while a list of available
1832article numbers will be returned."
1833 (let* ((fetch-all (and gnus-agent-consider-all-articles
1834 ;; Do not fetch all headers if the predicate
1835 ;; implies that we only consider unread articles.
1836 (not (gnus-predicate-implies-unread
1837 (gnus-agent-find-parameter group
1838 'agent-predicate)))))
1839 (articles (if fetch-all
4b70e299 1840 (if gnus-newsgroup-maximum-articles
11abff8e
MB		 1841 (let ((active (gnus-active group)))
1842 (gnus-uncompress-range
1843 (cons (max (car active)
1844 (- (cdr active)
4b70e299
MB		 1845 gnus-newsgroup-maximum-articles
1846 -1))
11abff8e
MB		 1847 (cdr active))))
1848 (gnus-uncompress-range (gnus-active group)))
23f87bed
MB		 1849 (gnus-list-of-unread-articles group)))
1850 (gnus-decode-encoded-word-function 'identity)
5cedca8d 1851 (gnus-decode-encoded-address-function 'identity)
01c52d31
MB		 1852 (file (gnus-agent-article-name ".overview" group))
1853 (file-name-coding-system nnmail-pathname-coding-system))
23f87bed
MB		 1854
1855 (unless fetch-all
1856 ;; Add articles with marks to the list of article headers we want to
1857 ;; fetch. Don't fetch articles solely on the basis of a recent or seen
1858 ;; mark, but do fetch recent or seen articles if they have other, more
1859 ;; interesting marks. (We have to fetch articles with boring marks
1860 ;; because otherwise the agent will remove their marks.)
1861 (dolist (arts (gnus-info-marks (gnus-get-info group)))
1862 (unless (memq (car arts) '(seen recent killed cache))
1863 (setq articles (gnus-range-add articles (cdr arts)))))
1864 (setq articles (sort (gnus-uncompress-sequence articles) '<)))
1865
1866 ;; At this point, I have the list of articles to consider for
1867 ;; fetching. This is the list that I'll return to my caller. Some
1868 ;; of these articles may have already been fetched. That's OK as
1869 ;; the fetch article code will filter those out. Internally, I'll
1870 ;; filter this list to just those articles whose headers need to
1871 ;; be fetched.
1872 (let ((articles articles))
1873 ;; Remove known articles.
1874 (when (and (or gnus-agent-cache
1875 (not gnus-plugged))
1876 (gnus-agent-load-alist group))
1877 ;; Remove articles marked as downloaded.
1878 (if fetch-all
1879 ;; I want to fetch all headers in the active range.
1880 ;; Therefore, exclude only those headers that are in the
1881 ;; article alist.
1882 ;; NOTE: This is probably NOT what I want to do after
1883 ;; agent expiration in this group.
1884 (setq articles (gnus-agent-uncached-articles articles group))
1885
1886 ;; I want to only fetch those headers that have never been
1887 ;; fetched. Therefore, exclude all headers that are, or
1888 ;; WERE, in the article alist.
1889 (let ((low (1+ (caar (last gnus-agent-article-alist))))
1890 (high (cdr (gnus-active group))))
1891 ;; Low can be greater than High when the same group is
1892 ;; fetched twice in the same session {The first fetch will
1893 ;; fill the article alist such that (last
1894 ;; gnus-agent-article-alist) equals (cdr (gnus-active
1895 ;; group))}. The addition of one(the 1+ above) then
1896 ;; forces Low to be greater than High. When this happens,
1897 ;; gnus-list-range-intersection returns nil which
1898 ;; indicates that no headers need to be fetched. -- Kevin
1899 (setq articles (gnus-list-range-intersection
1900 articles (list (cons low high)))))))
1901
a5954fa5
G		 1902 (when articles
1903 (gnus-message
1904 10 "gnus-agent-fetch-headers: undownloaded articles are '%s'"
1905 (gnus-compress-sequence articles t)))
23f87bed 1906
20a673b2 1907 (with-current-buffer nntp-server-buffer
23f87bed
MB		 1908 (if articles
1909 (progn
0afb49a1 1910 (gnus-message 8 "Fetching headers for %s..."
ec7995fa 1911 (gnus-agent-decoded-group-name group))
23f87bed
MB		 1912
1913 ;; Fetch them.
1914 (gnus-make-directory (nnheader-translate-file-chars
1915 (file-name-directory file) t))
1916
1917 (unless (eq 'nov (gnus-retrieve-headers articles group))
1918 (nnvirtual-convert-headers))
1919 (gnus-agent-check-overview-buffer)
1920 ;; Move these headers to the overview buffer so that
1921 ;; gnus-agent-braid-nov can merge them with the contents
1922 ;; of FILE.
1923 (copy-to-buffer
1924 gnus-agent-overview-buffer (point-min) (point-max))
54506618
MB		 1925 ;; NOTE: Call g-a-brand-nov even when the file does not
1926 ;; exist. As a minimum, it will validate the article
1927 ;; numbers already in the buffer.
c2e9e9ef 1928 (gnus-agent-braid-nov articles file)
23f87bed
MB		 1929 (let ((coding-system-for-write
1930 gnus-agent-file-coding-system))
1931 (gnus-agent-check-overview-buffer)
1932 (write-region (point-min) (point-max) file nil 'silent))
01c52d31 1933 (gnus-agent-update-view-total-fetched-for group t)
23f87bed
MB		 1934 (gnus-agent-save-alist group articles nil)
1935 articles)
1936 (ignore-errors
1937 (erase-buffer)
1938 (nnheader-insert-file-contents file)))))
1939 articles))
df80b09f 1940
54506618
MB		 1941(defsubst gnus-agent-read-article-number ()
1942 "Reads the article number at point. Returns nil when a valid article number can not be read."
1943
58090a8d 1944 ;; It is unfortunate but the read function quietly overflows
54506618
MB		 1945 ;; integer. As a result, I have to use string operations to test
1946 ;; for overflow BEFORE calling read.
1947 (when (looking-at "[0-9]+\t")
1948 (let ((len (- (match-end 0) (match-beginning 0))))
1949 (cond ((< len 9)
1950 (read (current-buffer)))
1951 ((= len 9)
1952 ;; Many 9 digit base-10 numbers can be represented in a 27-bit int
1953 ;; Back convert from int to string to ensure that this is one of them.
1954 (let* ((str1 (buffer-substring (match-beginning 0) (1- (match-end 0))))
1955 (num (read (current-buffer)))
1956 (str2 (int-to-string num)))
1957 (when (equal str1 str2)
1958 num)))))))
1959
df80b09f 1960(defsubst gnus-agent-copy-nov-line (article)
54506618 1961 "Copy the indicated ARTICLE from the overview buffer to the nntp server buffer."
23f87bed 1962 (let (art b e)
df80b09f 1963 (set-buffer gnus-agent-overview-buffer)
23f87bed 1964 (while (and (not (eobp))
54506618
MB		 1965 (or (not (setq art (gnus-agent-read-article-number)))
1966 (< art article)))
23f87bed
MB		 1967 (forward-line 1))
1968 (beginning-of-line)
1969 (if (or (eobp)
1970 (not (eq article art)))
1971 (set-buffer nntp-server-buffer)
1972 (setq b (point))
1973 (setq e (progn (forward-line 1) (point)))
1974 (set-buffer nntp-server-buffer)
1975 (insert-buffer-substring gnus-agent-overview-buffer b e))))
df80b09f 1976
c2e9e9ef 1977(defun gnus-agent-braid-nov (articles file)
23f87bed 1978 "Merge agent overview data with given file.
54506618
MB		 1979Takes unvalidated headers for ARTICLES from
1980`gnus-agent-overview-buffer' and validated headers from the given
1981FILE and places the combined valid headers into
1982`nntp-server-buffer'. This function can be used, when file
1983doesn't exist, to valid the overview buffer."
23f87bed
MB		 1984 (let (start last)
1985 (set-buffer gnus-agent-overview-buffer)
1986 (goto-char (point-min))
1987 (set-buffer nntp-server-buffer)
1988 (erase-buffer)
54506618
MB		 1989 (when (file-exists-p file)
1990 (nnheader-insert-file-contents file))
23f87bed
MB		 1991 (goto-char (point-max))
1992 (forward-line -1)
54506618 1993
23f87bed
MB		 1994 (unless (or (= (point-min) (point-max))
1995 (< (setq last (read (current-buffer))) (car articles)))
54506618 1996 ;; Old and new overlap -- We do it the hard way.
23f87bed
MB		 1997 (when (nnheader-find-nov-line (car articles))
1998 ;; Replacing existing NOV entry
1999 (delete-region (point) (progn (forward-line 1) (point))))
2000 (gnus-agent-copy-nov-line (pop articles))
2001
2002 (ignore-errors
01c52d31
MB		 2003 (while articles
2004 (while (let ((art (read (current-buffer))))
2005 (cond ((< art (car articles))
2006 (forward-line 1)
2007 t)
2008 ((= art (car articles))
2009 (beginning-of-line)
2010 (delete-region
2011 (point) (progn (forward-line 1) (point)))
2012 nil)
2013 (t
2014 (beginning-of-line)
2015 nil))))
54506618 2016
01c52d31 2017 (gnus-agent-copy-nov-line (pop articles)))))
54506618 2018
23f87bed 2019 (goto-char (point-max))
54506618
MB		 2020
2021 ;; Append the remaining lines
df80b09f 2022 (when articles
23f87bed 2023 (when last
df80b09f 2024 (set-buffer gnus-agent-overview-buffer)
23f87bed
MB		 2025 (setq start (point))
2026 (set-buffer nntp-server-buffer))
54506618
MB		 2027
2028 (let ((p (point)))
2029 (insert-buffer-substring gnus-agent-overview-buffer start)
2030 (goto-char p))
2031
2032 (setq last (or last -134217728))
58090a8d 2033 (while (catch 'problems
01c52d31
MB		 2034 (let (sort art)
2035 (while (not (eobp))
2036 (setq art (gnus-agent-read-article-number))
2037 (cond ((not art)
2038 ;; Bad art num - delete this line
2039 (beginning-of-line)
2040 (delete-region (point) (progn (forward-line 1) (point))))
2041 ((< art last)
2042 ;; Art num out of order - enable sort
2043 (setq sort t)
2044 (forward-line 1))
58090a8d
MB		 2045 ((= art last)
2046 ;; Bad repeat of art number - delete this line
2047 (beginning-of-line)
2048 (delete-region (point) (progn (forward-line 1) (point))))
01c52d31
MB		 2049 (t
2050 ;; Good art num
2051 (setq last art)
2052 (forward-line 1))))
2053 (when sort
58090a8d
MB		 2054 ;; something is seriously wrong as we simply shouldn't see out-of-order data.
2055 ;; First, we'll fix the sort.
2056 (sort-numeric-fields 1 (point-min) (point-max))
2057
655591a7 2058 ;; but now we have to consider that we may have duplicate rows...
58090a8d
MB		 2059 ;; so reset to beginning of file
2060 (goto-char (point-min))
2061 (setq last -134217728)
655591a7 2062
58090a8d
MB		 2063 ;; and throw a code that restarts this scan
2064 (throw 'problems t))
2065 nil))))))
df80b09f 2066
23f87bed
MB		 2067;; Keeps the compiler from warning about the free variable in
2068;; gnus-agent-read-agentview.
9efa445f 2069(defvar gnus-agent-read-agentview)
df80b09f 2070
23f87bed
MB		 2071(defun gnus-agent-load-alist (group)
2072 "Load the article-state alist for GROUP."
2073 ;; Bind free variable that's used in `gnus-agent-read-agentview'.
c25d60ab
LMI		 2074 (let* ((gnus-agent-read-agentview group)
2075 (file-name-coding-system nnmail-pathname-coding-system)
2076 (agentview (gnus-agent-article-name ".agentview" group)))
e8861cd2
LMI		 2077 (setq gnus-agent-article-alist
2078 (and (file-exists-p agentview)
2079 (gnus-cache-file-contents
2080 agentview
2081 'gnus-agent-file-loading-cache
2082 'gnus-agent-read-agentview)))))
23f87bed 2083
23f87bed
MB		 2084(defun gnus-agent-read-agentview (file)
2085 "Load FILE and do a `read' there."
2086 (with-temp-buffer
54506618 2087 (condition-case nil
01c52d31
MB		 2088 (progn
2089 (nnheader-insert-file-contents file)
2090 (goto-char (point-min))
2091 (let ((alist (read (current-buffer)))
2092 (version (condition-case nil (read (current-buffer))
2093 (end-of-file 0)))
2094 changed-version)
2095
2096 (cond
2097 ((= version 0)
2098 (let ((inhibit-quit t)
2099 entry)
2100 (gnus-agent-open-history)
2101 (set-buffer (gnus-agent-history-buffer))
2102 (goto-char (point-min))
2103 (while (not (eobp))
2104 (if (and (looking-at
2105 "[^\t\n]+\t\\([0-9]+\\)\t\\([^ \n]+\\) \\([0-9]+\\)")
2106 (string= (match-string 2)
2107 gnus-agent-read-agentview)
2108 (setq entry (assoc (string-to-number (match-string 3)) alist)))
2109 (setcdr entry (string-to-number (match-string 1))))
2110 (forward-line 1))
2111 (gnus-agent-close-history)
2112 (setq changed-version t)))
2113 ((= version 1)
2114 (setq changed-version (not (= 1 gnus-agent-article-alist-save-format))))
2115 ((= version 2)
2116 (let (state sequence uncomp)
2117 (while alist
2118 (setq state (caar alist)
2119 sequence (inline (gnus-uncompress-range (cdar alist)))
2120 alist (cdr alist))
2121 (while sequence
2122 (push (cons (pop sequence) state) uncomp)))
58090a8d
MB		 2123 (setq alist (sort uncomp 'car-less-than-car)))
2124 (setq changed-version (not (= 2 gnus-agent-article-alist-save-format)))))
01c52d31
MB		 2125 (when changed-version
2126 (let ((gnus-agent-article-alist alist))
2127 (gnus-agent-save-alist gnus-agent-read-agentview)))
2128 alist))
2129 ((end-of-file file-error)
c9fc72fa 2130 ;; The agentview file is missing.
01c52d31
MB		 2131 (condition-case nil
2132 ;; If the agent directory exists, attempt to perform a brute-force
2133 ;; reconstruction of its contents.
2134 (let* (alist
2135 (file-name-coding-system nnmail-pathname-coding-system)
c9fc72fa 2136 (file-attributes (directory-files-and-attributes
01c52d31
MB		 2137 (gnus-agent-article-name ""
2138 gnus-agent-read-agentview) nil "^[0-9]+$" t)))
2139 (while file-attributes
2140 (let ((fa (pop file-attributes)))
2141 (unless (nth 1 fa)
2142 (push (cons (string-to-number (nth 0 fa)) (time-to-days (nth 5 fa))) alist))))
2143 alist)
2144 (file-error nil))))))
23f87bed
MB		 2145
2146(defun gnus-agent-save-alist (group &optional articles state)
df80b09f 2147 "Save the article-state alist for GROUP."
23f87bed
MB		 2148 (let* ((file-name-coding-system nnmail-pathname-coding-system)
2149 (prev (cons nil gnus-agent-article-alist))
2150 (all prev)
c2e9e9ef 2151 print-level print-length article)
23f87bed
MB		 2152 (while (setq article (pop articles))
2153 (while (and (cdr prev)
2154 (< (caadr prev) article))
2155 (setq prev (cdr prev)))
2156 (cond
2157 ((not (cdr prev))
2158 (setcdr prev (list (cons article state))))
2159 ((> (caadr prev) article)
2160 (setcdr prev (cons (cons article state) (cdr prev))))
2161 ((= (caadr prev) article)
2162 (setcdr (cadr prev) state)))
2163 (setq prev (cdr prev)))
2164 (setq gnus-agent-article-alist (cdr all))
2165
bf247b6e
KS		 2166 (gnus-agent-set-local group
2167 (caar gnus-agent-article-alist)
23f87bed
MB		 2168 (caar (last gnus-agent-article-alist)))
2169
2170 (gnus-make-directory (gnus-agent-article-name "" group))
2171 (with-temp-file (gnus-agent-article-name ".agentview" group)
2172 (cond ((eq gnus-agent-article-alist-save-format 1)
2173 (princ gnus-agent-article-alist (current-buffer)))
2174 ((eq gnus-agent-article-alist-save-format 2)
01c52d31
MB		 2175 (let ((alist gnus-agent-article-alist)
2176 article-id day-of-download comp-list compressed)
2177 (while alist
2178 (setq article-id (caar alist)
2179 day-of-download (cdar alist)
2180 comp-list (assq day-of-download compressed)
2181 alist (cdr alist))
2182 (if comp-list
2183 (setcdr comp-list (cons article-id (cdr comp-list)))
2184 (push (list day-of-download article-id) compressed)))
2185 (setq alist compressed)
2186 (while alist
2187 (setq comp-list (pop alist))
2188 (setcdr comp-list
2189 (gnus-compress-sequence (nreverse (cdr comp-list)))))
23f87bed
MB		 2190 (princ compressed (current-buffer)))))
2191 (insert "\n")
2192 (princ gnus-agent-article-alist-save-format (current-buffer))
01c52d31
MB		 2193 (insert "\n"))
2194
2195 (gnus-agent-update-view-total-fetched-for group nil)))
23f87bed
MB		 2196
2197(defvar gnus-agent-article-local nil)
4469385c 2198(defvar gnus-agent-article-local-times nil)
23f87bed
MB		 2199(defvar gnus-agent-file-loading-local nil)
2200
2201(defun gnus-agent-load-local (&optional method)
2202 "Load the METHOD'S local file. The local file contains min/max
2203article counts for each of the method's subscribed groups."
2204 (let ((gnus-command-method (or method gnus-command-method)))
4469385c 2205 (when (or (null gnus-agent-article-local-times)
9937bef4
G		 2206 (zerop gnus-agent-article-local-times)
2207 (not (gnus-methods-equal-p
2208 gnus-command-method
2209 (symbol-value (intern "+method" gnus-agent-article-local)))))
4469385c
LMI		 2210 (setq gnus-agent-article-local
2211 (gnus-cache-file-contents
2212 (gnus-agent-lib-file "local")
2213 'gnus-agent-file-loading-local
2214 'gnus-agent-read-and-cache-local))
2215 (when gnus-agent-article-local-times
2216 (incf gnus-agent-article-local-times)))
2217 gnus-agent-article-local))
23f87bed
MB		 2218
2219(defun gnus-agent-read-and-cache-local (file)
2220 "Load and read FILE then bind its contents to
2221gnus-agent-article-local. If that variable had `dirty' (also known as
2222modified) original contents, they are first saved to their own file."
23f87bed
MB		 2223 (if (and gnus-agent-article-local
2224 (symbol-value (intern "+dirty" gnus-agent-article-local)))
2225 (gnus-agent-save-local))
2226 (gnus-agent-read-local file))
2227
2228(defun gnus-agent-read-local (file)
2229 "Load FILE and do a `read' there."
bf247b6e 2230 (let ((my-obarray (gnus-make-hashtable (count-lines (point-min)
23f87bed
MB		 2231 (point-max))))
2232 (line 1))
2233 (with-temp-buffer
2234 (condition-case nil
54506618
MB		 2235 (let ((nnheader-file-coding-system gnus-agent-file-coding-system))
2236 (nnheader-insert-file-contents file))
23f87bed
MB		 2237 (file-error))
2238
2239 (goto-char (point-min))
2240 ;; Skip any comments at the beginning of the file (the only place where they may appear)
2241 (while (= (following-char) ?\;)
2242 (forward-line 1)
2243 (setq line (1+ line)))
2244
2245 (while (not (eobp))
2246 (condition-case err
bf247b6e 2247 (let (group
23f87bed
MB		 2248 min
2249 max
26c9afc3
MB		 2250 (cur (current-buffer))
2251 (obarray my-obarray))
23f87bed
MB		 2252 (setq group (read cur)
2253 min (read cur)
2254 max (read cur))
2255
2256 (when (stringp group)
2257 (setq group (intern group my-obarray)))
2258
2259 ;; NOTE: The '+ 0' ensure that min and max are both numerics.
2260 (set group (cons (+ 0 min) (+ 0 max))))
2261 (error
58090a8d 2262 (gnus-message 3 "Warning - invalid agent local: %s on line %d: %s"
23f87bed
MB		 2263 file line (error-message-string err))))
2264 (forward-line 1)
2265 (setq line (1+ line))))
bf247b6e 2266
23f87bed
MB		 2267 (set (intern "+dirty" my-obarray) nil)
2268 (set (intern "+method" my-obarray) gnus-command-method)
2269 my-obarray))
2270
2271(defun gnus-agent-save-local (&optional force)
2272 "Save gnus-agent-article-local under it method's agent.lib directory."
2273 (let ((my-obarray gnus-agent-article-local))
2274 (when (and my-obarray
2275 (or force (symbol-value (intern "+dirty" my-obarray))))
2276 (let* ((gnus-command-method (symbol-value (intern "+method" my-obarray)))
2277 ;; NOTE: gnus-command-method is used within gnus-agent-lib-file.
2278 (dest (gnus-agent-lib-file "local")))
2279 (gnus-make-directory (gnus-agent-lib-file ""))
54506618 2280
01c52d31
MB		 2281 (let ((coding-system-for-write gnus-agent-file-coding-system)
2282 (file-name-coding-system nnmail-pathname-coding-system))
54506618
MB		 2283 (with-temp-file dest
2284 (let ((gnus-command-method (symbol-value (intern "+method" my-obarray)))
c2e9e9ef 2285 print-level print-length
54506618
MB		 2286 (standard-output (current-buffer)))
2287 (mapatoms (lambda (symbol)
2288 (cond ((not (boundp symbol))
2289 nil)
2290 ((member (symbol-name symbol) '("+dirty" "+method"))
2291 nil)
2292 (t
54506618 2293 (let ((range (symbol-value symbol)))
58090a8d 2294 (when range
01c52d31
MB		 2295 (prin1 symbol)
2296 (princ " ")
2297 (princ (car range))
2298 (princ " ")
2299 (princ (cdr range))
58090a8d 2300 (princ "\n"))))))
54506618
MB		 2301 my-obarray))))))))
2302
2303(defun gnus-agent-get-local (group &optional gmane method)
2304 (let* ((gmane (or gmane (gnus-group-real-name group)))
2305 (gnus-command-method (or method (gnus-find-method-for-group group)))
23f87bed
MB		 2306 (local (gnus-agent-load-local))
2307 (symb (intern gmane local))
2308 (minmax (and (boundp symb) (symbol-value symb))))
2309 (unless minmax
2310 ;; Bind these so that gnus-agent-load-alist doesn't change the
2311 ;; current alist (i.e. gnus-agent-article-alist)
2312 (let* ((gnus-agent-article-alist gnus-agent-article-alist)
2313 (gnus-agent-file-loading-cache gnus-agent-file-loading-cache)
2314 (alist (gnus-agent-load-alist group)))
2315 (when alist
2316 (setq minmax
2317 (cons (caar alist)
2318 (caar (last alist))))
bf247b6e 2319 (gnus-agent-set-local group (car minmax) (cdr minmax)
23f87bed
MB		 2320 gmane gnus-command-method local))))
2321 minmax))
2322
2323(defun gnus-agent-set-local (group min max &optional gmane method local)
2324 (let* ((gmane (or gmane (gnus-group-real-name group)))
2325 (gnus-command-method (or method (gnus-find-method-for-group group)))
2326 (local (or local (gnus-agent-load-local)))
2327 (symb (intern gmane local))
2328 (minmax (and (boundp symb) (symbol-value symb))))
23f87bed
MB		 2329 (if (cond ((and minmax
2330 (or (not (eq min (car minmax)))
26c9afc3
MB		 2331 (not (eq max (cdr minmax))))
2332 min
2333 max)
23f87bed
MB		 2334 (setcar minmax min)
2335 (setcdr minmax max)
2336 t)
2337 (minmax
2338 nil)
2339 ((and min max)
2340 (set symb (cons min max))
54506618
MB		 2341 t)
2342 (t
2343 (unintern symb local)))
23f87bed 2344 (set (intern "+dirty" local) t))))
df80b09f
LMI		 2345
2346(defun gnus-agent-article-name (article group)
23f87bed 2347 (expand-file-name article
850846fd 2348 (file-name-as-directory
23f87bed 2349 (gnus-agent-group-pathname group))))
df80b09f 2350
16409b0b
GM		 2351(defun gnus-agent-batch-confirmation (msg)
2352 "Show error message and return t."
bdaa75c7 2353 (gnus-message 1 "%s" msg)
16409b0b
GM		 2354 t)
2355
df80b09f
LMI		 2356;;;###autoload
2357(defun gnus-agent-batch-fetch ()
2358 "Start Gnus and fetch session."
2359 (interactive)
2360 (gnus)
16409b0b
GM		 2361 (let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation))
2362 (gnus-agent-fetch-session))
df80b09f
LMI		 2363 (gnus-group-exit))
2364
2365(defun gnus-agent-fetch-session ()
2366 "Fetch all articles and headers that are eligible for fetching."
2367 (interactive)
2368 (unless gnus-agent-covered-methods
2369 (error "No servers are covered by the Gnus agent"))
2370 (unless gnus-plugged
2371 (error "Can't fetch articles while Gnus is unplugged"))
23f87bed 2372 (let ((methods (gnus-agent-covered-methods))
df80b09f
LMI		 2373 groups group gnus-command-method)
2374 (save-excursion
2375 (while methods
23f87bed
MB		 2376 (setq gnus-command-method (car methods))
2377 (when (and (or (gnus-server-opened gnus-command-method)
2378 (gnus-open-server gnus-command-method))
2379 (gnus-online gnus-command-method))
2380 (setq groups (gnus-groups-from-server (car methods)))
2381 (gnus-agent-with-fetch
2382 (while (setq group (pop groups))
2383 (when (<= (gnus-group-level group)
2384 gnus-agent-handle-level)
2385 (if (or debug-on-error debug-on-quit)
2386 (gnus-agent-fetch-group-1
2387 group gnus-command-method)
2388 (condition-case err
2389 (gnus-agent-fetch-group-1
2390 group gnus-command-method)
2391 (error
2392 (unless (funcall gnus-agent-confirmation-function
54506618 2393 (format "Error %s while fetching session. Should gnus continue? "
23f87bed
MB		 2394 (error-message-string err)))
2395 (error "Cannot fetch articles into the Gnus agent")))
2396 (quit
54506618 2397 (gnus-agent-regenerate-group group)
23f87bed
MB		 2398 (unless (funcall gnus-agent-confirmation-function
2399 (format
54506618 2400 "%s while fetching session. Should gnus continue? "
23f87bed
MB		 2401 (error-message-string err)))
2402 (signal 'quit
2403 "Cannot fetch articles into the Gnus agent")))))))))
2404 (setq methods (cdr methods)))
2405 (gnus-run-hooks 'gnus-agent-fetched-hook)
df80b09f
LMI		 2406 (gnus-message 6 "Finished fetching articles into the Gnus agent"))))
2407
c2e9e9ef
SM		 2408(defvar gnus-agent-short-article 500
2409 "Articles that have fewer lines than this are short.")
2410
2411(defvar gnus-agent-long-article 1000
2412 "Articles that have more lines than this are long.")
2413
2414(defvar gnus-agent-low-score 0
2415 "Articles that have a score lower than this have a low score.")
2416
2417(defvar gnus-agent-high-score 0
2418 "Articles that have a score higher than this have a high score.")
2419
df80b09f
LMI		 2420(defun gnus-agent-fetch-group-1 (group method)
2421 "Fetch GROUP."
2422 (let ((gnus-command-method method)
16409b0b 2423 (gnus-newsgroup-name group)
23f87bed
MB		 2424 (gnus-newsgroup-dependencies gnus-newsgroup-dependencies)
2425 (gnus-newsgroup-headers gnus-newsgroup-headers)
2426 (gnus-newsgroup-scored gnus-newsgroup-scored)
2427 (gnus-use-cache gnus-use-cache)
16409b0b
GM		 2428 (gnus-summary-expunge-below gnus-summary-expunge-below)
2429 (gnus-summary-mark-below gnus-summary-mark-below)
2430 (gnus-orphan-score gnus-orphan-score)
2431 ;; Maybe some other gnus-summary local variables should also
2432 ;; be put here.
23f87bed
MB		 2433
2434 gnus-headers
2435 gnus-score
c2e9e9ef
SM		 2436 articles
2437 predicate info marks
16409b0b
GM		 2438 )
2439 (unless (gnus-check-group group)
2440 (error "Can't open server for %s" group))
23f87bed 2441
df80b09f 2442 ;; Fetch headers.
23f87bed
MB		 2443 (when (or gnus-newsgroup-active
2444 (gnus-active group)
2445 (gnus-activate-group group))
2446 (let ((marked-articles gnus-newsgroup-downloadable))
2447 ;; Identify the articles marked for download
2448 (unless gnus-newsgroup-active
2449 ;; The variable gnus-newsgroup-active was selected as I need
2450 ;; a gnus-summary local variable that is NOT bound to any
2451 ;; value (its global value should default to nil).
2452 (dolist (mark gnus-agent-download-marks)
2453 (let ((arts (cdr (assq mark (gnus-info-marks
2454 (setq info (gnus-get-info group)))))))
2455 (when arts
2456 (setq marked-articles (nconc (gnus-uncompress-range arts)
2457 marked-articles))
2458 ))))
2459 (setq marked-articles (sort marked-articles '<))
2460
2461 ;; Fetch any new articles from the server
2462 (setq articles (gnus-agent-fetch-headers group))
2463
2464 ;; Merge new articles with marked
2465 (setq articles (sort (append marked-articles articles) '<))
2466
2467 (when articles
2468 ;; Parse them and see which articles we want to fetch.
2469 (setq gnus-newsgroup-dependencies
2470 (or gnus-newsgroup-dependencies
2471 (make-vector (length articles) 0)))
2472 (setq gnus-newsgroup-headers
2473 (or gnus-newsgroup-headers
2474 (gnus-get-newsgroup-headers-xover articles nil nil
2475 group)))
2476 ;; `gnus-agent-overview-buffer' may be killed for
2477 ;; timeout reason. If so, recreate it.
2478 (gnus-agent-create-buffer)
2479
23f87bed
MB		 2480 (setq predicate
2481 (gnus-get-predicate
2482 (gnus-agent-find-parameter group 'agent-predicate)))
2483
2484 ;; If the selection predicate requires scoring, score each header
2485 (unless (memq predicate '(gnus-agent-true gnus-agent-false))
2486 (let ((score-param
2487 (gnus-agent-find-parameter group 'agent-score-file)))
2488 ;; Translate score-param into real one
2489 (cond
2490 ((not score-param))
2491 ((eq score-param 'file)
2492 (setq score-param (gnus-all-score-files group)))
2493 ((stringp (car score-param)))
2494 (t
2495 (setq score-param (list (list score-param)))))
2496 (when score-param
2497 (gnus-score-headers score-param))))
2498
2499 (unless (and (eq predicate 'gnus-agent-false)
2500 (not marked-articles))
2501 (let ((arts (list nil)))
2502 (let ((arts-tail arts)
2503 (alist (gnus-agent-load-alist group))
2504 (marked-articles marked-articles)
2505 (gnus-newsgroup-headers gnus-newsgroup-headers))
2506 (while (setq gnus-headers (pop gnus-newsgroup-headers))
2507 (let ((num (mail-header-number gnus-headers)))
2508 ;; Determine if this article is already in the cache
2509 (while (and alist
2510 (> num (caar alist)))
2511 (setq alist (cdr alist)))
2512
2513 (unless (and (eq num (caar alist))
2514 (cdar alist))
2515
2516 ;; Determine if this article was marked for download.
2517 (while (and marked-articles
2518 (> num (car marked-articles)))
2519 (setq marked-articles
2520 (cdr marked-articles)))
2521
2522 ;; When this article is marked, or selected by the
2523 ;; predicate, add it to the download list
2524 (when (or (eq num (car marked-articles))
2525 (let ((gnus-score
2526 (or (cdr
2527 (assq num gnus-newsgroup-scored))
2528 gnus-summary-default-score))
2529 (gnus-agent-long-article
2530 (gnus-agent-find-parameter
2531 group 'agent-long-article))
2532 (gnus-agent-short-article
2533 (gnus-agent-find-parameter
2534 group 'agent-short-article))
2535 (gnus-agent-low-score
2536 (gnus-agent-find-parameter
2537 group 'agent-low-score))
2538 (gnus-agent-high-score
2539 (gnus-agent-find-parameter
2540 group 'agent-high-score))
2541 (gnus-agent-expire-days
2542 (gnus-agent-find-parameter
2543 group 'agent-days-until-old)))
2544 (funcall predicate)))
2545 (gnus-agent-append-to-list arts-tail num))))))
2546
2547 (let (fetched-articles)
2548 ;; Fetch all selected articles
2549 (setq gnus-newsgroup-undownloaded
2550 (gnus-sorted-ndifference
2551 gnus-newsgroup-undownloaded
2552 (setq fetched-articles
2553 (if (cdr arts)
2554 (gnus-agent-fetch-articles group (cdr arts))
2555 nil))))
2556
2557 (let ((unfetched-articles
2558 (gnus-sorted-ndifference (cdr arts) fetched-articles)))
2559 (if gnus-newsgroup-active
2560 ;; Update the summary buffer
2561 (progn
2562 (dolist (article marked-articles)
2563 (gnus-summary-set-agent-mark article t))
2564 (dolist (article fetched-articles)
58090a8d
MB		 2565 (when gnus-agent-mark-unread-after-downloaded
2566 (setq gnus-newsgroup-downloadable
2567 (delq article gnus-newsgroup-downloadable))
01c52d31
MB		 2568 (gnus-summary-mark-article
2569 article gnus-unread-mark))
23f87bed
MB		 2570 (when (gnus-summary-goto-subject article nil t)
2571 (gnus-summary-update-download-mark article)))
2572 (dolist (article unfetched-articles)
2573 (gnus-summary-mark-article
2574 article gnus-canceled-mark)))
2575
2576 ;; Update the group buffer.
2577
2578 ;; When some, or all, of the marked articles came
2579 ;; from the download mark. Remove that mark. I
2580 ;; didn't do this earlier as I only want to remove
2581 ;; the marks after the fetch is completed.
2582
2583 (dolist (mark gnus-agent-download-marks)
2584 (when (eq mark 'download)
2585 (let ((marked-arts
2586 (assq mark (gnus-info-marks
2587 (setq info (gnus-get-info group))))))
2588 (when (cdr marked-arts)
2589 (setq marks
2590 (delq marked-arts (gnus-info-marks info)))
2591 (gnus-info-set-marks info marks)))))
2592 (let ((read (gnus-info-read
2593 (or info (setq info (gnus-get-info group))))))
2594 (gnus-info-set-read
2595 info (gnus-add-to-range read unfetched-articles)))
2596
2597 (gnus-group-update-group group t)
2598 (sit-for 0)
2599
2600 (gnus-dribble-enter
2601 (concat "(gnus-group-set-info '"
2602 (gnus-prin1-to-string info)
b229f37d
KY		 2603 ")")
2604 (concat "^(gnus-group-set-info '(\""
2605 (regexp-quote group) "\""))))))))))))
df80b09f
LMI		 2606
2607;;;
2608;;; Agent Category Mode
2609;;;
2610
2611(defvar gnus-category-mode-hook nil
2612 "Hook run in `gnus-category-mode' buffers.")
2613
2614(defvar gnus-category-line-format " %(%20c%): %g\n"
23f87bed
MB		 2615 "Format of category lines.
2616
2617Valid specifiers include:
2618%c Topic name (string)
2619%g The number of groups in the topic (integer)
2620
2621General format specifiers can also be used. See Info node
2622`(gnus)Formatting Variables'.")
df80b09f
LMI		 2623
2624(defvar gnus-category-mode-line-format "Gnus: %%b"
2625 "The format specification for the category mode line.")
2626
23f87bed
MB		 2627(defvar gnus-agent-predicate 'false
2628 "The selection predicate used when no other source is available.")
2629
df80b09f
LMI		 2630
2631;;; Internal variables.
2632
2633(defvar gnus-category-buffer "*Agent Category*")
2634
c2e9e9ef
SM		 2635(defvar gnus-tmp-name)
2636(defvar gnus-tmp-groups)
2637
df80b09f
LMI		 2638(defvar gnus-category-line-format-alist
2639 `((?c gnus-tmp-name ?s)
2640 (?g gnus-tmp-groups ?d)))
2641
2642(defvar gnus-category-mode-line-format-alist
2643 `((?u user-defined ?s)))
2644
2645(defvar gnus-category-line-format-spec nil)
2646(defvar gnus-category-mode-line-format-spec nil)
2647
2648(defvar gnus-category-mode-map nil)
2649(put 'gnus-category-mode 'mode-class 'special)
2650
2651(unless gnus-category-mode-map
2652 (setq gnus-category-mode-map (make-sparse-keymap))
2653 (suppress-keymap gnus-category-mode-map)
2654
2655 (gnus-define-keys gnus-category-mode-map
2656 "q" gnus-category-exit
2657 "k" gnus-category-kill
2658 "c" gnus-category-copy
2659 "a" gnus-category-add
23f87bed 2660 "e" gnus-agent-customize-category
df80b09f
LMI		 2661 "p" gnus-category-edit-predicate
2662 "g" gnus-category-edit-groups
2663 "s" gnus-category-edit-score
2664 "l" gnus-category-list
2665
2666 "\C-c\C-i" gnus-info-find-node
2667 "\C-c\C-b" gnus-bug))
2668
2669(defvar gnus-category-menu-hook nil
2670 "*Hook run after the creation of the menu.")
2671
2672(defun gnus-category-make-menu-bar ()
2673 (gnus-turn-off-edit-menu 'category)
2674 (unless (boundp 'gnus-category-menu)
2675 (easy-menu-define
2676 gnus-category-menu gnus-category-mode-map ""
2677 '("Categories"
2678 ["Add" gnus-category-add t]
2679 ["Kill" gnus-category-kill t]
2680 ["Copy" gnus-category-copy t]
23f87bed 2681 ["Edit category" gnus-agent-customize-category t]
df80b09f
LMI		 2682 ["Edit predicate" gnus-category-edit-predicate t]
2683 ["Edit score" gnus-category-edit-score t]
2684 ["Edit groups" gnus-category-edit-groups t]
2685 ["Exit" gnus-category-exit t]))
2686
2687 (gnus-run-hooks 'gnus-category-menu-hook)))
2688
c2e9e9ef 2689(define-derived-mode gnus-category-mode fundamental-mode "Category"
df80b09f
LMI		 2690 "Major mode for listing and editing agent categories.
2691
2692All normal editing commands are switched off.
2693\\<gnus-category-mode-map>
2694For more in-depth information on this mode, read the manual
23f87bed 2695\(`\\[gnus-info-find-node]').
df80b09f
LMI		 2696
2697The following commands are available:
2698
2699\\{gnus-category-mode-map}"
df80b09f
LMI		 2700 (when (gnus-visual-p 'category-menu 'menu)
2701 (gnus-category-make-menu-bar))
df80b09f 2702 (gnus-simplify-mode-line)
df80b09f
LMI		 2703 (gnus-set-default-directory)
2704 (setq mode-line-process nil)
16409b0b 2705 (buffer-disable-undo)
df80b09f 2706 (setq truncate-lines t)
c2e9e9ef 2707 (setq buffer-read-only t))
df80b09f
LMI		 2708
2709(defalias 'gnus-category-position-point 'gnus-goto-colon)
2710
2711(defun gnus-category-insert-line (category)
23f87bed
MB		 2712 (let* ((gnus-tmp-name (format "%s" (car category)))
2713 (gnus-tmp-groups (length (gnus-agent-cat-groups category))))
df80b09f
LMI		 2714 (beginning-of-line)
2715 (gnus-add-text-properties
2716 (point)
2717 (prog1 (1+ (point))
2718 ;; Insert the text.
2719 (eval gnus-category-line-format-spec))
2720 (list 'gnus-category gnus-tmp-name))))
2721
2722(defun gnus-enter-category-buffer ()
2723 "Go to the Category buffer."
2724 (interactive)
2725 (gnus-category-setup-buffer)
2726 (gnus-configure-windows 'category)
2727 (gnus-category-prepare))
2728
2729(defun gnus-category-setup-buffer ()
2730 (unless (get-buffer gnus-category-buffer)
20a673b2 2731 (with-current-buffer (gnus-get-buffer-create gnus-category-buffer)
df80b09f
LMI		 2732 (gnus-category-mode))))
2733
2734(defun gnus-category-prepare ()
2735 (gnus-set-format 'category-mode)
2736 (gnus-set-format 'category t)
2737 (let ((alist gnus-category-alist)
2738 (buffer-read-only nil))
2739 (erase-buffer)
2740 (while alist
2741 (gnus-category-insert-line (pop alist)))
2742 (goto-char (point-min))
2743 (gnus-category-position-point)))
2744
2745(defun gnus-category-name ()
01c52d31 2746 (or (intern (get-text-property (point-at-bol) 'gnus-category))
df80b09f
LMI		 2747 (error "No category on the current line")))
2748
2749(defun gnus-category-read ()
2750 "Read the category alist."
2751 (setq gnus-category-alist
23f87bed
MB		 2752 (or
2753 (with-temp-buffer
2754 (ignore-errors
2755 (nnheader-insert-file-contents (nnheader-concat gnus-agent-directory "lib/categories"))
2756 (goto-char (point-min))
2757 ;; This code isn't temp, it will be needed so long as
2758 ;; anyone may be migrating from an older version.
2759
2760 ;; Once we're certain that people will not revert to an
2761 ;; earlier version, we can take out the old-list code in
2762 ;; gnus-category-write.
2763 (let* ((old-list (read (current-buffer)))
2764 (new-list (ignore-errors (read (current-buffer)))))
2765 (if new-list
2766 new-list
2767 ;; Convert from a positional list to an alist.
2768 (mapcar
2769 (lambda (c)
2770 (setcdr c
2771 (delq nil
2772 (gnus-mapcar
2773 (lambda (valu symb)
2774 (if valu
2775 (cons symb valu)))
2776 (cdr c)
2777 '(agent-predicate agent-score-file agent-groups))))
2778 c)
2779 old-list)))))
2780 (list (gnus-agent-cat-make 'default 'short)))))
df80b09f
LMI		 2781
2782(defun gnus-category-write ()
2783 "Write the category alist."
2784 (setq gnus-category-predicate-cache nil
2785 gnus-category-group-cache nil)
16409b0b
GM		 2786 (gnus-make-directory (nnheader-concat gnus-agent-directory "lib"))
2787 (with-temp-file (nnheader-concat gnus-agent-directory "lib/categories")
23f87bed
MB		 2788 ;; This prin1 is temporary. It exists so that people can revert
2789 ;; to an earlier version of gnus-agent.
2790 (prin1 (mapcar (lambda (c)
2791 (list (car c)
2792 (cdr (assoc 'agent-predicate c))
2793 (cdr (assoc 'agent-score-file c))
2794 (cdr (assoc 'agent-groups c))))
2795 gnus-category-alist)
2796 (current-buffer))
2797 (newline)
df80b09f
LMI		 2798 (prin1 gnus-category-alist (current-buffer))))
2799
2800(defun gnus-category-edit-predicate (category)
2801 "Edit the predicate for CATEGORY."
2802 (interactive (list (gnus-category-name)))
2803 (let ((info (assq category gnus-category-alist)))
2804 (gnus-edit-form
23f87bed
MB		 2805 (gnus-agent-cat-predicate info)
2806 (format "Editing the select predicate for category %s" category)
df80b09f 2807 `(lambda (predicate)
23f87bed
MB		 2808 ;; Avoid run-time execution of setf form
2809 ;; (setf (gnus-agent-cat-predicate (assq ',category gnus-category-alist))
2810 ;; predicate)
2811 ;; use its expansion instead:
2812 (gnus-agent-cat-set-property (assq ',category gnus-category-alist)
2813 'agent-predicate predicate)
2814
df80b09f
LMI		 2815 (gnus-category-write)
2816 (gnus-category-list)))))
2817
2818(defun gnus-category-edit-score (category)
2819 "Edit the score expression for CATEGORY."
2820 (interactive (list (gnus-category-name)))
2821 (let ((info (assq category gnus-category-alist)))
2822 (gnus-edit-form
23f87bed 2823 (gnus-agent-cat-score-file info)
df80b09f 2824 (format "Editing the score expression for category %s" category)
23f87bed
MB		 2825 `(lambda (score-file)
2826 ;; Avoid run-time execution of setf form
2827 ;; (setf (gnus-agent-cat-score-file (assq ',category gnus-category-alist))
2828 ;; score-file)
2829 ;; use its expansion instead:
2830 (gnus-agent-cat-set-property (assq ',category gnus-category-alist)
2831 'agent-score-file score-file)
2832
df80b09f
LMI		 2833 (gnus-category-write)
2834 (gnus-category-list)))))
2835
2836(defun gnus-category-edit-groups (category)
2837 "Edit the group list for CATEGORY."
2838 (interactive (list (gnus-category-name)))
2839 (let ((info (assq category gnus-category-alist)))
2840 (gnus-edit-form
23f87bed
MB		 2841 (gnus-agent-cat-groups info)
2842 (format "Editing the group list for category %s" category)
df80b09f 2843 `(lambda (groups)
23f87bed
MB		 2844 ;; Avoid run-time execution of setf form
2845 ;; (setf (gnus-agent-cat-groups (assq ',category gnus-category-alist))
2846 ;; groups)
2847 ;; use its expansion instead:
2848 (gnus-agent-set-cat-groups (assq ',category gnus-category-alist)
2849 groups)
2850
df80b09f
LMI		 2851 (gnus-category-write)
2852 (gnus-category-list)))))
2853
2854(defun gnus-category-kill (category)
2855 "Kill the current category."
2856 (interactive (list (gnus-category-name)))
2857 (let ((info (assq category gnus-category-alist))
2858 (buffer-read-only nil))
2859 (gnus-delete-line)
16409b0b
GM		 2860 (setq gnus-category-alist (delq info gnus-category-alist))
2861 (gnus-category-write)))
df80b09f
LMI		 2862
2863(defun gnus-category-copy (category to)
2864 "Copy the current category."
2865 (interactive (list (gnus-category-name) (intern (read-string "New name: "))))
2866 (let ((info (assq category gnus-category-alist)))
23f87bed
MB		 2867 (push (let ((newcat (gnus-copy-sequence info)))
2868 (setf (gnus-agent-cat-name newcat) to)
2869 (setf (gnus-agent-cat-groups newcat) nil)
2870 newcat)
df80b09f
LMI		 2871 gnus-category-alist)
2872 (gnus-category-write)
2873 (gnus-category-list)))
2874
2875(defun gnus-category-add (category)
2876 "Create a new category."
2877 (interactive "SCategory name: ")
2878 (when (assq category gnus-category-alist)
2879 (error "Category %s already exists" category))
23f87bed 2880 (push (gnus-agent-cat-make category)
df80b09f
LMI		 2881 gnus-category-alist)
2882 (gnus-category-write)
2883 (gnus-category-list))
2884
2885(defun gnus-category-list ()
2886 "List all categories."
2887 (interactive)
2888 (gnus-category-prepare))
2889
2890(defun gnus-category-exit ()
2891 "Return to the group buffer."
2892 (interactive)
2893 (kill-buffer (current-buffer))
2894 (gnus-configure-windows 'group t))
2895
2896;; To avoid having 8-bit characters in the source file.
2897(defvar gnus-category-not (list '! 'not (intern (format "%c" 172))))
2898
2899(defvar gnus-category-predicate-alist
2900 '((spam . gnus-agent-spam-p)
2901 (short . gnus-agent-short-p)
2902 (long . gnus-agent-long-p)
2903 (low . gnus-agent-low-scored-p)
2904 (high . gnus-agent-high-scored-p)
23f87bed 2905 (read . gnus-agent-read-p)
df80b09f
LMI		 2906 (true . gnus-agent-true)
2907 (false . gnus-agent-false))
2908 "Mapping from short score predicate symbols to predicate functions.")
2909
2910(defun gnus-agent-spam-p ()
2911 "Say whether an article is spam or not."
2912 (unless gnus-agent-spam-hashtb
2913 (setq gnus-agent-spam-hashtb (gnus-make-hashtable 1000)))
2914 (if (not (equal (mail-header-references gnus-headers) ""))
2915 nil
2916 (let ((string (gnus-simplify-subject (mail-header-subject gnus-headers))))
2917 (prog1
2918 (gnus-gethash string gnus-agent-spam-hashtb)
2919 (gnus-sethash string t gnus-agent-spam-hashtb)))))
2920
2921(defun gnus-agent-short-p ()
2922 "Say whether an article is short or not."
2923 (< (mail-header-lines gnus-headers) gnus-agent-short-article))
2924
2925(defun gnus-agent-long-p ()
2926 "Say whether an article is long or not."
2927 (> (mail-header-lines gnus-headers) gnus-agent-long-article))
2928
2929(defun gnus-agent-low-scored-p ()
2930 "Say whether an article has a low score or not."
2931 (< gnus-score gnus-agent-low-score))
2932
2933(defun gnus-agent-high-scored-p ()
2934 "Say whether an article has a high score or not."
2935 (> gnus-score gnus-agent-high-score))
2936
23f87bed
MB		 2937(defun gnus-agent-read-p ()
2938 "Say whether an article is read or not."
2939 (gnus-member-of-range (mail-header-number gnus-headers)
2940 (gnus-info-read (gnus-get-info gnus-newsgroup-name))))
2941
2942(defun gnus-category-make-function (predicate)
2943 "Make a function from PREDICATE."
2944 (let ((func (gnus-category-make-function-1 predicate)))
2945 (if (and (= (length func) 1)
2946 (symbolp (car func)))
2947 (car func)
2948 (gnus-byte-compile `(lambda () ,func)))))
df80b09f
LMI		 2949
2950(defun gnus-agent-true ()
2951 "Return t."
2952 t)
2953
2954(defun gnus-agent-false ()
2955 "Return nil."
2956 nil)
2957
23f87bed
MB		 2958(defun gnus-category-make-function-1 (predicate)
2959 "Make a function from PREDICATE."
df80b09f
LMI		 2960 (cond
2961 ;; Functions are just returned as is.
23f87bed
MB		 2962 ((or (symbolp predicate)
2963 (functionp predicate))
2964 `(,(or (cdr (assq predicate gnus-category-predicate-alist))
2965 predicate)))
2966 ;; More complex predicate.
2967 ((consp predicate)
df80b09f 2968 `(,(cond
23f87bed 2969 ((memq (car predicate) '(& and))
df80b09f 2970 'and)
23f87bed 2971 ((memq (car predicate) '(| or))
df80b09f 2972 'or)
23f87bed 2973 ((memq (car predicate) gnus-category-not)
df80b09f 2974 'not))
23f87bed 2975 ,@(mapcar 'gnus-category-make-function-1 (cdr predicate))))
df80b09f 2976 (t
23f87bed 2977 (error "Unknown predicate type: %s" predicate))))
df80b09f
LMI		 2978
2979(defun gnus-get-predicate (predicate)
23f87bed 2980 "Return the function implementing PREDICATE."
df80b09f 2981 (or (cdr (assoc predicate gnus-category-predicate-cache))
23f87bed 2982 (let ((func (gnus-category-make-function predicate)))
c2e9e9ef 2983 (push (cons predicate func) gnus-category-predicate-cache)
23f87bed
MB		 2984 func)))
2985
2986(defun gnus-predicate-implies-unread (predicate)
2987 "Say whether PREDICATE implies unread articles only.
2988It is okay to miss some cases, but there must be no false positives.
2989That is, if this predicate returns true, then indeed the predicate must
2990return only unread articles."
bf247b6e 2991 (eq t (gnus-function-implies-unread-1
23f87bed
MB		 2992 (gnus-category-make-function-1 predicate))))
2993
2994(defun gnus-function-implies-unread-1 (function)
2995 "Recursively evaluate a predicate function to determine whether it can select
2996any read articles. Returns t if the function is known to never
2997return read articles, nil when it is known to always return read
2998articles, and t_nil when the function may return both read and unread
2999articles."
3000 (let ((func (car function))
3001 (args (mapcar 'gnus-function-implies-unread-1 (cdr function))))
3002 (cond ((eq func 'and)
3003 (cond ((memq t args) ; if any argument returns only unread articles
3004 ;; then that argument constrains the result to only unread articles.
3005 t)
3006 ((memq 't_nil args) ; if any argument is indeterminate
3007 ;; then the result is indeterminate
3008 't_nil)))
3009 ((eq func 'or)
3010 (cond ((memq nil args) ; if any argument returns read articles
3011 ;; then that argument ensures that the results includes read articles.
3012 nil)
3013 ((memq 't_nil args) ; if any argument is indeterminate
3014 ;; then that argument ensures that the results are indeterminate
3015 't_nil)
3016 (t ; if all arguments return only unread articles
3017 ;; then the result returns only unread articles
3018 t)))
3019 ((eq func 'not)
3020 (cond ((eq (car args) 't_nil) ; if the argument is indeterminate
3021 ; then the result is indeterminate
3022 (car args))
3023 (t ; otherwise
3024 ; toggle the result to be the opposite of the argument
3025 (not (car args)))))
3026 ((eq func 'gnus-agent-read-p)
3027 nil) ; The read predicate NEVER returns unread articles
3028 ((eq func 'gnus-agent-false)
3029 t) ; The false predicate returns t as the empty set excludes all read articles
3030 ((eq func 'gnus-agent-true)
3031 nil) ; The true predicate ALWAYS returns read articles
3032 ((catch 'found-match
3033 (let ((alist gnus-category-predicate-alist))
3034 (while alist
3035 (if (eq func (cdar alist))
3036 (throw 'found-match t)
3037 (setq alist (cdr alist))))))
3038 't_nil) ; All other predicates return read and unread articles
3039 (t
3040 (error "Unknown predicate function: %s" function)))))
df80b09f
LMI		 3041
3042(defun gnus-group-category (group)
3043 "Return the category GROUP belongs to."
3044 (unless gnus-category-group-cache
3045 (setq gnus-category-group-cache (gnus-make-hashtable 1000))
3046 (let ((cs gnus-category-alist)
3047 groups cat)
3048 (while (setq cat (pop cs))
23f87bed 3049 (setq groups (gnus-agent-cat-groups cat))
df80b09f
LMI		 3050 (while groups
3051 (gnus-sethash (pop groups) cat gnus-category-group-cache)))))
3052 (or (gnus-gethash group gnus-category-group-cache)
3053 (assq 'default gnus-category-alist)))
3054
c2e9e9ef
SM		 3055(defvar gnus-agent-expire-current-dirs)
3056(defvar gnus-agent-expire-stats)
3057
23f87bed
MB		 3058(defun gnus-agent-expire-group (group &optional articles force)
3059 "Expire all old articles in GROUP.
3060If you want to force expiring of certain articles, this function can
3061take ARTICLES, and FORCE parameters as well.
3062
3063The articles on which the expiration process runs are selected as follows:
3064 if ARTICLES is null, all read and unmarked articles.
3065 if ARTICLES is t, all articles.
3066 if ARTICLES is a list, just those articles.
3067FORCE is equivalent to setting the expiration predicates to true."
01c52d31 3068 (interactive (list (gnus-agent-read-group)))
23f87bed
MB		 3069
3070 (if (not group)
3071 (gnus-agent-expire articles group force)
c2e9e9ef 3072 (let (;; Bind gnus-agent-expire-stats to enable tracking of
01c52d31 3073 ;; expiration statistics of this single group
23f87bed
MB		 3074 (gnus-agent-expire-stats (list 0 0 0.0)))
3075 (if (or (not (eq articles t))
3076 (yes-or-no-p
3077 (concat "Are you sure that you want to "
66841476 3078 "expire all articles in " group "? ")))
23f87bed
MB		 3079 (let ((gnus-command-method (gnus-find-method-for-group group))
3080 (overview (gnus-get-buffer-create " *expire overview*"))
3081 orig)
3082 (unwind-protect
3083 (let ((active-file (gnus-agent-lib-file "active")))
3084 (when (file-exists-p active-file)
3085 (with-temp-buffer
3086 (nnheader-insert-file-contents active-file)
3087 (gnus-active-to-gnus-format
3088 gnus-command-method
3089 (setq orig (gnus-make-hashtable
3090 (count-lines (point-min) (point-max))))))
3091 (save-excursion
3092 (gnus-agent-expire-group-1
3093 group overview (gnus-gethash-safe group orig)
3094 articles force))))
3095 (kill-buffer overview))))
bdaa75c7 3096 (gnus-message 4 "%s" (gnus-agent-expire-done-message)))))
23f87bed
MB		 3097
3098(defun gnus-agent-expire-group-1 (group overview active articles force)
3099 ;; Internal function - requires caller to have set
3100 ;; gnus-command-method, initialized overview buffer, and to have
3101 ;; provided a non-nil active
3102
01c52d31
MB		 3103 (let ((dir (gnus-agent-group-pathname group))
3104 (file-name-coding-system nnmail-pathname-coding-system)
3105 (decoded (gnus-agent-decoded-group-name group)))
3106 (gnus-agent-with-refreshed-group
3107 group
3108 (when (boundp 'gnus-agent-expire-current-dirs)
c2e9e9ef 3109 (push dir gnus-agent-expire-current-dirs))
01c52d31
MB		 3110
3111 (if (and (not force)
3112 (eq 'DISABLE (gnus-agent-find-parameter group
3113 'agent-enable-expiration)))
3114 (gnus-message 5 "Expiry skipping over %s" decoded)
3115 (gnus-message 5 "Expiring articles in %s" decoded)
3116 (gnus-agent-load-alist group)
3117 (let* ((bytes-freed 0)
3118 (size-files-deleted 0.0)
3119 (files-deleted 0)
3120 (nov-entries-deleted 0)
3121 (info (gnus-get-info group))
3122 (alist gnus-agent-article-alist)
3123 (day (- (time-to-days (current-time))
3124 (gnus-agent-find-parameter group 'agent-days-until-old)))
3125 (specials (if (and alist
3126 (not force))
3127 ;; This could be a bit of a problem. I need to
3128 ;; keep the last article to avoid refetching
3129 ;; headers when using nntp in the backend. At
3130 ;; the same time, if someone uses a backend
3131 ;; that supports article moving then I may have
3132 ;; to remove the last article to complete the
3133 ;; move. Right now, I'm going to assume that
3134 ;; FORCE overrides specials.
3135 (list (caar (last alist)))))
3136 (unreads ;; Articles that are excluded from the
3137 ;; expiration process
3138 (cond (gnus-agent-expire-all
3139 ;; All articles are marked read by global decree
3140 nil)
3141 ((eq articles t)
3142 ;; All articles are marked read by function
3143 ;; parameter
3144 nil)
3145 ((not articles)
3146 ;; Unread articles are marked protected from
3147 ;; expiration Don't call
3148 ;; gnus-list-of-unread-articles as it returns
3149 ;; articles that have not been fetched into the
3150 ;; agent.
3151 (ignore-errors
3152 (gnus-agent-unread-articles group)))
3153 (t
3154 ;; All articles EXCEPT those named by the caller
3155 ;; are protected from expiration
3156 (gnus-sorted-difference
3157 (gnus-uncompress-range
3158 (cons (caar alist)
3159 (caar (last alist))))
3160 (sort articles '<)))))
3161 (marked ;; More articles that are excluded from the
3162 ;; expiration process
3163 (cond (gnus-agent-expire-all
3164 ;; All articles are unmarked by global decree
3165 nil)
3166 ((eq articles t)
3167 ;; All articles are unmarked by function
3168 ;; parameter
3169 nil)
3170 (articles
3171 ;; All articles may as well be unmarked as the
3172 ;; unreads list already names the articles we are
3173 ;; going to keep
3174 nil)
3175 (t
3176 ;; Ticked and/or dormant articles are excluded
3177 ;; from expiration
3178 (nconc
3179 (gnus-uncompress-range
3180 (cdr (assq 'tick (gnus-info-marks info))))
3181 (gnus-uncompress-range
3182 (cdr (assq 'dormant
3183 (gnus-info-marks info))))))))
3184 (nov-file (concat dir ".overview"))
3185 (cnt 0)
3186 (completed -1)
3187 dlist
3188 type)
3189
3190 ;; The normal article alist contains elements that look like
3191 ;; (article# . fetch_date) I need to combine other
3192 ;; information with this list. For example, a flag indicating
3193 ;; that a particular article MUST BE KEPT. To do this, I'm
3194 ;; going to transform the elements to look like (article#
3195 ;; fetch_date keep_flag NOV_entry_position) Later, I'll reverse
3196 ;; the process to generate the expired article alist.
3197
3198 ;; Convert the alist elements to (article# fetch_date nil
3199 ;; nil).
3200 (setq dlist (mapcar (lambda (e)
3201 (list (car e) (cdr e) nil nil)) alist))
3202
3203 ;; Convert the keep lists to elements that look like (article#
3204 ;; nil keep_flag nil) then append it to the expanded dlist
e1dbe924 3205 ;; These statements are sorted by ascending precedence of the
01c52d31
MB		 3206 ;; keep_flag.
3207 (setq dlist (nconc dlist
3208 (mapcar (lambda (e)
3209 (list e nil 'unread nil))
3210 unreads)))
3211 (setq dlist (nconc dlist
3212 (mapcar (lambda (e)
3213 (list e nil 'marked nil))
3214 marked)))
3215 (setq dlist (nconc dlist
3216 (mapcar (lambda (e)
3217 (list e nil 'special nil))
3218 specials)))
3219
3220 (set-buffer overview)
3221 (erase-buffer)
3222 (buffer-disable-undo)
3223 (when (file-exists-p nov-file)
3224 (gnus-message 7 "gnus-agent-expire: Loading overview...")
3225 (nnheader-insert-file-contents nov-file)
3226 (goto-char (point-min))
c9fc72fa 3227
01c52d31
MB		 3228 (let (p)
3229 (while (< (setq p (point)) (point-max))
3230 (condition-case nil
3231 ;; If I successfully read an integer (the plus zero
3232 ;; ensures a numeric type), append the position
3233 ;; to the list
3234 (push (list (+ 0 (read (current-buffer))) nil nil
3235 p)
3236 dlist)
3237 (error
3238 (gnus-message 1 "gnus-agent-expire: read error \
23f87bed
MB		 3239occurred when reading expression at %s in %s. Skipping to next \
3240line." (point) nov-file)))
01c52d31
MB		 3241 ;; Whether I succeeded, or failed, it doesn't matter.
3242 ;; Move to the next line then try again.
3243 (forward-line 1)))
3244
3245 (gnus-message
3246 7 "gnus-agent-expire: Loading overview... Done"))
3247 (set-buffer-modified-p nil)
3248
3249 ;; At this point, all of the information is in dlist. The
3250 ;; only problem is that much of it is spread across multiple
3251 ;; entries. Sort then MERGE!!
3252 (gnus-message 7 "gnus-agent-expire: Sorting entries... ")
c2e9e9ef
SM		 3253 (setq dlist
3254 (sort dlist
3255 (lambda (a b)
3256 (cond ((< (nth 0 a) (nth 0 b))
3257 t)
3258 ((> (nth 0 a) (nth 0 b))
3259 nil)
3260 (t
3261 ;; If two entries have the same article-number
3262 ;; then sort by ascending keep_flag.
3263 (let* ((kf-score '((special . 0)
3264 (marked . 1)
3265 (unread . 2)))
3266 (a (or (cdr (assq (nth 2 a) kf-score))
3267 3))
3268 (b (or (cdr (assq (nth 2 b) kf-score))
3269 3)))
3270 (<= a b)))))))
01c52d31
MB		 3271 (gnus-message 7 "gnus-agent-expire: Sorting entries... Done")
3272 (gnus-message 7 "gnus-agent-expire: Merging entries... ")
3273 (let ((dlist dlist))
3274 (while (cdr dlist) ; I'm not at the end-of-list
3275 (if (eq (caar dlist) (caadr dlist))
3276 (let ((first (cdr (car dlist)))
3277 (secnd (cdr (cadr dlist))))
3278 (setcar first (or (car first)
3279 (car secnd))) ; fetch_date
3280 (setq first (cdr first)
3281 secnd (cdr secnd))
3282 (setcar first (or (car first)
3283 (car secnd))) ; Keep_flag
3284 (setq first (cdr first)
3285 secnd (cdr secnd))
3286 (setcar first (or (car first)
3287 (car secnd))) ; NOV_entry_position
3288
3289 (setcdr dlist (cddr dlist)))
3290 (setq dlist (cdr dlist)))))
3291
3292 ;; Check the order of the entry positions. They should be in
3293 ;; ascending order. If they aren't, the positions must be
3294 ;; converted to markers.
3295 (when (catch 'sort-results
3296 (let ((dlist dlist)
3297 (prev-pos -1)
3298 pos)
3299 (while dlist
3300 (if (setq pos (nth 3 (pop dlist)))
3301 (if (< pos prev-pos)
3302 (throw 'sort-results 'unsorted)
3303 (setq prev-pos pos))))))
3304 (gnus-message 7 "gnus-agent-expire: Unsorted overview; inserting markers to compensate.")
3305 (mapc (lambda (entry)
3306 (let ((pos (nth 3 entry)))
3307 (if pos
3308 (setf (nth 3 entry)
3309 (set-marker (make-marker)
3310 pos)))))
3311 dlist))
3312
3313 (gnus-message 7 "gnus-agent-expire: Merging entries... Done")
3314
3315 (let* ((len (float (length dlist)))
3316 (alist (list nil))
3317 (tail-alist alist)
3318 (position-offset 0)
3319 )
3320
3321 (while dlist
3322 (let ((new-completed (truncate (* 100.0
3323 (/ (setq cnt (1+ cnt))
3324 len))))
3325 message-log-max)
3326 (when (> new-completed completed)
3327 (setq completed new-completed)
3328 (gnus-message 7 "%3d%% completed..." completed)))
3329 (let* ((entry (car dlist))
3330 (article-number (nth 0 entry))
3331 (fetch-date (nth 1 entry))
3332 (keep (nth 2 entry))
3333 (marker (nth 3 entry)))
3334
3335 (cond
3336 ;; Kept articles are unread, marked, or special.
3337 (keep
3338 (gnus-agent-message 10
3339 "gnus-agent-expire: %s:%d: Kept %s article%s."
3340 decoded article-number keep (if fetch-date " and file" ""))
3341 (when fetch-date
3342 (unless (file-exists-p
3343 (concat dir (number-to-string
3344 article-number)))
3345 (setf (nth 1 entry) nil)
3346 (gnus-agent-message 3 "gnus-agent-expire cleared \
23f87bed 3347download flag on %s:%d as the cached article file is missing."
01c52d31
MB		 3348 decoded (caar dlist)))
3349 (unless marker
3350 (gnus-message 1 "gnus-agent-expire detected a \
23f87bed 3351missing NOV entry. Run gnus-agent-regenerate-group to restore it.")))
01c52d31
MB		 3352 (gnus-agent-append-to-list
3353 tail-alist
3354 (cons article-number fetch-date)))
3355
3356 ;; The following articles are READ, UNMARKED, and
3357 ;; ORDINARY. See if they can be EXPIRED!!!
3358 ((setq type
3359 (cond
3360 ((not (integerp fetch-date))
58090a8d 3361 'read) ;; never fetched article (may expire
01c52d31
MB		 3362 ;; right now)
3363 ((not (file-exists-p
3364 (concat dir (number-to-string
3365 article-number))))
3366 (setf (nth 1 entry) nil)
3367 'externally-expired) ;; Can't find the cached
3368 ;; article. Handle case
3369 ;; as though this article
3370 ;; was never fetched.
3371
3372 ;; We now have the arrival day, so we see
3373 ;; whether it's old enough to be expired.
3374 ((< fetch-date day)
3375 'expired)
3376 (force
3377 'forced)))
3378
3379 ;; I found some reason to expire this entry.
3380
3381 (let ((actions nil))
3382 (when (memq type '(forced expired))
3383 (ignore-errors ; Just being paranoid.
3384 (let* ((file-name (nnheader-concat dir (number-to-string
3385 article-number)))
3386 (size (float (nth 7 (file-attributes file-name)))))
3387 (incf bytes-freed size)
3388 (incf size-files-deleted size)
3389 (incf files-deleted)
3390 (delete-file file-name))
3391 (push "expired cached article" actions))
3392 (setf (nth 1 entry) nil)
3393 )
3394
3395 (when marker
3396 (push "NOV entry removed" actions)
3397
3398 (goto-char (if (markerp marker)
3399 marker
3400 (- marker position-offset)))
3401
3402 (incf nov-entries-deleted)
3403
3404 (let* ((from (point-at-bol))
3405 (to (progn (forward-line 1) (point)))
3406 (freed (- to from)))
3407 (incf bytes-freed freed)
3408 (incf position-offset freed)
3409 (delete-region from to)))
3410
3411 ;; If considering all articles is set, I can only
3412 ;; expire article IDs that are no longer in the
97610156 3413 ;; active range (That is, articles that precede the
01c52d31
MB		 3414 ;; first article in the new alist).
3415 (if (and gnus-agent-consider-all-articles
3416 (>= article-number (car active)))
3417 ;; I have to keep this ID in the alist
3418 (gnus-agent-append-to-list
3419 tail-alist (cons article-number fetch-date))
3420 (push (format "Removed %s article number from \
23f87bed
MB		 3421article alist" type) actions))
3422
01c52d31
MB		 3423 (when actions
3424 (gnus-agent-message 8 "gnus-agent-expire: %s:%d: %s"
3425 decoded article-number
3426 (mapconcat 'identity actions ", ")))))
3427 (t
3428 (gnus-agent-message
3429 10 "gnus-agent-expire: %s:%d: Article kept as \
3430expiration tests failed." decoded article-number)
3431 (gnus-agent-append-to-list
3432 tail-alist (cons article-number fetch-date)))
3433 )
3434
3435 ;; Remove markers as I intend to reuse this buffer again.
3436 (when (and marker
3437 (markerp marker))
3438 (set-marker marker nil))
3439
3440 (setq dlist (cdr dlist))))
3441
3442 (setq alist (cdr alist))
3443
3444 (let ((inhibit-quit t))
3445 (unless (equal alist gnus-agent-article-alist)
3446 (setq gnus-agent-article-alist alist)
3447 (gnus-agent-save-alist group))
3448
3449 (when (buffer-modified-p)
3450 (let ((coding-system-for-write
3451 gnus-agent-file-coding-system))
3452 (gnus-make-directory dir)
3453 (write-region (point-min) (point-max) nov-file nil
3454 'silent)
3455 ;; clear the modified flag as that I'm not confused by
3456 ;; its status on the next pass through this routine.
3457 (set-buffer-modified-p nil)
3458 (gnus-agent-update-view-total-fetched-for group t)))
3459
3460 (when (eq articles t)
3461 (gnus-summary-update-info))))
3462
3463 (when (boundp 'gnus-agent-expire-stats)
c2e9e9ef 3464 (let ((stats gnus-agent-expire-stats))
01c52d31
MB		 3465 (incf (nth 2 stats) bytes-freed)
3466 (incf (nth 1 stats) files-deleted)
3467 (incf (nth 0 stats) nov-entries-deleted)))
3468
3469 (gnus-agent-update-files-total-fetched-for group (- size-files-deleted)))))))
23f87bed
MB		 3470
3471(defun gnus-agent-expire (&optional articles group force)
3472 "Expire all old articles.
3473If you want to force expiring of certain articles, this function can
3474take ARTICLES, GROUP and FORCE parameters as well.
3475
3476The articles on which the expiration process runs are selected as follows:
3477 if ARTICLES is null, all read and unmarked articles.
3478 if ARTICLES is t, all articles.
3479 if ARTICLES is a list, just those articles.
3480Setting GROUP will limit expiration to that group.
3481FORCE is equivalent to setting the expiration predicates to true."
df80b09f 3482 (interactive)
bf247b6e 3483
23f87bed
MB		 3484 (if group
3485 (gnus-agent-expire-group group articles force)
3486 (if (or (not (eq articles t))
3487 (yes-or-no-p "Are you sure that you want to expire all \
66841476 3488articles in every agentized group? "))
23f87bed
MB		 3489 (let ((methods (gnus-agent-covered-methods))
3490 ;; Bind gnus-agent-expire-current-dirs to enable tracking
3491 ;; of agent directories.
3492 (gnus-agent-expire-current-dirs nil)
3493 ;; Bind gnus-agent-expire-stats to enable tracking of
3494 ;; expiration statistics across all groups
3495 (gnus-agent-expire-stats (list 0 0 0.0))
3496 gnus-command-method overview orig)
3497 (setq overview (gnus-get-buffer-create " *expire overview*"))
3498 (unwind-protect
3499 (while (setq gnus-command-method (pop methods))
3500 (let ((active-file (gnus-agent-lib-file "active")))
3501 (when (file-exists-p active-file)
3502 (with-temp-buffer
3503 (nnheader-insert-file-contents active-file)
3504 (gnus-active-to-gnus-format
3505 gnus-command-method
3506 (setq orig (gnus-make-hashtable
3507 (count-lines (point-min) (point-max))))))
3508 (dolist (expiring-group (gnus-groups-from-server
3509 gnus-command-method))
3510 (let* ((active
3511 (gnus-gethash-safe expiring-group orig)))
bf247b6e 3512
23f87bed
MB		 3513 (when active
3514 (save-excursion
3515 (gnus-agent-expire-group-1
3516 expiring-group overview active articles force))))))))
3517 (kill-buffer overview))
3518 (gnus-agent-expire-unagentized-dirs)
bdaa75c7 3519 (gnus-message 4 "%s" (gnus-agent-expire-done-message))))))
23f87bed
MB		 3520
3521(defun gnus-agent-expire-done-message ()
3522 (if (and (> gnus-verbose 4)
3523 (boundp 'gnus-agent-expire-stats))
c2e9e9ef 3524 (let* ((stats gnus-agent-expire-stats)
23f87bed
MB		 3525 (size (nth 2 stats))
3526 (units '(B KB MB GB)))
3527 (while (and (> size 1024.0)
3528 (cdr units))
3529 (setq size (/ size 1024.0)
3530 units (cdr units)))
3531
3532 (format "Expiry recovered %d NOV entries, deleted %d files,\
1e91d506 3533 and freed %.f %s."
bf247b6e
KS		 3534 (nth 0 stats)
3535 (nth 1 stats)
23f87bed
MB		 3536 size (car units)))
3537 "Expiry...done"))
3538
3539(defun gnus-agent-expire-unagentized-dirs ()
3540 (when (and gnus-agent-expire-unagentized-dirs
3541 (boundp 'gnus-agent-expire-current-dirs))
3542 (let* ((keep (gnus-make-hashtable))
01c52d31 3543 (file-name-coding-system nnmail-pathname-coding-system))
23f87bed
MB		 3544
3545 (gnus-sethash gnus-agent-directory t keep)
c2e9e9ef 3546 (dolist (dir gnus-agent-expire-current-dirs)
23f87bed
MB		 3547 (when (and (stringp dir)
3548 (file-directory-p dir))
3549 (while (not (gnus-gethash dir keep))
3550 (gnus-sethash dir t keep)
3551 (setq dir (file-name-directory (directory-file-name dir))))))
3552
3553 (let* (to-remove
3554 checker
3555 (checker
3556 (function
3557 (lambda (d)
bf247b6e
KS		 3558 "Given a directory, check it and its subdirectories for
3559 membership in the keep hash. If it isn't found, add
3560 it to to-remove."
23f87bed
MB		 3561 (let ((files (directory-files d))
3562 file)
3563 (while (setq file (pop files))
3564 (cond ((equal file ".") ; Ignore self
3565 nil)
3566 ((equal file "..") ; Ignore parent
3567 nil)
bf247b6e 3568 ((equal file ".overview")
23f87bed
MB		 3569 ;; Directory must contain .overview to be
3570 ;; agent's cache of a group.
3571 (let ((d (file-name-as-directory d))
3572 r)
3573 ;; Search ancestor's for last directory NOT
3574 ;; found in keep hash.
3575 (while (not (gnus-gethash
3576 (setq d (file-name-directory d)) keep))
3577 (setq r d
3578 d (directory-file-name d)))
3579 ;; if ANY ancestor was NOT in keep hash and
debce7bc 3580 ;; it's not already in to-remove, add it to
bf247b6e 3581 ;; to-remove.
23f87bed
MB		 3582 (if (and r
3583 (not (member r to-remove)))
3584 (push r to-remove))))
3585 ((file-directory-p (setq file (nnheader-concat d file)))
3586 (funcall checker file)))))))))
3587 (funcall checker (expand-file-name gnus-agent-directory))
3588
3589 (when (and to-remove
3590 (or gnus-expert-user
3591 (gnus-y-or-n-p
3592 "gnus-agent-expire has identified local directories that are\
655591a7 3593 not currently required by any agentized group. Do you wish to consider\
23f87bed
MB		 3594 deleting them?")))
3595 (while to-remove
3596 (let ((dir (pop to-remove)))
5e7d4a75
KY		 3597 (if (or gnus-expert-user
3598 (gnus-y-or-n-p (format "Delete %s? " dir)))
23f87bed 3599 (let* (delete-recursive
01c52d31 3600 files f
23f87bed
MB		 3601 (delete-recursive
3602 (function
3603 (lambda (f-or-d)
3604 (ignore-errors
3605 (if (file-directory-p f-or-d)
3606 (condition-case nil
3607 (delete-directory f-or-d)
3608 (file-error
01c52d31
MB		 3609 (setq files (directory-files f-or-d))
3610 (while files
3611 (setq f (pop files))
3612 (or (member f '("." ".."))
3613 (funcall delete-recursive
3614 (nnheader-concat
3615 f-or-d f))))
23f87bed
MB		 3616 (delete-directory f-or-d)))
3617 (delete-file f-or-d)))))))
3618 (funcall delete-recursive dir))))))))))
df80b09f
LMI		 3619
3620;;;###autoload
3621(defun gnus-agent-batch ()
23f87bed 3622 "Start Gnus, send queue and fetch session."
df80b09f
LMI		 3623 (interactive)
3624 (let ((init-file-user "")
3625 (gnus-always-read-dribble-file t))
3626 (gnus))
23f87bed
MB		 3627 (let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation))
3628 (gnus-group-send-queue)
3629 (gnus-agent-fetch-session)))
3630
3631(defun gnus-agent-unread-articles (group)
3632 (let* ((read (gnus-info-read (gnus-get-info group)))
3633 (known (gnus-agent-load-alist group))
3634 (unread (list nil))
3635 (tail-unread unread))
3636 (while (and known read)
3637 (let ((candidate (car (pop known))))
3638 (while (let* ((range (car read))
3639 (min (if (numberp range) range (car range)))
3640 (max (if (numberp range) range (cdr range))))
3641 (cond ((or (not min)
3642 (< candidate min))
3643 (gnus-agent-append-to-list tail-unread candidate)
3644 nil)
3645 ((> candidate max)
3646 (setq read (cdr read))
3647 ;; return t so that I always loop one more
3648 ;; time. If I just iterated off the end of
3649 ;; read, min will become nil and the current
3650 ;; candidate will be added to the unread list.
3651 t))))))
3652 (while known
3653 (gnus-agent-append-to-list tail-unread (car (pop known))))
3654 (cdr unread)))
3655
3656(defun gnus-agent-uncached-articles (articles group &optional cached-header)
3657 "Restrict ARTICLES to numbers already fetched.
54506618 3658Returns a sublist of ARTICLES that excludes those article ids in GROUP
23f87bed
MB		 3659that have already been fetched.
3660If CACHED-HEADER is nil, articles are only excluded if the article itself
3661has been fetched."
3662
3663 ;; Logically equivalent to: (gnus-sorted-difference articles (mapcar
3664 ;; 'car gnus-agent-article-alist))
3665
3666 ;; Functionally, I don't need to construct a temp list using mapcar.
3667
3668 (if (and (or gnus-agent-cache (not gnus-plugged))
3669 (gnus-agent-load-alist group))
3670 (let* ((ref gnus-agent-article-alist)
3671 (arts articles)
3672 (uncached (list nil))
3673 (tail-uncached uncached))
3674 (while (and ref arts)
3675 (let ((v1 (car arts))
3676 (v2 (caar ref)))
3677 (cond ((< v1 v2) ; v1 does not appear in the reference list
3678 (gnus-agent-append-to-list tail-uncached v1)
3679 (setq arts (cdr arts)))
3680 ((= v1 v2)
3681 (unless (or cached-header (cdar ref)) ; v1 is already cached
3682 (gnus-agent-append-to-list tail-uncached v1))
3683 (setq arts (cdr arts))
3684 (setq ref (cdr ref)))
97610156 3685 (t ; reference article (v2) precedes the list being filtered
23f87bed
MB		 3686 (setq ref (cdr ref))))))
3687 (while arts
3688 (gnus-agent-append-to-list tail-uncached (pop arts)))
3689 (cdr uncached))
3690 ;; if gnus-agent-load-alist fails, no articles are cached.
3691 articles))
3692
3693(defun gnus-agent-retrieve-headers (articles group &optional fetch-old)
3694 (save-excursion
3695 (gnus-agent-create-buffer)
3696 (let ((gnus-decode-encoded-word-function 'identity)
5cedca8d 3697 (gnus-decode-encoded-address-function 'identity)
23f87bed 3698 (file (gnus-agent-article-name ".overview" group))
c2e9e9ef 3699 uncached-articles
01c52d31 3700 (file-name-coding-system nnmail-pathname-coding-system))
23f87bed
MB		 3701 (gnus-make-directory (nnheader-translate-file-chars
3702 (file-name-directory file) t))
3703
71cca84d
G		 3704 (when fetch-old
3705 (setq articles (gnus-uncompress-range
3706 (cons (if (numberp fetch-old)
3707 (max 1 (- (car articles) fetch-old))
3708 1)
3709 (car (last articles))))))
3710
23f87bed
MB		 3711 ;; Populate temp buffer with known headers
3712 (when (file-exists-p file)
3713 (with-current-buffer gnus-agent-overview-buffer
3714 (erase-buffer)
3715 (let ((nnheader-file-coding-system
3716 gnus-agent-file-coding-system))
3717 (nnheader-insert-nov-file file (car articles)))))
3718
3719 (if (setq uncached-articles (gnus-agent-uncached-articles articles group
3720 t))
3721 (progn
3722 ;; Populate nntp-server-buffer with uncached headers
3723 (set-buffer nntp-server-buffer)
3724 (erase-buffer)
3725 (cond ((not (eq 'nov (let (gnus-agent) ; Turn off agent
3726 (gnus-retrieve-headers
4478e074 3727 uncached-articles group))))
23f87bed
MB		 3728 (nnvirtual-convert-headers))
3729 ((eq 'nntp (car gnus-current-select-method))
3730 ;; The author of gnus-get-newsgroup-headers-xover
3731 ;; reports that the XOVER command is commonly
3732 ;; unreliable. The problem is that recently
3733 ;; posted articles may not be entered into the
3734 ;; NOV database in time to respond to my XOVER
3735 ;; query.
3736 ;;
3737 ;; I'm going to use his assumption that the NOV
3738 ;; database is updated in order of ascending
3739 ;; article ID. Therefore, a response containing
3740 ;; article ID N implies that all articles from 1
3741 ;; to N-1 are up-to-date. Therefore, missing
3742 ;; articles in that range have expired.
3743
3744 (set-buffer nntp-server-buffer)
3745 (let* ((fetched-articles (list nil))
3746 (tail-fetched-articles fetched-articles)
71cca84d 3747 (min (car articles))
23f87bed
MB		 3748 (max (car (last articles))))
3749
3750 ;; Get the list of articles that were fetched
3751 (goto-char (point-min))
54506618
MB		 3752 (let ((pm (point-max))
3753 art)
23f87bed 3754 (while (< (point) pm)
54506618
MB		 3755 (when (setq art (gnus-agent-read-article-number))
3756 (gnus-agent-append-to-list tail-fetched-articles art))
23f87bed
MB		 3757 (forward-line 1)))
3758
3759 ;; Clip this list to the headers that will
3760 ;; actually be returned
3761 (setq fetched-articles (gnus-list-range-intersection
3762 (cdr fetched-articles)
3763 (cons min max)))
3764
3765 ;; Clip the uncached articles list to exclude
3766 ;; IDs after the last FETCHED header. The
3767 ;; excluded IDs may be fetchable using HEAD.
3768 (if (car tail-fetched-articles)
3769 (setq uncached-articles
3770 (gnus-list-range-intersection
3771 uncached-articles
3772 (cons (car uncached-articles)
3773 (car tail-fetched-articles)))))
3774
3775 ;; Create the list of articles that were
3776 ;; "successfully" fetched. Success, in this
3777 ;; case, means that the ID should not be
3778 ;; fetched again. In the case of an expired
3779 ;; article, the header will not be fetched.
3780 (setq uncached-articles
3781 (gnus-sorted-nunion fetched-articles
3782 uncached-articles))
3783 )))
3784
3785 ;; Erase the temp buffer
3786 (set-buffer gnus-agent-overview-buffer)
3787 (erase-buffer)
3788
3789 ;; Copy the nntp-server-buffer to the temp buffer
3790 (set-buffer nntp-server-buffer)
3791 (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max))
3792
54506618
MB		 3793 ;; Merge the temp buffer with the known headers (found on
3794 ;; disk in FILE) into the nntp-server-buffer
3795 (when uncached-articles
c2e9e9ef 3796 (gnus-agent-braid-nov uncached-articles file))
23f87bed 3797
54506618 3798 ;; Save the new set of known headers to FILE
23f87bed
MB		 3799 (set-buffer nntp-server-buffer)
3800 (let ((coding-system-for-write
3801 gnus-agent-file-coding-system))
3802 (gnus-agent-check-overview-buffer)
3803 (write-region (point-min) (point-max) file nil 'silent))
3804
01c52d31
MB		 3805 (gnus-agent-update-view-total-fetched-for group t)
3806
23f87bed
MB		 3807 ;; Update the group's article alist to include the newly
3808 ;; fetched articles.
3809 (gnus-agent-load-alist group)
3810 (gnus-agent-save-alist group uncached-articles nil)
3811 )
3812
3813 ;; Copy the temp buffer to the nntp-server-buffer
3814 (set-buffer nntp-server-buffer)
3815 (erase-buffer)
3816 (insert-buffer-substring gnus-agent-overview-buffer)))
3817
3818 (if (and fetch-old
3819 (not (numberp fetch-old)))
3820 t ; Don't remove anything.
3821 (nnheader-nov-delete-outside-range
71cca84d 3822 (car articles)
23f87bed
MB		 3823 (car (last articles)))
3824 t)
3825
3826 'nov))
3827
3828(defun gnus-agent-request-article (article group)
3829 "Retrieve ARTICLE in GROUP from the agent cache."
3830 (when (and gnus-agent
3831 (or gnus-agent-cache
3832 (not gnus-plugged))
3833 (numberp article))
3834 (let* ((gnus-command-method (gnus-find-method-for-group group))
3835 (file (gnus-agent-article-name (number-to-string article) group))
01c52d31
MB		 3836 (buffer-read-only nil)
3837 (file-name-coding-system nnmail-pathname-coding-system))
23f87bed
MB		 3838 (when (and (file-exists-p file)
3839 (> (nth 7 (file-attributes file)) 0))
3840 (erase-buffer)
3841 (gnus-kill-all-overlays)
3842 (let ((coding-system-for-read gnus-cache-coding-system))
3843 (insert-file-contents file))
3844 t))))
3845
f3b146e9
LMI		 3846(defun gnus-agent-store-article (article group)
3847 (let* ((gnus-command-method (gnus-find-method-for-group group))
3848 (file (gnus-agent-article-name (number-to-string article) group))
3849 (file-name-coding-system nnmail-pathname-coding-system)
3850 (coding-system-for-write gnus-cache-coding-system))
3851 (when (not (file-exists-p file))
3852 (gnus-make-directory (file-name-directory file))
e7719ea1
G		 3853 (write-region (point-min) (point-max) file nil 'silent)
3854 ;; Tell the Agent when the article was fetched, so that it can
3855 ;; be expired later.
3856 (gnus-agent-load-alist group)
3857 (gnus-agent-save-alist group (list article)
3858 (time-to-days (current-time))))))
f3b146e9 3859
23f87bed
MB		 3860(defun gnus-agent-regenerate-group (group &optional reread)
3861 "Regenerate GROUP.
3862If REREAD is t, all articles in the .overview are marked as unread.
3863If REREAD is a list, the specified articles will be marked as unread.
3864In addition, their NOV entries in .overview will be refreshed using
3865the articles' current headers.
3866If REREAD is not nil, downloaded articles are marked as unread."
3867 (interactive
01c52d31 3868 (list (gnus-agent-read-group)
23f87bed
MB		 3869 (catch 'mark
3870 (while (let (c
3871 (cursor-in-echo-area t)
3872 (echo-keystrokes 0))
3873 (message "Mark as unread: (n)one / (a)ll / all (d)ownloaded articles? (n) ")
3874 (setq c (read-char-exclusive))
3875
3876 (cond ((or (eq c ?\r) (eq c ?n) (eq c ?N))
3877 (throw 'mark nil))
3878 ((or (eq c ?a) (eq c ?A))
3879 (throw 'mark t))
3880 ((or (eq c ?d) (eq c ?D))
3881 (throw 'mark 'some)))
3882 (gnus-message 3 "Ignoring unexpected input")
3883 (sit-for 1)
3884 t)))))
23f87bed 3885 (when group
ec7995fa 3886 (gnus-message 5 "Regenerating in %s" (gnus-agent-decoded-group-name group))
01c52d31
MB		 3887 (let* ((gnus-command-method (or gnus-command-method
3888 (gnus-find-method-for-group group)))
3889 (file (gnus-agent-article-name ".overview" group))
3890 (dir (file-name-directory file))
01c52d31
MB		 3891 (file-name-coding-system nnmail-pathname-coding-system)
3892 (downloaded (if (file-exists-p dir)
655591a7 3893 (sort (delq nil (mapcar (lambda (name)
26c9afc3
MB		 3894 (and (not (file-directory-p (nnheader-concat dir name)))
3895 (string-to-number name)))
3896 (directory-files dir nil "^[0-9]+$" t)))
01c52d31
MB		 3897 '>)
3898 (progn (gnus-make-directory dir) nil)))
c2e9e9ef 3899 nov-arts
01c52d31
MB		 3900 alist header
3901 regenerated)
3902
3903 (mm-with-unibyte-buffer
3904 (if (file-exists-p file)
3905 (let ((nnheader-file-coding-system
3906 gnus-agent-file-coding-system))
3907 (nnheader-insert-file-contents file)))
3908 (set-buffer-modified-p nil)
3909
3910 ;; Load the article IDs found in the overview file. As a
3911 ;; side-effect, validate the file contents.
3912 (let ((load t))
3913 (while load
3914 (setq load nil)
3915 (goto-char (point-min))
3916 (while (< (point) (point-max))
3917 (cond ((and (looking-at "[0-9]+\t")
3918 (<= (- (match-end 0) (match-beginning 0)) 9))
3919 (push (read (current-buffer)) nov-arts)
3920 (forward-line 1)
3921 (let ((l1 (car nov-arts))
3922 (l2 (cadr nov-arts)))
3923 (cond ((and (listp reread) (memq l1 reread))
3924 (gnus-delete-line)
3925 (setq nov-arts (cdr nov-arts))
3926 (gnus-message 4 "gnus-agent-regenerate-group: NOV\
54506618 3927 entry of article %s deleted." l1))
01c52d31
MB		 3928 ((not l2)
3929 nil)
3930 ((< l1 l2)
3931 (gnus-message 3 "gnus-agent-regenerate-group: NOV\
23f87bed 3932 entries are NOT in ascending order.")
01c52d31
MB		 3933 ;; Don't sort now as I haven't verified
3934 ;; that every line begins with a number
3935 (setq load t))
3936 ((= l1 l2)
3937 (forward-line -1)
3938 (gnus-message 4 "gnus-agent-regenerate-group: NOV\
3939 entries contained duplicate of article %s. Duplicate deleted." l1)
3940 (gnus-delete-line)
3941 (setq nov-arts (cdr nov-arts))))))
3942 (t
3943 (gnus-message 1 "gnus-agent-regenerate-group: NOV\
23f87bed
MB		 3944 entries contained line that did not begin with an article number. Deleted\
3945 line.")
01c52d31
MB		 3946 (gnus-delete-line))))
3947 (when load
3948 (gnus-message 5 "gnus-agent-regenerate-group: Sorting NOV\
23f87bed 3949 entries into ascending order.")
01c52d31
MB		 3950 (sort-numeric-fields 1 (point-min) (point-max))
3951 (setq nov-arts nil))))
3952 (gnus-agent-check-overview-buffer)
3953
3954 ;; Construct a new article alist whose nodes match every header
3955 ;; in the .overview file. As a side-effect, missing headers are
3956 ;; reconstructed from the downloaded article file.
3957 (while (or downloaded nov-arts)
3958 (cond ((and downloaded
3959 (or (not nov-arts)
3960 (> (car downloaded) (car nov-arts))))
3961 ;; This entry is missing from the overview file
ec7995fa
KY		 3962 (gnus-message 3 "Regenerating NOV %s %d..."
3963 (gnus-agent-decoded-group-name group)
01c52d31
MB		 3964 (car downloaded))
3965 (let ((file (concat dir (number-to-string (car downloaded)))))
3966 (mm-with-unibyte-buffer
3967 (nnheader-insert-file-contents file)
3968 (nnheader-remove-body)
3969 (setq header (nnheader-parse-naked-head)))
3970 (mail-header-set-number header (car downloaded))
3971 (if nov-arts
3972 (let ((key (concat "^" (int-to-string (car nov-arts))
3973 "\t")))
3974 (or (re-search-backward key nil t)
3975 (re-search-forward key))
3976 (forward-line 1))
3977 (goto-char (point-min)))
3978 (nnheader-insert-nov header))
3979 (setq nov-arts (cons (car downloaded) nov-arts)))
3980 ((eq (car downloaded) (car nov-arts))
3981 ;; This entry in the overview has been downloaded
3982 (push (cons (car downloaded)
3983 (time-to-days
3984 (nth 5 (file-attributes
3985 (concat dir (number-to-string
3986 (car downloaded))))))) alist)
3987 (setq downloaded (cdr downloaded))
3988 (setq nov-arts (cdr nov-arts)))
3989 (t
3990 ;; This entry in the overview has not been downloaded
3991 (push (cons (car nov-arts) nil) alist)
3992 (setq nov-arts (cdr nov-arts)))))
3993
3994 ;; When gnus-agent-consider-all-articles is set,
3995 ;; gnus-agent-regenerate-group should NOT remove article IDs from
3996 ;; the alist. Those IDs serve as markers to indicate that an
3997 ;; attempt has been made to fetch that article's header.
3998
3999 ;; When gnus-agent-consider-all-articles is NOT set,
4000 ;; gnus-agent-regenerate-group can remove the article ID of every
4001 ;; article (with the exception of the last ID in the list - it's
4002 ;; special) that no longer appears in the overview. In this
9858f6c3 4003 ;; situation, the last article ID in the list implies that it,
97610156 4004 ;; and every article ID preceding it, have been fetched from the
01c52d31
MB		 4005 ;; server.
4006
4007 (if gnus-agent-consider-all-articles
4008 ;; Restore all article IDs that were not found in the overview file.
4009 (let* ((n (cons nil alist))
4010 (merged n)
4011 (o (gnus-agent-load-alist group)))
4012 (while o
4013 (let ((nID (caadr n))
4014 (oID (caar o)))
4015 (cond ((not nID)
4016 (setq n (setcdr n (list (list oID))))
4017 (setq o (cdr o)))
4018 ((< oID nID)
4019 (setcdr n (cons (list oID) (cdr n)))
4020 (setq o (cdr o)))
4021 ((= oID nID)
4022 (setq o (cdr o))
4023 (setq n (cdr n)))
4024 (t
4025 (setq n (cdr n))))))
4026 (setq alist (cdr merged)))
4027 ;; Restore the last article ID if it is not already in the new alist
4028 (let ((n (last alist))
4029 (o (last (gnus-agent-load-alist group))))
4030 (cond ((not o)
4031 nil)
4032 ((not n)
4033 (push (cons (caar o) nil) alist))
4034 ((< (caar n) (caar o))
4035 (setcdr n (list (car o)))))))
4036
4037 (let ((inhibit-quit t))
4038 (if (setq regenerated (buffer-modified-p))
4039 (let ((coding-system-for-write gnus-agent-file-coding-system))
4040 (write-region (point-min) (point-max) file nil 'silent)))
4041
4042 (setq regenerated (or regenerated
4043 (and reread gnus-agent-article-alist)
4044 (not (equal alist gnus-agent-article-alist))))
4045
4046 (setq gnus-agent-article-alist alist)
4047
4048 (when regenerated
4049 (gnus-agent-save-alist group)
4050
4051 ;; I have to alter the group's active range NOW as
4052 ;; gnus-make-ascending-articles-unread will use it to
4053 ;; recalculate the number of unread articles in the group
4054
4055 (let ((group (gnus-group-real-name group))
4056 (group-active (or (gnus-active group)
4057 (gnus-activate-group group))))
4058 (gnus-agent-possibly-alter-active group group-active)))))
4059
4060 (when (and reread gnus-agent-article-alist)
655591a7 4061 (gnus-agent-synchronize-group-flags
01c52d31 4062 group
58090a8d 4063 (list (list
01c52d31
MB		 4064 (if (listp reread)
4065 reread
4066 (delq nil (mapcar (function (lambda (c)
4067 (cond ((eq reread t)
4068 (car c))
4069 ((cdr c)
4070 (car c)))))
58090a8d
MB		 4071 gnus-agent-article-alist)))
4072 'del '(read)))
4073 gnus-command-method)
23f87bed 4074
01c52d31
MB		 4075 (when regenerated
4076 (gnus-agent-update-files-total-fetched-for group nil)))
23f87bed 4077
01c52d31
MB		 4078 (gnus-message 5 "")
4079 regenerated)))
23f87bed
MB		 4080
4081;;;###autoload
c2e9e9ef 4082(defun gnus-agent-regenerate (&optional _clean reread)
23f87bed 4083 "Regenerate all agent covered files.
c2e9e9ef
SM		 4084CLEAN is obsolete and ignored."
4085 (interactive)
23f87bed
MB		 4086 (let (regenerated)
4087 (gnus-message 4 "Regenerating Gnus agent files...")
4088 (dolist (gnus-command-method (gnus-agent-covered-methods))
c2e9e9ef
SM		 4089 (dolist (group (gnus-groups-from-server gnus-command-method))
4090 (setq regenerated (or (gnus-agent-regenerate-group group reread)
4091 regenerated))))
23f87bed
MB		 4092 (gnus-message 4 "Regenerating Gnus agent files...done")
4093
4094 regenerated))
4095
4096(defun gnus-agent-go-online (&optional force)
4097 "Switch servers into online status."
4098 (interactive (list t))
4099 (dolist (server gnus-opened-servers)
4100 (when (eq (nth 1 server) 'offline)
4101 (if (if (eq force 'ask)
4102 (gnus-y-or-n-p
4103 (format "Switch %s:%s into online status? "
4104 (caar server) (cadar server)))
4105 force)
4106 (setcar (nthcdr 1 server) 'close)))))
4107
4108(defun gnus-agent-toggle-group-plugged (group)
4109 "Toggle the status of the server of the current group."
4110 (interactive (list (gnus-group-group-name)))
4111 (let* ((method (gnus-find-method-for-group group))
4112 (status (cadr (assoc method gnus-opened-servers))))
4113 (if (eq status 'offline)
4114 (gnus-server-set-status method 'closed)
4115 (gnus-close-server method)
4116 (gnus-server-set-status method 'offline))
4117 (message "Turn %s:%s from %s to %s." (car method) (cadr method)
4118 (if (eq status 'offline) 'offline 'online)
4119 (if (eq status 'offline) 'online 'offline))))
4120
4121(defun gnus-agent-group-covered-p (group)
4122 (gnus-agent-method-p (gnus-group-method group)))
4123
84254bbd
LI		 4124(defun gnus-agent-update-files-total-fetched-for (group delta
4125 &optional method path)
01c52d31
MB		 4126 "Update, or set, the total disk space used by the articles that the
4127agent has fetched."
4128 (when gnus-agent-total-fetched-hashtb
4129 (gnus-agent-with-refreshed-group
4130 group
4131 ;; if null, gnus-agent-group-pathname will calc method.
4132 (let* ((gnus-command-method method)
4133 (path (or path (gnus-agent-group-pathname group)))
4134 (entry (or (gnus-gethash path gnus-agent-total-fetched-hashtb)
4135 (gnus-sethash path (make-list 3 0)
4136 gnus-agent-total-fetched-hashtb)))
4137 (file-name-coding-system nnmail-pathname-coding-system))
84254bbd
LI		 4138 (when (file-exists-p path)
4139 (when (listp delta)
4140 (if delta
4141 (let ((sum 0.0)
4142 file)
4143 (while (setq file (pop delta))
4144 (incf sum (float (or (nth 7 (file-attributes
4145 (nnheader-concat
4146 path
4147 (if (numberp file)
4148 (number-to-string file)
4149 file)))) 0))))
4150 (setq delta sum))
4151 (let ((sum (- (nth 2 entry)))
4152 (info (directory-files-and-attributes
4153 path nil "^-?[0-9]+$" t))
01c52d31 4154 file)
84254bbd
LI		 4155 (while (setq file (pop info))
4156 (incf sum (float (or (nth 8 file) 0))))
4157 (setq delta sum))))
4158
4159 (setq gnus-agent-need-update-total-fetched-for t)
4160 (incf (nth 2 entry) delta))))))
01c52d31
MB		 4161
4162(defun gnus-agent-update-view-total-fetched-for
4163 (group agent-over &optional method path)
4164 "Update, or set, the total disk space used by the .agentview and
4165.overview files. These files are calculated separately as they can be
4166modified."
4167 (when gnus-agent-total-fetched-hashtb
4168 (gnus-agent-with-refreshed-group
4169 group
4170 ;; if null, gnus-agent-group-pathname will calc method.
4171 (let* ((gnus-command-method method)
4172 (path (or path (gnus-agent-group-pathname group)))
4173 (entry (or (gnus-gethash path gnus-agent-total-fetched-hashtb)
4174 (gnus-sethash path (make-list 3 0)
4175 gnus-agent-total-fetched-hashtb)))
4176 (file-name-coding-system nnmail-pathname-coding-system)
4177 (size (or (nth 7 (file-attributes
4178 (nnheader-concat
4179 path (if agent-over
4180 ".overview"
4181 ".agentview"))))
4182 0)))
4183 (setq gnus-agent-need-update-total-fetched-for t)
4184 (setf (nth (if agent-over 1 0) entry) size)))))
4185
4186(defun gnus-agent-total-fetched-for (group &optional method no-inhibit)
4187 "Get the total disk space used by the specified GROUP."
4188 (unless (equal group "dummy.group")
4189 (unless gnus-agent-total-fetched-hashtb
4190 (setq gnus-agent-total-fetched-hashtb (gnus-make-hashtable 1024)))
4191
4192 ;; if null, gnus-agent-group-pathname will calc method.
4193 (let* ((gnus-command-method method)
4194 (path (gnus-agent-group-pathname group))
4195 (entry (gnus-gethash path gnus-agent-total-fetched-hashtb)))
4196 (if entry
4197 (apply '+ entry)
4198 (let ((gnus-agent-inhibit-update-total-fetched-for (not no-inhibit)))
4199 (+
4200 (gnus-agent-update-view-total-fetched-for group nil method path)
4201 (gnus-agent-update-view-total-fetched-for group t method path)
4202 (gnus-agent-update-files-total-fetched-for group nil method path)))))))
4203
df80b09f
LMI		 4204(provide 'gnus-agent)
4205
4206;;; gnus-agent.el ends here
Unnamed repository; edit this file 'description' to name the repository.