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

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