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

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