cgit.sxemacs.org Git - gnus/blob - lisp/gnus-agent.el

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