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