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