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

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