git.chise.org Git - elisp/gnus.git-/blob - lisp/gnus-agent.el

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