/[emacs]/emacs/lisp/gnus/gnus-agent.el
ViewVC logotype

Diff of /emacs/lisp/gnus/gnus-agent.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

Legend:
Removed from v.1.5.8.2  
changed lines
  Added in v.1.5.8.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26