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

   1 ;;; gnus-agent.el --- unplugged support for Gnus
   2 ;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002
   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 (eval-when-compile
  33   (if (featurep 'xemacs)
  34       (require 'itimer)
  35     (require 'timer))
  36   (require 'cl))
  37
  38 (eval-and-compile
  39   (autoload 'gnus-server-update-server "gnus-srvr"))
  40
  41 (defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/")
  42   "Where the Gnus agent will store its files."
  43   :group 'gnus-agent
  44   :type 'directory)
  45
  46 (defcustom gnus-agent-plugged-hook nil
  47   "Hook run when plugging into the network."
  48   :group 'gnus-agent
  49   :type 'hook)
  50
  51 (defcustom gnus-agent-unplugged-hook nil
  52   "Hook run when unplugging from the network."
  53   :group 'gnus-agent
  54   :type 'hook)
  55
  56 (defcustom gnus-agent-fetched-hook nil
  57   "Hook run after finishing fetching articles."
  58   :group 'gnus-agent
  59   :type 'hook)
  60
  61 (defcustom gnus-agent-handle-level gnus-level-subscribed
  62   "Groups on levels higher than this variable will be ignored by the Agent."
  63   :group 'gnus-agent
  64   :type 'integer)
  65
  66 (defcustom gnus-agent-expire-days 7
  67   "Read articles older than this will be expired.
  68 This can also be a list of regexp/day pairs.  The regexps will
  69 be matched against group names."
  70   :group 'gnus-agent
  71   :type 'integer)
  72
  73 (defcustom gnus-agent-expire-all nil
  74   "If non-nil, also expire unread, ticked and dormant articles.
  75 If nil, only read articles will be expired."
  76   :group 'gnus-agent
  77   :type 'boolean)
  78
  79 (defcustom gnus-agent-group-mode-hook nil
  80   "Hook run in Agent group minor modes."
  81   :group 'gnus-agent
  82   :type 'hook)
  83
  84 ;; Extracted from gnus-xmas-redefine in order to preserve user settings
  85 (when (featurep 'xemacs)
  86   (add-hook 'gnus-agent-group-mode-hook 'gnus-xmas-agent-group-menu-add))
  87
  88 (defcustom gnus-agent-summary-mode-hook nil
  89   "Hook run in Agent summary minor modes."
  90   :group 'gnus-agent
  91   :type 'hook)
  92
  93 ;; Extracted from gnus-xmas-redefine in order to preserve user settings
  94 (when (featurep 'xemacs)
  95   (add-hook 'gnus-agent-summary-mode-hook 'gnus-xmas-agent-summary-menu-add))
  96
  97 (defcustom gnus-agent-server-mode-hook nil
  98   "Hook run in Agent summary minor modes."
  99   :group 'gnus-agent
 100   :type 'hook)
 101
 102 ;; Extracted from gnus-xmas-redefine in order to preserve user settings
 103 (when (featurep 'xemacs)
 104   (add-hook 'gnus-agent-server-mode-hook 'gnus-xmas-agent-server-menu-add))
 105
 106 (defcustom gnus-agent-confirmation-function 'y-or-n-p
 107   "Function to confirm when error happens."
 108   :version "21.1"
 109   :group 'gnus-agent
 110   :type 'function)
 111
 112 (defcustom gnus-agent-synchronize-flags 'ask
 113   "Indicate if flags are synchronized when you plug in.
 114 If this is `ask' the hook will query the user."
 115   :version "21.1"
 116   :type '(choice (const :tag "Always" t)
 117                  (const :tag "Never" nil)
 118                  (const :tag "Ask" ask))
 119   :group 'gnus-agent)
 120
 121 ;;; Internal variables
 122
 123 (defvar gnus-agent-history-buffers nil)
 124 (defvar gnus-agent-buffer-alist nil)
 125 (defvar gnus-agent-article-alist nil)
 126 (defvar gnus-agent-group-alist nil)
 127 (defvar gnus-agent-covered-methods nil)
 128 (defvar gnus-category-alist nil)
 129 (defvar gnus-agent-current-history nil)
 130 (defvar gnus-agent-overview-buffer nil)
 131 (defvar gnus-category-predicate-cache nil)
 132 (defvar gnus-category-group-cache nil)
 133 (defvar gnus-agent-spam-hashtb nil)
 134 (defvar gnus-agent-file-name nil)
 135 (defvar gnus-agent-send-mail-function nil)
 136 (defvar gnus-agent-file-coding-system 'raw-text)
 137
 138 ;; Dynamic variables
 139 (defvar gnus-headers)
 140 (defvar gnus-score)
 141
 142 ;;;
 143 ;;; Setup
 144 ;;;
 145
 146 (defun gnus-open-agent ()
 147   (setq gnus-agent t)
 148   (gnus-agent-read-servers)
 149   (gnus-category-read)
 150   (gnus-agent-create-buffer)
 151   (add-hook 'gnus-group-mode-hook 'gnus-agent-mode)
 152   (add-hook 'gnus-summary-mode-hook 'gnus-agent-mode)
 153   (add-hook 'gnus-server-mode-hook 'gnus-agent-mode))
 154
 155 (defun gnus-agent-create-buffer ()
 156   (if (gnus-buffer-live-p gnus-agent-overview-buffer)
 157       t
 158     (setq gnus-agent-overview-buffer
 159           (gnus-get-buffer-create " *Gnus agent overview*"))
 160     (with-current-buffer gnus-agent-overview-buffer
 161       (mm-enable-multibyte))
 162     nil))
 163
 164 (gnus-add-shutdown 'gnus-close-agent 'gnus)
 165
 166 (defun gnus-close-agent ()
 167   (setq gnus-agent-covered-methods nil
 168         gnus-category-predicate-cache nil
 169         gnus-category-group-cache nil
 170         gnus-agent-spam-hashtb nil)
 171   (gnus-kill-buffer gnus-agent-overview-buffer))
 172
 173 ;;;
 174 ;;; Utility functions
 175 ;;;
 176
 177 (defun gnus-agent-read-file (file)
 178   "Load FILE and do a `read' there."
 179   (with-temp-buffer
 180     (ignore-errors
 181       (nnheader-insert-file-contents file)
 182       (goto-char (point-min))
 183       (read (current-buffer)))))
 184
 185 (defsubst gnus-agent-method ()
 186   (concat (symbol-name (car gnus-command-method)) "/"
 187           (if (equal (cadr gnus-command-method) "")
 188               "unnamed"
 189             (cadr gnus-command-method))))
 190
 191 (defsubst gnus-agent-directory ()
 192   "Path of the Gnus agent directory."
 193   (nnheader-concat gnus-agent-directory
 194                    (nnheader-translate-file-chars (gnus-agent-method)) "/"))
 195
 196 (defun gnus-agent-lib-file (file)
 197   "The full path of the Gnus agent library FILE."
 198   (expand-file-name file
 199                     (file-name-as-directory
 200                      (expand-file-name "agent.lib" (gnus-agent-directory)))))
 201
 202 ;;; Fetching setup functions.
 203
 204 (defun gnus-agent-start-fetch ()
 205   "Initialize data structures for efficient fetching."
 206   (gnus-agent-open-history)
 207   (setq gnus-agent-current-history (gnus-agent-history-buffer))
 208   (gnus-agent-create-buffer))
 209
 210 (defun gnus-agent-stop-fetch ()
 211   "Save all data structures and clean up."
 212   (gnus-agent-save-history)
 213   (gnus-agent-close-history)
 214   (setq gnus-agent-spam-hashtb nil)
 215   (save-excursion
 216     (set-buffer nntp-server-buffer)
 217     (widen)))
 218
 219 (defmacro gnus-agent-with-fetch (&rest forms)
 220   "Do FORMS safely."
 221   `(unwind-protect
 222        (let ((gnus-agent-fetching t))
 223          (gnus-agent-start-fetch)
 224          ,@forms)
 225      (gnus-agent-stop-fetch)))
 226
 227 (put 'gnus-agent-with-fetch 'lisp-indent-function 0)
 228 (put 'gnus-agent-with-fetch 'edebug-form-spec '(body))
 229
 230 ;;;
 231 ;;; Mode infestation
 232 ;;;
 233
 234 (defvar gnus-agent-mode-hook nil
 235   "Hook run when installing agent mode.")
 236
 237 (defvar gnus-agent-mode nil)
 238 (defvar gnus-agent-mode-status '(gnus-agent-mode " Plugged"))
 239
 240 (defun gnus-agent-mode ()
 241   "Minor mode for providing a agent support in Gnus buffers."
 242   (let* ((buffer (progn (string-match "^gnus-\\(.*\\)-mode$"
 243                                       (symbol-name major-mode))
 244                         (match-string 1 (symbol-name major-mode))))
 245          (mode (intern (format "gnus-agent-%s-mode" buffer))))
 246     (set (make-local-variable 'gnus-agent-mode) t)
 247     (set mode nil)
 248     (set (make-local-variable mode) t)
 249     ;; Set up the menu.
 250     (when (gnus-visual-p 'agent-menu 'menu)
 251       (funcall (intern (format "gnus-agent-%s-make-menu-bar" buffer))))
 252     (unless (assq 'gnus-agent-mode minor-mode-alist)
 253       (push gnus-agent-mode-status minor-mode-alist))
 254     (unless (assq mode minor-mode-map-alist)
 255       (push (cons mode (symbol-value (intern (format "gnus-agent-%s-mode-map"
 256                                                      buffer))))
 257             minor-mode-map-alist))
 258     (when (eq major-mode 'gnus-group-mode)
 259       (gnus-agent-toggle-plugged gnus-plugged))
 260     (gnus-run-hooks 'gnus-agent-mode-hook
 261                     (intern (format "gnus-agent-%s-mode-hook" buffer)))))
 262
 263 (defvar gnus-agent-group-mode-map (make-sparse-keymap))
 264 (gnus-define-keys gnus-agent-group-mode-map
 265   "Ju" gnus-agent-fetch-groups
 266   "Jc" gnus-enter-category-buffer
 267   "Jj" gnus-agent-toggle-plugged
 268   "Js" gnus-agent-fetch-session
 269   "JY" gnus-agent-synchronize-flags
 270   "JS" gnus-group-send-queue
 271   "Ja" gnus-agent-add-group
 272   "Jr" gnus-agent-remove-group)
 273
 274 (defun gnus-agent-group-make-menu-bar ()
 275   (unless (boundp 'gnus-agent-group-menu)
 276     (easy-menu-define
 277      gnus-agent-group-menu gnus-agent-group-mode-map ""
 278      '("Agent"
 279        ["Toggle plugged" gnus-agent-toggle-plugged t]
 280        ["List categories" gnus-enter-category-buffer t]
 281        ["Send queue" gnus-group-send-queue gnus-plugged]
 282        ("Fetch"
 283         ["All" gnus-agent-fetch-session gnus-plugged]
 284         ["Group" gnus-agent-fetch-group gnus-plugged])))))
 285
 286 (defvar gnus-agent-summary-mode-map (make-sparse-keymap))
 287 (gnus-define-keys gnus-agent-summary-mode-map
 288   "Jj" gnus-agent-toggle-plugged
 289   "Ju" gnus-agent-summary-fetch-group
 290   "J#" gnus-agent-mark-article
 291   "J\M-#" gnus-agent-unmark-article
 292   "@" gnus-agent-toggle-mark
 293   "Jc" gnus-agent-catchup)
 294
 295 (defun gnus-agent-summary-make-menu-bar ()
 296   (unless (boundp 'gnus-agent-summary-menu)
 297     (easy-menu-define
 298      gnus-agent-summary-menu gnus-agent-summary-mode-map ""
 299      '("Agent"
 300        ["Toggle plugged" gnus-agent-toggle-plugged t]
 301        ["Mark as downloadable" gnus-agent-mark-article t]
 302        ["Unmark as downloadable" gnus-agent-unmark-article t]
 303        ["Toggle mark" gnus-agent-toggle-mark t]
 304        ["Fetch downloadable" gnus-aget-summary-fetch-group t]
 305        ["Catchup undownloaded" gnus-agent-catchup t]))))
 306
 307 (defvar gnus-agent-server-mode-map (make-sparse-keymap))
 308 (gnus-define-keys gnus-agent-server-mode-map
 309   "Jj" gnus-agent-toggle-plugged
 310   "Ja" gnus-agent-add-server
 311   "Jr" gnus-agent-remove-server)
 312
 313 (defun gnus-agent-server-make-menu-bar ()
 314   (unless (boundp 'gnus-agent-server-menu)
 315     (easy-menu-define
 316      gnus-agent-server-menu gnus-agent-server-mode-map ""
 317      '("Agent"
 318        ["Toggle plugged" gnus-agent-toggle-plugged t]
 319        ["Add" gnus-agent-add-server t]
 320        ["Remove" gnus-agent-remove-server t]))))
 321
 322 (defun gnus-agent-make-mode-line-string (string mouse-button mouse-func)
 323   (if (and (fboundp 'propertize)
 324            (fboundp 'make-mode-line-mouse-map))
 325       (propertize string 'local-map
 326                   (make-mode-line-mouse-map mouse-button mouse-func))
 327     string))
 328
 329 (defun gnus-agent-toggle-plugged (plugged)
 330   "Toggle whether Gnus is unplugged or not."
 331   (interactive (list (not gnus-plugged)))
 332   (if plugged
 333       (progn
 334         (setq gnus-plugged plugged)
 335         (gnus-agent-possibly-synchronize-flags)
 336         (gnus-run-hooks 'gnus-agent-plugged-hook)
 337         (setcar (cdr gnus-agent-mode-status)
 338                 (gnus-agent-make-mode-line-string " Plugged"
 339                                                   'mouse-2
 340                                                   'gnus-agent-toggle-plugged)))
 341     (gnus-agent-close-connections)
 342     (setq gnus-plugged plugged)
 343     (gnus-run-hooks 'gnus-agent-unplugged-hook)
 344     (setcar (cdr gnus-agent-mode-status)
 345             (gnus-agent-make-mode-line-string " Unplugged"
 346                                               'mouse-2
 347                                               'gnus-agent-toggle-plugged)))
 348   (set-buffer-modified-p t))
 349
 350 (defun gnus-agent-close-connections ()
 351   "Close all methods covered by the Gnus agent."
 352   (let ((methods gnus-agent-covered-methods))
 353     (while methods
 354       (gnus-close-server (pop methods)))))
 355
 356 ;;;###autoload
 357 (defun gnus-unplugged ()
 358   "Start Gnus unplugged."
 359   (interactive)
 360   (setq gnus-plugged nil)
 361   (gnus))
 362
 363 ;;;###autoload
 364 (defun gnus-plugged ()
 365   "Start Gnus plugged."
 366   (interactive)
 367   (setq gnus-plugged t)
 368   (gnus))
 369
 370 ;;;###autoload
 371 (defun gnus-agentize ()
 372   "Allow Gnus to be an offline newsreader.
 373 The normal usage of this command is to put the following as the
 374 last form in your `.gnus.el' file:
 375
 376 \(gnus-agentize)
 377
 378 This will modify the `gnus-setup-news-hook', and
 379 `message-send-mail-real-function' variables, and install the Gnus agent
 380 minor mode in all Gnus buffers."
 381   (interactive)
 382   (gnus-open-agent)
 383   (add-hook 'gnus-setup-news-hook 'gnus-agent-queue-setup)
 384   (unless gnus-agent-send-mail-function
 385     (setq gnus-agent-send-mail-function (or
 386                                          message-send-mail-real-function
 387                                          message-send-mail-function)
 388           message-send-mail-real-function 'gnus-agent-send-mail))
 389   (unless gnus-agent-covered-methods
 390     (setq gnus-agent-covered-methods (list gnus-select-method))))
 391
 392 (defun gnus-agent-queue-setup ()
 393   "Make sure the queue group exists."
 394   (unless (gnus-gethash "nndraft:queue" gnus-newsrc-hashtb)
 395     (gnus-request-create-group "queue" '(nndraft ""))
 396     (let ((gnus-level-default-subscribed 1))
 397       (gnus-subscribe-group "nndraft:queue" nil '(nndraft "")))
 398     (gnus-group-set-parameter
 399      "nndraft:queue" 'gnus-dummy '((gnus-draft-mode)))))
 400
 401 (defun gnus-agent-send-mail ()
 402   (if gnus-plugged
 403       (funcall gnus-agent-send-mail-function)
 404     (goto-char (point-min))
 405     (re-search-forward
 406      (concat "^" (regexp-quote mail-header-separator) "\n"))
 407     (replace-match "\n")
 408     (gnus-agent-insert-meta-information 'mail)
 409     (gnus-request-accept-article "nndraft:queue" nil t t)))
 410
 411 (defun gnus-agent-insert-meta-information (type &optional method)
 412   "Insert meta-information into the message that says how it's to be posted.
 413 TYPE can be either `mail' or `news'.  If the latter, then METHOD can
 414 be a select method."
 415   (save-excursion
 416     (message-remove-header gnus-agent-meta-information-header)
 417     (goto-char (point-min))
 418     (insert gnus-agent-meta-information-header ": "
 419             (symbol-name type) " " (format "%S" method)
 420             "\n")
 421     (forward-char -1)
 422     (while (search-backward "\n" nil t)
 423       (replace-match "\\n" t t))))
 424
 425 (defun gnus-agent-restore-gcc ()
 426   "Restore GCC field from saved header."
 427   (save-excursion
 428     (goto-char (point-min))
 429     (while (re-search-forward (concat gnus-agent-gcc-header ":") nil t)
 430       (replace-match "Gcc:" 'fixedcase))))
 431
 432 (defun gnus-agent-any-covered-gcc ()
 433   (save-restriction
 434     (message-narrow-to-headers)
 435     (let* ((gcc (mail-fetch-field "gcc" nil t))
 436            (methods (and gcc
 437                          (mapcar 'gnus-inews-group-method
 438                                  (message-unquote-tokens
 439                                   (message-tokenize-header
 440                                    gcc " ,")))))
 441            covered)
 442       (while (and (not covered) methods)
 443         (setq covered (gnus-agent-method-p (car methods))
 444               methods (cdr methods)))
 445       covered)))
 446
 447 (defun gnus-agent-possibly-save-gcc ()
 448   "Save GCC if Gnus is unplugged."
 449   (when (and (not gnus-plugged) (gnus-agent-any-covered-gcc))
 450     (save-excursion
 451       (goto-char (point-min))
 452       (let ((case-fold-search t))
 453         (while (re-search-forward "^gcc:" nil t)
 454           (replace-match (concat gnus-agent-gcc-header ":") 'fixedcase))))))
 455
 456 (defun gnus-agent-possibly-do-gcc ()
 457   "Do GCC if Gnus is plugged."
 458   (when (or gnus-plugged (not (gnus-agent-any-covered-gcc)))
 459     (gnus-inews-do-gcc)))
 460
 461 ;;;
 462 ;;; Group mode commands
 463 ;;;
 464
 465 (defun gnus-agent-fetch-groups (n)
 466   "Put all new articles in the current groups into the Agent."
 467   (interactive "P")
 468   (unless gnus-plugged
 469     (error "Groups can't be fetched when Gnus is unplugged"))
 470   (gnus-group-iterate n 'gnus-agent-fetch-group))
 471
 472 (defun gnus-agent-fetch-group (group)
 473   "Put all new articles in GROUP into the Agent."
 474   (interactive (list (gnus-group-group-name)))
 475   (let ((state gnus-plugged))
 476     (unwind-protect
 477         (progn
 478           (unless group
 479             (error "No group on the current line"))
 480           (unless state
 481             (gnus-agent-toggle-plugged gnus-plugged))
 482           (let ((gnus-command-method (gnus-find-method-for-group group)))
 483             (gnus-agent-with-fetch
 484               (gnus-agent-fetch-group-1 group gnus-command-method)
 485               (gnus-message 5 "Fetching %s...done" group))))
 486       (when (and (not state)
 487                  gnus-plugged)
 488         (gnus-agent-toggle-plugged gnus-plugged)))))
 489
 490 (defun gnus-agent-add-group (category arg)
 491   "Add the current group to an agent category."
 492   (interactive
 493    (list
 494     (intern
 495      (completing-read
 496       "Add to category: "
 497       (mapcar (lambda (cat) (list (symbol-name (car cat))))
 498               gnus-category-alist)
 499       nil t))
 500     current-prefix-arg))
 501   (let ((cat (assq category gnus-category-alist))
 502         c groups)
 503     (gnus-group-iterate arg
 504       (lambda (group)
 505         (when (cadddr (setq c (gnus-group-category group)))
 506           (setf (cadddr c) (delete group (cadddr c))))
 507         (push group groups)))
 508     (setf (cadddr cat) (nconc (cadddr cat) groups))
 509     (gnus-category-write)))
 510
 511 (defun gnus-agent-remove-group (arg)
 512   "Remove the current group from its agent category, if any."
 513   (interactive "P")
 514   (let (c)
 515     (gnus-group-iterate arg
 516       (lambda (group)
 517         (when (cadddr (setq c (gnus-group-category group)))
 518           (setf (cadddr c) (delete group (cadddr c))))))
 519     (gnus-category-write)))
 520
 521 (defun gnus-agent-synchronize-flags ()
 522   "Synchronize unplugged flags with servers."
 523   (interactive)
 524   (save-excursion
 525     (dolist (gnus-command-method gnus-agent-covered-methods)
 526       (when (file-exists-p (gnus-agent-lib-file "flags"))
 527         (gnus-agent-synchronize-flags-server gnus-command-method)))))
 528
 529 (defun gnus-agent-possibly-synchronize-flags ()
 530   "Synchronize flags according to `gnus-agent-synchronize-flags'."
 531   (interactive)
 532   (save-excursion
 533     (dolist (gnus-command-method gnus-agent-covered-methods)
 534       (when (file-exists-p (gnus-agent-lib-file "flags"))
 535         (gnus-agent-possibly-synchronize-flags-server gnus-command-method)))))
 536
 537 (defun gnus-agent-synchronize-flags-server (method)
 538   "Synchronize flags set when unplugged for server."
 539   (let ((gnus-command-method method))
 540     (when (file-exists-p (gnus-agent-lib-file "flags"))
 541       (set-buffer (get-buffer-create " *Gnus Agent flag synchronize*"))
 542       (erase-buffer)
 543       (nnheader-insert-file-contents (gnus-agent-lib-file "flags"))
 544       (if (null (gnus-check-server gnus-command-method))
 545           (message "Couldn't open server %s" (nth 1 gnus-command-method))
 546         (while (not (eobp))
 547           (if (null (eval (read (current-buffer))))
 548               (progn (forward-line)
 549                      (kill-line -1))
 550             (write-file (gnus-agent-lib-file "flags"))
 551             (error "Couldn't set flags from file %s"
 552                    (gnus-agent-lib-file "flags"))))
 553         (delete-file (gnus-agent-lib-file "flags")))
 554       (kill-buffer nil))))
 555
 556 (defun gnus-agent-possibly-synchronize-flags-server (method)
 557   "Synchronize flags for server according to `gnus-agent-synchronize-flags'."
 558   (when (or (and gnus-agent-synchronize-flags
 559                  (not (eq gnus-agent-synchronize-flags 'ask)))
 560             (and (eq gnus-agent-synchronize-flags 'ask)
 561                  (gnus-y-or-n-p (format "Synchronize flags on server `%s'? "
 562                                         (cadr method)))))
 563     (gnus-agent-synchronize-flags-server method)))
 564
 565 ;;;
 566 ;;; Server mode commands
 567 ;;;
 568
 569 (defun gnus-agent-add-server (server)
 570   "Enroll SERVER in the agent program."
 571   (interactive (list (gnus-server-server-name)))
 572   (unless server
 573     (error "No server on the current line"))
 574   (let ((method (gnus-server-get-method nil (gnus-server-server-name))))
 575     (when (gnus-agent-method-p method)
 576       (error "Server already in the agent program"))
 577     (push method gnus-agent-covered-methods)
 578     (gnus-server-update-server server)
 579     (gnus-agent-write-servers)
 580     (message "Entered %s into the Agent" server)))
 581
 582 (defun gnus-agent-remove-server (server)
 583   "Remove SERVER from the agent program."
 584   (interactive (list (gnus-server-server-name)))
 585   (unless server
 586     (error "No server on the current line"))
 587   (let ((method (gnus-server-get-method nil (gnus-server-server-name))))
 588     (unless (gnus-agent-method-p method)
 589       (error "Server not in the agent program"))
 590     (setq gnus-agent-covered-methods
 591           (delete method gnus-agent-covered-methods))
 592     (gnus-server-update-server server)
 593     (gnus-agent-write-servers)
 594     (message "Removed %s from the agent" server)))
 595
 596 (defun gnus-agent-read-servers ()
 597   "Read the alist of covered servers."
 598   (setq gnus-agent-covered-methods
 599         (gnus-agent-read-file
 600          (nnheader-concat gnus-agent-directory "lib/servers"))))
 601
 602 (defun gnus-agent-write-servers ()
 603   "Write the alist of covered servers."
 604   (gnus-make-directory (nnheader-concat gnus-agent-directory "lib"))
 605   (let ((coding-system-for-write nnheader-file-coding-system)
 606         (file-name-coding-system nnmail-pathname-coding-system))
 607     (with-temp-file (nnheader-concat gnus-agent-directory "lib/servers")
 608       (prin1 gnus-agent-covered-methods (current-buffer)))))
 609
 610 ;;;
 611 ;;; Summary commands
 612 ;;;
 613
 614 (defun gnus-agent-mark-article (n &optional unmark)
 615   "Mark the next N articles as downloadable.
 616 If N is negative, mark backward instead.  If UNMARK is non-nil, remove
 617 the mark instead.  The difference between N and the actual number of
 618 articles marked is returned."
 619   (interactive "p")
 620   (let ((backward (< n 0))
 621         (n (abs n)))
 622     (while (and
 623             (> n 0)
 624             (progn
 625               (gnus-summary-set-agent-mark
 626                (gnus-summary-article-number) unmark)
 627               (zerop (gnus-summary-next-subject (if backward -1 1) nil t))))
 628       (setq n (1- n)))
 629     (when (/= 0 n)
 630       (gnus-message 7 "No more articles"))
 631     (gnus-summary-recenter)
 632     (gnus-summary-position-point)
 633     n))
 634
 635 (defun gnus-agent-unmark-article (n)
 636   "Remove the downloadable mark from the next N articles.
 637 If N is negative, unmark backward instead.  The difference between N and
 638 the actual number of articles unmarked is returned."
 639   (interactive "p")
 640   (gnus-agent-mark-article n t))
 641
 642 (defun gnus-agent-toggle-mark (n)
 643   "Toggle the downloadable mark from the next N articles.
 644 If N is negative, toggle backward instead.  The difference between N and
 645 the actual number of articles toggled is returned."
 646   (interactive "p")
 647   (gnus-agent-mark-article n 'toggle))
 648
 649 (defun gnus-summary-set-agent-mark (article &optional unmark)
 650   "Mark ARTICLE as downloadable."
 651   (let ((unmark (if (and (not (null unmark)) (not (eq t unmark)))
 652                     (memq article gnus-newsgroup-downloadable)
 653                   unmark)))
 654     (if unmark
 655         (progn
 656           (setq gnus-newsgroup-downloadable
 657                 (delq article gnus-newsgroup-downloadable))
 658           (push article gnus-newsgroup-undownloaded))
 659       (setq gnus-newsgroup-undownloaded
 660             (delq article gnus-newsgroup-undownloaded))
 661       (push article gnus-newsgroup-downloadable))
 662     (gnus-summary-update-mark
 663      (if unmark gnus-undownloaded-mark gnus-downloadable-mark)
 664      'unread)))
 665
 666 (defun gnus-agent-get-undownloaded-list ()
 667   "Mark all unfetched articles as read."
 668   (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name)))
 669     (when (and (not gnus-plugged)
 670                (gnus-agent-method-p gnus-command-method))
 671       (gnus-agent-load-alist gnus-newsgroup-name)
 672       ;; First mark all undownloaded articles as undownloaded.
 673       (dolist (article (mapcar (lambda (header) (mail-header-number header))
 674                                gnus-newsgroup-headers))
 675         (unless (or (cdr (assq article gnus-agent-article-alist))
 676                     (memq article gnus-newsgroup-downloadable)
 677                     (memq article gnus-newsgroup-cached))
 678           (push article gnus-newsgroup-undownloaded)))
 679       ;; Then mark downloaded downloadable as not-downloadable,
 680       ;; if you get my drift.
 681       (dolist (article gnus-newsgroup-downloadable)
 682         (when (cdr (assq article gnus-agent-article-alist))
 683           (setq gnus-newsgroup-downloadable
 684                 (delq article gnus-newsgroup-downloadable)))))))
 685
 686 (defun gnus-agent-catchup ()
 687   "Mark all undownloaded articles as read."
 688   (interactive)
 689   (save-excursion
 690     (while gnus-newsgroup-undownloaded
 691       (gnus-summary-mark-article
 692        (pop gnus-newsgroup-undownloaded) gnus-catchup-mark)))
 693   (gnus-summary-position-point))
 694
 695 (defun gnus-agent-summary-fetch-group ()
 696   "Fetch the downloadable articles in the group."
 697   (interactive)
 698   (let ((articles gnus-newsgroup-downloadable)
 699         (gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))
 700         (state gnus-plugged))
 701     (unwind-protect
 702         (progn
 703           (unless state
 704             (gnus-agent-toggle-plugged t))
 705           (unless articles
 706             (error "No articles to download"))
 707           (gnus-agent-with-fetch
 708             (gnus-agent-fetch-articles gnus-newsgroup-name articles))
 709           (save-excursion
 710             (dolist (article articles)
 711               (setq gnus-newsgroup-downloadable
 712                     (delq article gnus-newsgroup-downloadable))
 713               (gnus-summary-mark-article article gnus-unread-mark))))
 714       (when (and (not state)
 715                  gnus-plugged)
 716         (gnus-agent-toggle-plugged nil)))))
 717
 718 ;;;
 719 ;;; Internal functions
 720 ;;;
 721
 722 (defun gnus-agent-save-active (method)
 723   (gnus-agent-save-active-1 method 'gnus-active-to-gnus-format))
 724
 725 (defun gnus-agent-save-active-1 (method function)
 726   (when (gnus-agent-method-p method)
 727     (let* ((gnus-command-method method)
 728            (new (gnus-make-hashtable (count-lines (point-min) (point-max))))
 729            (file (gnus-agent-lib-file "active")))
 730       (funcall function nil new)
 731       (gnus-agent-write-active file new)
 732       (erase-buffer)
 733       (nnheader-insert-file-contents file))))
 734
 735 (defun gnus-agent-write-active (file new)
 736   (let ((orig (gnus-make-hashtable (count-lines (point-min) (point-max))))
 737         (file (gnus-agent-lib-file "active"))
 738         elem osym)
 739     (when (file-exists-p file)
 740       (with-temp-buffer
 741         (nnheader-insert-file-contents file)
 742         (gnus-active-to-gnus-format nil orig))
 743       (mapatoms
 744        (lambda (sym)
 745          (when (and sym (boundp sym))
 746            (if (and (boundp (setq osym (intern (symbol-name sym) orig)))
 747                     (setq elem (symbol-value osym)))
 748                (progn
 749                  (if (and (integerp (car (symbol-value sym)))
 750                           (> (car elem) (car (symbol-value sym))))
 751                      (setcar elem (car (symbol-value sym))))
 752                  (if (integerp (cdr (symbol-value sym)))
 753                      (setcdr elem (cdr (symbol-value sym)))))
 754              (set (intern (symbol-name sym) orig) (symbol-value sym)))))
 755        new))
 756     (gnus-make-directory (file-name-directory file))
 757     (let ((coding-system-for-write gnus-agent-file-coding-system))
 758       ;; The hashtable contains real names of groups,  no more prefix
 759       ;; removing, so set `full' to `t'.
 760       (gnus-write-active-file file orig t))))
 761
 762 (defun gnus-agent-save-groups (method)
 763   (gnus-agent-save-active-1 method 'gnus-groups-to-gnus-format))
 764
 765 (defun gnus-agent-save-group-info (method group active)
 766   (when (gnus-agent-method-p method)
 767     (let* ((gnus-command-method method)
 768            (coding-system-for-write nnheader-file-coding-system)
 769            (file-name-coding-system nnmail-pathname-coding-system)
 770            (file (gnus-agent-lib-file "active"))
 771            oactive-min)
 772       (gnus-make-directory (file-name-directory file))
 773       (with-temp-file file
 774         ;; Emacs got problem to match non-ASCII group in multibyte buffer.
 775         (mm-disable-multibyte)
 776         (when (file-exists-p file)
 777           (nnheader-insert-file-contents file))
 778         (goto-char (point-min))
 779         (when (re-search-forward
 780                (concat "^" (regexp-quote group) " ") nil t)
 781           (save-excursion
 782             (read (current-buffer))                      ;; max
 783             (setq oactive-min (read (current-buffer))))  ;; min
 784           (gnus-delete-line))
 785         (insert (format "%S %d %d y\n" (intern group)
 786                         (cdr active)
 787                         (or oactive-min (car active))))
 788         (goto-char (point-max))
 789         (while (search-backward "\\." nil t)
 790           (delete-char 1))))))
 791
 792 (defun gnus-agent-group-path (group)
 793   "Translate GROUP into a path."
 794   (if nnmail-use-long-file-names
 795       (gnus-group-real-name group)
 796     (nnheader-translate-file-chars
 797      (nnheader-replace-chars-in-string
 798       (nnheader-replace-duplicate-chars-in-string
 799        (nnheader-replace-chars-in-string
 800         (gnus-group-real-name group)
 801         ?/ ?_)
 802        ?. ?_)
 803       ?. ?/))))
 804
 805 \f
 806
 807 (defun gnus-agent-method-p (method)
 808   "Say whether METHOD is covered by the agent."
 809   (member method gnus-agent-covered-methods))
 810
 811 (defun gnus-agent-get-function (method)
 812   (if (and (not gnus-plugged)
 813            (gnus-agent-method-p method))
 814       (progn
 815         (require 'nnagent)
 816         'nnagent)
 817     (car method)))
 818
 819 ;;; History functions
 820
 821 (defun gnus-agent-history-buffer ()
 822   (cdr (assoc (gnus-agent-method) gnus-agent-history-buffers)))
 823
 824 (defun gnus-agent-open-history ()
 825   (save-excursion
 826     (push (cons (gnus-agent-method)
 827                 (set-buffer (gnus-get-buffer-create
 828                              (format " *Gnus agent %s history*"
 829                                      (gnus-agent-method)))))
 830           gnus-agent-history-buffers)
 831     (mm-disable-multibyte) ;; everything is binary
 832     (erase-buffer)
 833     (insert "\n")
 834     (let ((file (gnus-agent-lib-file "history")))
 835       (when (file-exists-p file)
 836         (nnheader-insert-file-contents file))
 837       (set (make-local-variable 'gnus-agent-file-name) file))))
 838
 839 (defun gnus-agent-save-history ()
 840   (save-excursion
 841     (set-buffer gnus-agent-current-history)
 842     (gnus-make-directory (file-name-directory gnus-agent-file-name))
 843     (let ((coding-system-for-write gnus-agent-file-coding-system))
 844       (write-region (1+ (point-min)) (point-max)
 845                     gnus-agent-file-name nil 'silent))))
 846
 847 (defun gnus-agent-close-history ()
 848   (when (gnus-buffer-live-p gnus-agent-current-history)
 849     (kill-buffer gnus-agent-current-history)
 850     (setq gnus-agent-history-buffers
 851           (delq (assoc (gnus-agent-method) gnus-agent-history-buffers)
 852                 gnus-agent-history-buffers))))
 853
 854 (defun gnus-agent-enter-history (id group-arts date)
 855   (save-excursion
 856     (set-buffer gnus-agent-current-history)
 857     (goto-char (point-max))
 858     (let ((p (point)))
 859       (insert id "\t" (number-to-string date) "\t")
 860       (while group-arts
 861         (insert (format "%S" (intern (caar group-arts)))
 862                 " " (number-to-string (cdr (pop group-arts)))
 863                 " "))
 864       (insert "\n")
 865       (while (search-backward "\\." p t)
 866         (delete-char 1)))))
 867
 868 (defun gnus-agent-article-in-history-p (id)
 869   (save-excursion
 870     (set-buffer (gnus-agent-history-buffer))
 871     (goto-char (point-min))
 872     (search-forward (concat "\n" id "\t") nil t)))
 873
 874 (defun gnus-agent-history-path (id)
 875   (save-excursion
 876     (set-buffer (gnus-agent-history-buffer))
 877     (goto-char (point-min))
 878     (when (search-forward (concat "\n" id "\t") nil t)
 879       (let ((method (gnus-agent-method)))
 880         (let (paths group)
 881           (while (not (numberp (setq group (read (current-buffer)))))
 882             (push (concat method "/" group) paths))
 883           (nreverse paths))))))
 884
 885 ;;;
 886 ;;; Fetching
 887 ;;;
 888
 889 (defun gnus-agent-fetch-articles (group articles)
 890   "Fetch ARTICLES from GROUP and put them into the Agent."
 891   (when articles
 892     ;; Prune off articles that we have already fetched.
 893     (while (and articles
 894                 (cdr (assq (car articles) gnus-agent-article-alist)))
 895       (pop articles))
 896     (let ((arts articles))
 897       (while (cdr arts)
 898         (if (cdr (assq (cadr arts) gnus-agent-article-alist))
 899             (setcdr arts (cddr arts))
 900           (setq arts (cdr arts)))))
 901     (when articles
 902       (let ((dir (concat
 903                   (gnus-agent-directory)
 904                   (gnus-agent-group-path group) "/"))
 905             (date (time-to-days (current-time)))
 906             (case-fold-search t)
 907             pos crosses id elem)
 908         (gnus-make-directory dir)
 909         (gnus-message 7 "Fetching articles for %s..." group)
 910         ;; Fetch the articles from the backend.
 911         (if (gnus-check-backend-function 'retrieve-articles group)
 912             (setq pos (gnus-retrieve-articles articles group))
 913           (with-temp-buffer
 914             (let (article)
 915               (while (setq article (pop articles))
 916                 (when (or
 917                        (gnus-backlog-request-article group article
 918                                                      nntp-server-buffer)
 919                        (gnus-request-article article group))
 920                   (goto-char (point-max))
 921                   (push (cons article (point)) pos)
 922                   (insert-buffer-substring nntp-server-buffer)))
 923               (copy-to-buffer nntp-server-buffer (point-min) (point-max))
 924               (setq pos (nreverse pos)))))
 925         ;; Then save these articles into the Agent.
 926         (save-excursion
 927           (set-buffer nntp-server-buffer)
 928           (while pos
 929             (narrow-to-region (cdar pos) (or (cdadr pos) (point-max)))
 930             (goto-char (point-min))
 931             (when (search-forward "\n\n" nil t)
 932               (when (search-backward "\nXrefs: " nil t)
 933                 ;; Handle crossposting.
 934                 (skip-chars-forward "^ ")
 935                 (skip-chars-forward " ")
 936                 (setq crosses nil)
 937                 (while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) +")
 938                   (push (cons (buffer-substring (match-beginning 1)
 939                                                 (match-end 1))
 940                               (buffer-substring (match-beginning 2)
 941                                                 (match-end 2)))
 942                         crosses)
 943                   (goto-char (match-end 0)))
 944                 (gnus-agent-crosspost crosses (caar pos))))
 945             (goto-char (point-min))
 946             (if (not (re-search-forward "^Message-ID: *<\\([^>\n]+\\)>" nil t))
 947                 (setq id "No-Message-ID-in-article")
 948               (setq id (buffer-substring (match-beginning 1) (match-end 1))))
 949             (let ((coding-system-for-write
 950                    gnus-agent-file-coding-system))
 951               (write-region (point-min) (point-max)
 952                             (concat dir (number-to-string (caar pos)))
 953                             nil 'silent))
 954             (when (setq elem (assq (caar pos) gnus-agent-article-alist))
 955               (setcdr elem t))
 956             (gnus-agent-enter-history
 957              id (or crosses (list (cons group (caar pos)))) date)
 958             (widen)
 959             (pop pos)))
 960         (gnus-agent-save-alist group)))))
 961
 962 (defun gnus-agent-crosspost (crosses article)
 963   (let (gnus-agent-article-alist group alist beg end)
 964     (save-excursion
 965       (set-buffer gnus-agent-overview-buffer)
 966       (when (nnheader-find-nov-line article)
 967         (forward-word 1)
 968         (setq beg (point))
 969         (setq end (progn (forward-line 1) (point)))))
 970     (while crosses
 971       (setq group (caar crosses))
 972       (unless (setq alist (assoc group gnus-agent-group-alist))
 973         (push (setq alist (list group (gnus-agent-load-alist (caar crosses))))
 974               gnus-agent-group-alist))
 975       (setcdr alist (cons (cons (cdar crosses) t) (cdr alist)))
 976       (save-excursion
 977         (set-buffer (gnus-get-buffer-create (format " *Gnus agent overview %s*"
 978                                                     group)))
 979         (when (= (point-max) (point-min))
 980           (push (cons group (current-buffer)) gnus-agent-buffer-alist)
 981           (ignore-errors
 982             (nnheader-insert-file-contents
 983              (gnus-agent-article-name ".overview" group))))
 984         (nnheader-find-nov-line (string-to-number (cdar crosses)))
 985         (insert (string-to-number (cdar crosses)))
 986         (insert-buffer-substring gnus-agent-overview-buffer beg end))
 987       (pop crosses))))
 988
 989 (defun gnus-agent-flush-cache ()
 990   (save-excursion
 991     (while gnus-agent-buffer-alist
 992       (set-buffer (cdar gnus-agent-buffer-alist))
 993       (let ((coding-system-for-write
 994              gnus-agent-file-coding-system))
 995         (write-region (point-min) (point-max)
 996                       (gnus-agent-article-name ".overview"
 997                                                (caar gnus-agent-buffer-alist))
 998                       nil 'silent))
 999       (pop gnus-agent-buffer-alist))
1000     (while gnus-agent-group-alist
1001       (with-temp-file (caar gnus-agent-group-alist)
1002         (princ (cdar gnus-agent-group-alist))
1003         (insert "\n"))
1004       (pop gnus-agent-group-alist))))
1005
1006 (defun gnus-agent-fetch-headers (group &optional force)
1007   (let ((articles (gnus-list-of-unread-articles group))
1008         (gnus-decode-encoded-word-function 'identity)
1009         (file (gnus-agent-article-name ".overview" group)))
1010     ;; Add article with marks to list of article headers we want to fetch.
1011     (dolist (arts (gnus-info-marks (gnus-get-info group)))
1012       (setq articles (gnus-range-add articles (cdr arts))))
1013     (setq articles (sort (gnus-uncompress-sequence articles) '<))
1014     ;; Remove known articles.
1015     (when (gnus-agent-load-alist group)
1016       (setq articles (gnus-sorted-intersection
1017                       articles
1018                       (gnus-uncompress-range
1019                        (cons (1+ (caar (last gnus-agent-article-alist)))
1020                              (cdr (gnus-active group)))))))
1021     ;; Fetch them.
1022     (gnus-make-directory (nnheader-translate-file-chars
1023                           (file-name-directory file) t))
1024     (when articles
1025       (gnus-message 7 "Fetching headers for %s..." group)
1026       (save-excursion
1027         (set-buffer nntp-server-buffer)
1028         (unless (eq 'nov (gnus-retrieve-headers articles group))
1029           (nnvirtual-convert-headers))
1030         ;; Save these headers for later processing.
1031         (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max))
1032         (when (file-exists-p file)
1033           (gnus-agent-braid-nov group articles file))
1034         (let ((coding-system-for-write
1035                gnus-agent-file-coding-system))
1036           (write-region (point-min) (point-max) file nil 'silent))
1037         (gnus-agent-save-alist group articles nil)
1038         (gnus-agent-enter-history
1039          "last-header-fetched-for-session"
1040          (list (cons group (nth (- (length  articles) 1) articles)))
1041          (time-to-days (current-time)))
1042         articles))))
1043
1044 (defsubst gnus-agent-copy-nov-line (article)
1045   (let (b e)
1046     (set-buffer gnus-agent-overview-buffer)
1047     (setq b (point))
1048     (if (eq article (read (current-buffer)))
1049         (setq e (progn (forward-line 1) (point)))
1050       (progn
1051         (beginning-of-line)
1052         (setq e b)))
1053     (set-buffer nntp-server-buffer)
1054     (insert-buffer-substring gnus-agent-overview-buffer b e)))
1055
1056 (defun gnus-agent-braid-nov (group articles file)
1057   (set-buffer gnus-agent-overview-buffer)
1058   (goto-char (point-min))
1059   (set-buffer nntp-server-buffer)
1060   (erase-buffer)
1061   (nnheader-insert-file-contents file)
1062   (goto-char (point-max))
1063   (if (or (= (point-min) (point-max))
1064           (progn
1065             (forward-line -1)
1066             (< (read (current-buffer)) (car articles))))
1067       ;; We have only headers that are after the older headers,
1068       ;; so we just append them.
1069       (progn
1070         (goto-char (point-max))
1071         (insert-buffer-substring gnus-agent-overview-buffer))
1072     ;; We do it the hard way.
1073     (nnheader-find-nov-line (car articles))
1074     (gnus-agent-copy-nov-line (car articles))
1075     (pop articles)
1076     (while (and articles
1077                 (not (eobp)))
1078       (while (and (not (eobp))
1079                   (< (read (current-buffer)) (car articles)))
1080         (forward-line 1))
1081       (beginning-of-line)
1082       (unless (eobp)
1083         (gnus-agent-copy-nov-line (car articles))
1084         (setq articles (cdr articles))))
1085     (when articles
1086       (let (b e)
1087         (set-buffer gnus-agent-overview-buffer)
1088         (setq b (point)
1089               e (point-max))
1090         (set-buffer nntp-server-buffer)
1091         (insert-buffer-substring gnus-agent-overview-buffer b e)))))
1092
1093 (defun gnus-agent-load-alist (group &optional dir)
1094   "Load the article-state alist for GROUP."
1095   (setq gnus-agent-article-alist
1096         (gnus-agent-read-file
1097          (if dir
1098              (expand-file-name ".agentview" dir)
1099            (gnus-agent-article-name ".agentview" group)))))
1100
1101 (defun gnus-agent-save-alist (group &optional articles state dir)
1102   "Save the article-state alist for GROUP."
1103   (let ((file-name-coding-system nnmail-pathname-coding-system)
1104         print-level print-length)
1105       (with-temp-file (if dir
1106                           (expand-file-name ".agentview" dir)
1107                         (gnus-agent-article-name ".agentview" group))
1108         (princ (setq gnus-agent-article-alist
1109                      (nconc gnus-agent-article-alist
1110                             (mapcar (lambda (article) (cons article state))
1111                                     articles)))
1112                (current-buffer))
1113         (insert "\n"))))
1114
1115 (defun gnus-agent-article-name (article group)
1116   (expand-file-name (if (stringp article) article (string-to-number article))
1117                     (file-name-as-directory
1118                      (expand-file-name (gnus-agent-group-path group)
1119                                        (gnus-agent-directory)))))
1120
1121 (defun gnus-agent-batch-confirmation (msg)
1122   "Show error message and return t."
1123   (gnus-message 1 msg)
1124   t)
1125
1126 ;;;###autoload
1127 (defun gnus-agent-batch-fetch ()
1128   "Start Gnus and fetch session."
1129   (interactive)
1130   (gnus)
1131   (let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation))
1132     (gnus-agent-fetch-session))
1133   (gnus-group-exit))
1134
1135 (defun gnus-agent-fetch-session ()
1136   "Fetch all articles and headers that are eligible for fetching."
1137   (interactive)
1138   (unless gnus-agent-covered-methods
1139     (error "No servers are covered by the Gnus agent"))
1140   (unless gnus-plugged
1141     (error "Can't fetch articles while Gnus is unplugged"))
1142   (let ((methods gnus-agent-covered-methods)
1143         groups group gnus-command-method)
1144     (save-excursion
1145       (while methods
1146         (condition-case err
1147             (progn
1148               (setq gnus-command-method (car methods))
1149               (when (or (gnus-server-opened gnus-command-method)
1150                         (gnus-open-server gnus-command-method))
1151                 (setq groups (gnus-groups-from-server (car methods)))
1152                 (gnus-agent-with-fetch
1153                   (while (setq group (pop groups))
1154                     (when (<= (gnus-group-level group) gnus-agent-handle-level)
1155                       (gnus-agent-fetch-group-1 group gnus-command-method))))))
1156           (error
1157            (unless (funcall gnus-agent-confirmation-function
1158                             (format "Error (%s).  Continue? " err))
1159              (error "Cannot fetch articles into the Gnus agent")))
1160           (quit
1161            (unless (funcall gnus-agent-confirmation-function
1162                             (format "Quit fetching session (%s).  Continue? "
1163                                     err))
1164              (signal 'quit "Cannot fetch articles into the Gnus agent"))))
1165         (pop methods))
1166       (run-hooks 'gnus-agent-fetch-hook)
1167       (gnus-message 6 "Finished fetching articles into the Gnus agent"))))
1168
1169 (defun gnus-agent-fetch-group-1 (group method)
1170   "Fetch GROUP."
1171   (let ((gnus-command-method method)
1172         (gnus-newsgroup-name group)
1173         gnus-newsgroup-dependencies gnus-newsgroup-headers
1174         gnus-newsgroup-scored gnus-headers gnus-score
1175         gnus-use-cache articles arts
1176         category predicate info marks score-param
1177         (gnus-summary-expunge-below gnus-summary-expunge-below)
1178         (gnus-summary-mark-below gnus-summary-mark-below)
1179         (gnus-orphan-score gnus-orphan-score)
1180         ;; Maybe some other gnus-summary local variables should also
1181         ;; be put here.
1182         )
1183     (unless (gnus-check-group group)
1184       (error "Can't open server for %s" group))
1185     ;; Fetch headers.
1186     (when (and (or (gnus-active group)
1187                    (gnus-activate-group group))
1188                (setq articles (gnus-agent-fetch-headers group))
1189                (let ((nntp-server-buffer gnus-agent-overview-buffer))
1190                  ;; Parse them and see which articles we want to fetch.
1191                  (setq gnus-newsgroup-dependencies
1192                        (make-vector (length articles) 0))
1193                  (setq gnus-newsgroup-headers
1194                        (gnus-get-newsgroup-headers-xover articles nil nil
1195                                                          group))
1196                  ;; `gnus-agent-overview-buffer' may be killed for
1197                  ;; timeout reason.  If so, recreate it.
1198                  (gnus-agent-create-buffer)))
1199       (setq category (gnus-group-category group))
1200       (setq predicate
1201             (gnus-get-predicate
1202              (or (gnus-group-find-parameter group 'agent-predicate t)
1203                  (cadr category))))
1204       (if (memq predicate '(gnus-agent-true gnus-agent-false))
1205           ;; Simple implementation
1206           (setq arts (and (eq predicate 'gnus-agent-true) articles))
1207         (setq arts nil)
1208         (setq score-param
1209               (or (gnus-group-get-parameter group 'agent-score t)
1210                   (caddr category)))
1211         ;; Translate score-param into real one
1212         (cond
1213          ((not score-param))
1214          ((eq score-param 'file)
1215           (setq score-param (gnus-all-score-files group)))
1216          ((stringp (car score-param)))
1217          (t
1218           (setq score-param (list (list score-param)))))
1219         (when score-param
1220           (gnus-score-headers score-param))
1221         (while (setq gnus-headers (pop gnus-newsgroup-headers))
1222           (setq gnus-score
1223                 (or (cdr (assq (mail-header-number gnus-headers)
1224                                gnus-newsgroup-scored))
1225                     gnus-summary-default-score))
1226           (when (funcall predicate)
1227             (push (mail-header-number gnus-headers)
1228                   arts))))
1229       ;; Fetch the articles.
1230       (when arts
1231         (gnus-agent-fetch-articles group arts)))
1232     ;; Perhaps we have some additional articles to fetch.
1233     (setq arts (assq 'download (gnus-info-marks
1234                                 (setq info (gnus-get-info group)))))
1235     (when (cdr arts)
1236       (gnus-message 8 "Agent is downloading marked articles...")
1237       (gnus-agent-fetch-articles
1238        group (gnus-uncompress-range (cdr arts)))
1239       (setq marks (delq arts (gnus-info-marks info)))
1240       (gnus-info-set-marks info marks)
1241       (gnus-dribble-enter
1242        (concat "(gnus-group-set-info '"
1243                (gnus-prin1-to-string info)
1244                ")")))))
1245
1246 ;;;
1247 ;;; Agent Category Mode
1248 ;;;
1249
1250 (defvar gnus-category-mode-hook nil
1251   "Hook run in `gnus-category-mode' buffers.")
1252
1253 (defvar gnus-category-line-format "     %(%20c%): %g\n"
1254   "Format of category lines.
1255
1256 Valid specifiers include:
1257 %c  Topic name (string)
1258 %g  The number of groups in the topic (integer)
1259
1260 General format specifiers can also be used.  See
1261 (gnus)Formatting Variables.")
1262
1263 (defvar gnus-category-mode-line-format "Gnus: %%b"
1264   "The format specification for the category mode line.")
1265
1266 (defvar gnus-agent-short-article 100
1267   "Articles that have fewer lines than this are short.")
1268
1269 (defvar gnus-agent-long-article 200
1270   "Articles that have more lines than this are long.")
1271
1272 (defvar gnus-agent-low-score 0
1273   "Articles that have a score lower than this have a low score.")
1274
1275 (defvar gnus-agent-high-score 0
1276   "Articles that have a score higher than this have a high score.")
1277
1278
1279 ;;; Internal variables.
1280
1281 (defvar gnus-category-buffer "*Agent Category*")
1282
1283 (defvar gnus-category-line-format-alist
1284   `((?c gnus-tmp-name ?s)
1285     (?g gnus-tmp-groups ?d)))
1286
1287 (defvar gnus-category-mode-line-format-alist
1288   `((?u user-defined ?s)))
1289
1290 (defvar gnus-category-line-format-spec nil)
1291 (defvar gnus-category-mode-line-format-spec nil)
1292
1293 (defvar gnus-category-mode-map nil)
1294 (put 'gnus-category-mode 'mode-class 'special)
1295
1296 (unless gnus-category-mode-map
1297   (setq gnus-category-mode-map (make-sparse-keymap))
1298   (suppress-keymap gnus-category-mode-map)
1299
1300   (gnus-define-keys gnus-category-mode-map
1301     "q" gnus-category-exit
1302     "k" gnus-category-kill
1303     "c" gnus-category-copy
1304     "a" gnus-category-add
1305     "p" gnus-category-edit-predicate
1306     "g" gnus-category-edit-groups
1307     "s" gnus-category-edit-score
1308     "l" gnus-category-list
1309
1310     "\C-c\C-i" gnus-info-find-node
1311     "\C-c\C-b" gnus-bug))
1312
1313 (defvar gnus-category-menu-hook nil
1314   "*Hook run after the creation of the menu.")
1315
1316 (defun gnus-category-make-menu-bar ()
1317   (gnus-turn-off-edit-menu 'category)
1318   (unless (boundp 'gnus-category-menu)
1319     (easy-menu-define
1320      gnus-category-menu gnus-category-mode-map ""
1321      '("Categories"
1322        ["Add" gnus-category-add t]
1323        ["Kill" gnus-category-kill t]
1324        ["Copy" gnus-category-copy t]
1325        ["Edit predicate" gnus-category-edit-predicate t]
1326        ["Edit score" gnus-category-edit-score t]
1327        ["Edit groups" gnus-category-edit-groups t]
1328        ["Exit" gnus-category-exit t]))
1329
1330     (gnus-run-hooks 'gnus-category-menu-hook)))
1331
1332 (defun gnus-category-mode ()
1333   "Major mode for listing and editing agent categories.
1334
1335 All normal editing commands are switched off.
1336 \\<gnus-category-mode-map>
1337 For more in-depth information on this mode, read the manual
1338 (`\\[gnus-info-find-node]').
1339
1340 The following commands are available:
1341
1342 \\{gnus-category-mode-map}"
1343   (interactive)
1344   (when (gnus-visual-p 'category-menu 'menu)
1345     (gnus-category-make-menu-bar))
1346   (kill-all-local-variables)
1347   (gnus-simplify-mode-line)
1348   (setq major-mode 'gnus-category-mode)
1349   (setq mode-name "Category")
1350   (gnus-set-default-directory)
1351   (setq mode-line-process nil)
1352   (use-local-map gnus-category-mode-map)
1353   (buffer-disable-undo)
1354   (setq truncate-lines t)
1355   (setq buffer-read-only t)
1356   (gnus-run-hooks 'gnus-category-mode-hook))
1357
1358 (defalias 'gnus-category-position-point 'gnus-goto-colon)
1359
1360 (defun gnus-category-insert-line (category)
1361   (let* ((gnus-tmp-name (format "%s" (car category)))
1362          (gnus-tmp-groups (length (cadddr category))))
1363     (beginning-of-line)
1364     (gnus-add-text-properties
1365      (point)
1366      (prog1 (1+ (point))
1367        ;; Insert the text.
1368        (eval gnus-category-line-format-spec))
1369      (list 'gnus-category gnus-tmp-name))))
1370
1371 (defun gnus-enter-category-buffer ()
1372   "Go to the Category buffer."
1373   (interactive)
1374   (gnus-category-setup-buffer)
1375   (gnus-configure-windows 'category)
1376   (gnus-category-prepare))
1377
1378 (defun gnus-category-setup-buffer ()
1379   (unless (get-buffer gnus-category-buffer)
1380     (save-excursion
1381       (set-buffer (gnus-get-buffer-create gnus-category-buffer))
1382       (gnus-category-mode))))
1383
1384 (defun gnus-category-prepare ()
1385   (gnus-set-format 'category-mode)
1386   (gnus-set-format 'category t)
1387   (let ((alist gnus-category-alist)
1388         (buffer-read-only nil))
1389     (erase-buffer)
1390     (while alist
1391       (gnus-category-insert-line (pop alist)))
1392     (goto-char (point-min))
1393     (gnus-category-position-point)))
1394
1395 (defun gnus-category-name ()
1396   (or (get-text-property (gnus-point-at-bol) 'gnus-category)
1397       (error "No category on the current line")))
1398
1399 (defun gnus-category-read ()
1400   "Read the category alist."
1401   (setq gnus-category-alist
1402         (or (gnus-agent-read-file
1403              (nnheader-concat gnus-agent-directory "lib/categories"))
1404             (list (list 'default 'short nil nil)))))
1405
1406 (defun gnus-category-write ()
1407   "Write the category alist."
1408   (setq gnus-category-predicate-cache nil
1409         gnus-category-group-cache nil)
1410   (gnus-make-directory (nnheader-concat gnus-agent-directory "lib"))
1411   (with-temp-file (nnheader-concat gnus-agent-directory "lib/categories")
1412     (prin1 gnus-category-alist (current-buffer))))
1413
1414 (defun gnus-category-edit-predicate (category)
1415   "Edit the predicate for CATEGORY."
1416   (interactive (list (gnus-category-name)))
1417   (let ((info (assq category gnus-category-alist)))
1418     (gnus-edit-form
1419      (cadr info) (format "Editing the predicate for category %s" category)
1420      `(lambda (predicate)
1421         (setcar (cdr (assq ',category gnus-category-alist)) predicate)
1422         (gnus-category-write)
1423         (gnus-category-list)))))
1424
1425 (defun gnus-category-edit-score (category)
1426   "Edit the score expression for CATEGORY."
1427   (interactive (list (gnus-category-name)))
1428   (let ((info (assq category gnus-category-alist)))
1429     (gnus-edit-form
1430      (caddr info)
1431      (format "Editing the score expression for category %s" category)
1432      `(lambda (groups)
1433         (setcar (cddr (assq ',category gnus-category-alist)) groups)
1434         (gnus-category-write)
1435         (gnus-category-list)))))
1436
1437 (defun gnus-category-edit-groups (category)
1438   "Edit the group list for CATEGORY."
1439   (interactive (list (gnus-category-name)))
1440   (let ((info (assq category gnus-category-alist)))
1441     (gnus-edit-form
1442      (cadddr info) (format "Editing the group list for category %s" category)
1443      `(lambda (groups)
1444         (setcar (nthcdr 3 (assq ',category gnus-category-alist)) groups)
1445         (gnus-category-write)
1446         (gnus-category-list)))))
1447
1448 (defun gnus-category-kill (category)
1449   "Kill the current category."
1450   (interactive (list (gnus-category-name)))
1451   (let ((info (assq category gnus-category-alist))
1452         (buffer-read-only nil))
1453     (gnus-delete-line)
1454     (setq gnus-category-alist (delq info gnus-category-alist))
1455     (gnus-category-write)))
1456
1457 (defun gnus-category-copy (category to)
1458   "Copy the current category."
1459   (interactive (list (gnus-category-name) (intern (read-string "New name: "))))
1460   (let ((info (assq category gnus-category-alist)))
1461     (push (list to (gnus-copy-sequence (cadr info))
1462                 (gnus-copy-sequence (caddr info)) nil)
1463           gnus-category-alist)
1464     (gnus-category-write)
1465     (gnus-category-list)))
1466
1467 (defun gnus-category-add (category)
1468   "Create a new category."
1469   (interactive "SCategory name: ")
1470   (when (assq category gnus-category-alist)
1471     (error "Category %s already exists" category))
1472   (push (list category 'false nil nil)
1473         gnus-category-alist)
1474   (gnus-category-write)
1475   (gnus-category-list))
1476
1477 (defun gnus-category-list ()
1478   "List all categories."
1479   (interactive)
1480   (gnus-category-prepare))
1481
1482 (defun gnus-category-exit ()
1483   "Return to the group buffer."
1484   (interactive)
1485   (kill-buffer (current-buffer))
1486   (gnus-configure-windows 'group t))
1487
1488 ;; To avoid having 8-bit characters in the source file.
1489 (defvar gnus-category-not (list '! 'not (intern (format "%c" 172))))
1490
1491 (defvar gnus-category-predicate-alist
1492   '((spam . gnus-agent-spam-p)
1493     (short . gnus-agent-short-p)
1494     (long . gnus-agent-long-p)
1495     (low . gnus-agent-low-scored-p)
1496     (high . gnus-agent-high-scored-p)
1497     (true . gnus-agent-true)
1498     (false . gnus-agent-false))
1499   "Mapping from short score predicate symbols to predicate functions.")
1500
1501 (defun gnus-agent-spam-p ()
1502   "Say whether an article is spam or not."
1503   (unless gnus-agent-spam-hashtb
1504     (setq gnus-agent-spam-hashtb (gnus-make-hashtable 1000)))
1505   (if (not (equal (mail-header-references gnus-headers) ""))
1506       nil
1507     (let ((string (gnus-simplify-subject (mail-header-subject gnus-headers))))
1508       (prog1
1509           (gnus-gethash string gnus-agent-spam-hashtb)
1510         (gnus-sethash string t gnus-agent-spam-hashtb)))))
1511
1512 (defun gnus-agent-short-p ()
1513   "Say whether an article is short or not."
1514   (< (mail-header-lines gnus-headers) gnus-agent-short-article))
1515
1516 (defun gnus-agent-long-p ()
1517   "Say whether an article is long or not."
1518   (> (mail-header-lines gnus-headers) gnus-agent-long-article))
1519
1520 (defun gnus-agent-low-scored-p ()
1521   "Say whether an article has a low score or not."
1522   (< gnus-score gnus-agent-low-score))
1523
1524 (defun gnus-agent-high-scored-p ()
1525   "Say whether an article has a high score or not."
1526   (> gnus-score gnus-agent-high-score))
1527
1528 (defun gnus-category-make-function (cat)
1529   "Make a function from category CAT."
1530   (let ((func (gnus-category-make-function-1 cat)))
1531     (if (and (= (length func) 1)
1532              (symbolp (car func)))
1533         (car func)
1534       (gnus-byte-compile `(lambda () ,func)))))
1535
1536 (defun gnus-agent-true ()
1537   "Return t."
1538   t)
1539
1540 (defun gnus-agent-false ()
1541   "Return nil."
1542   nil)
1543
1544 (defun gnus-category-make-function-1 (cat)
1545   "Make a function from category CAT."
1546   (cond
1547    ;; Functions are just returned as is.
1548    ((or (symbolp cat)
1549         (gnus-functionp cat))
1550     `(,(or (cdr (assq cat gnus-category-predicate-alist))
1551            cat)))
1552    ;; More complex category.
1553    ((consp cat)
1554     `(,(cond
1555         ((memq (car cat) '(& and))
1556          'and)
1557         ((memq (car cat) '(| or))
1558          'or)
1559         ((memq (car cat) gnus-category-not)
1560          'not))
1561       ,@(mapcar 'gnus-category-make-function-1 (cdr cat))))
1562    (t
1563     (error "Unknown category type: %s" cat))))
1564
1565 (defun gnus-get-predicate (predicate)
1566   "Return the predicate for CATEGORY."
1567   (or (cdr (assoc predicate gnus-category-predicate-cache))
1568       (cdar (push (cons predicate
1569                         (gnus-category-make-function predicate))
1570                   gnus-category-predicate-cache))))
1571
1572 (defun gnus-group-category (group)
1573   "Return the category GROUP belongs to."
1574   (unless gnus-category-group-cache
1575     (setq gnus-category-group-cache (gnus-make-hashtable 1000))
1576     (let ((cs gnus-category-alist)
1577           groups cat)
1578       (while (setq cat (pop cs))
1579         (setq groups (cadddr cat))
1580         (while groups
1581           (gnus-sethash (pop groups) cat gnus-category-group-cache)))))
1582   (or (gnus-gethash group gnus-category-group-cache)
1583       (assq 'default gnus-category-alist)))
1584
1585 (defun gnus-agent-expire ()
1586   "Expire all old articles."
1587   (interactive)
1588   (let ((methods gnus-agent-covered-methods)
1589         (day (if (numberp gnus-agent-expire-days)
1590                  (- (time-to-days (current-time)) gnus-agent-expire-days)
1591                nil))
1592         (current-day (time-to-days (current-time)))
1593         gnus-command-method sym group articles
1594         history overview file histories elem art nov-file low info
1595         unreads marked article orig lowest highest found days)
1596     (save-excursion
1597       (setq overview (gnus-get-buffer-create " *expire overview*"))
1598       (while (setq gnus-command-method (pop methods))
1599         (when (file-exists-p (gnus-agent-lib-file "active"))
1600           (with-temp-buffer
1601             (nnheader-insert-file-contents (gnus-agent-lib-file "active"))
1602             (gnus-active-to-gnus-format
1603              gnus-command-method
1604              (setq orig (gnus-make-hashtable
1605                          (count-lines (point-min) (point-max))))))
1606           (let ((expiry-hashtb (gnus-make-hashtable 1023)))
1607             (gnus-agent-open-history)
1608             (set-buffer
1609              (setq gnus-agent-current-history
1610                    (setq history (gnus-agent-history-buffer))))
1611             (goto-char (point-min))
1612             (when (> (buffer-size) 1)
1613               (goto-char (point-min))
1614               (while (not (eobp))
1615                 (skip-chars-forward "^\t")
1616                 (if (let ((fetch-date (read (current-buffer))))
1617                       (if (numberp fetch-date)
1618                           ;; We now have the arrival day, so we see
1619                           ;; whether it's old enough to be expired.
1620                           (if (numberp day)
1621                               (> fetch-date day)
1622                             (skip-chars-forward "\t")
1623                             (setq found nil
1624                                   days gnus-agent-expire-days)
1625                             (while (and (not found)
1626                                         days)
1627                               (when (looking-at (caar days))
1628                                 (setq found (cadar days)))
1629                               (pop days))
1630                             (> fetch-date (- current-day found)))
1631                         ;; History file is corrupted.
1632                         (gnus-message
1633                          5
1634                          (format "File %s is corrupted!"
1635                                  (gnus-agent-lib-file "history")))
1636                         (sit-for 1)
1637                         ;; Ignore it
1638                         t))
1639                     ;; New article; we don't expire it.
1640                     (forward-line 1)
1641                   ;; Old article.  Schedule it for possible nuking.
1642                   (while (not (eolp))
1643                     (setq sym (let ((obarray expiry-hashtb) s)
1644                                 (setq s (read (current-buffer)))
1645                                 (if (stringp s) (intern s) s)))
1646                     (if (boundp sym)
1647                         (set sym (cons (cons (read (current-buffer)) (point))
1648                                        (symbol-value sym)))
1649                       (set sym (list (cons (read (current-buffer)) (point)))))
1650                     (skip-chars-forward " "))
1651                   (forward-line 1)))
1652               ;; We now have all articles that can possibly be expired.
1653               (mapatoms
1654                (lambda (sym)
1655                  (setq group (symbol-name sym)
1656                        articles (sort (symbol-value sym) 'car-less-than-car)
1657                        low (car (gnus-active group))
1658                        info (gnus-get-info group)
1659                        unreads (ignore-errors
1660                                  (gnus-list-of-unread-articles group))
1661                        marked (nconc
1662                                (gnus-uncompress-range
1663                                 (cdr (assq 'tick (gnus-info-marks info))))
1664                                (gnus-uncompress-range
1665                                 (cdr (assq 'dormant
1666                                            (gnus-info-marks info)))))
1667                        nov-file (gnus-agent-article-name ".overview" group)
1668                        lowest nil
1669                        highest nil)
1670                  (gnus-agent-load-alist group)
1671                  (gnus-message 5 "Expiring articles in %s" group)
1672                  (set-buffer overview)
1673                  (erase-buffer)
1674                  (when (file-exists-p nov-file)
1675                    (nnheader-insert-file-contents nov-file))
1676                  (goto-char (point-min))
1677                  (setq article 0)
1678                  (while (setq elem (pop articles))
1679                    (setq article (car elem))
1680                    (when (or (null low)
1681                              (< article low)
1682                              gnus-agent-expire-all
1683                              (and (not (memq article unreads))
1684                                   (not (memq article marked))))
1685                      ;; Find and nuke the NOV line.
1686                      (while (and (not (eobp))
1687                                  (or (not (numberp
1688                                            (setq art (read (current-buffer)))))
1689                                      (< art article)))
1690                        (if (and (numberp art)
1691                                 (file-exists-p
1692                                  (gnus-agent-article-name
1693                                   (number-to-string art) group)))
1694                            (progn
1695                              (unless lowest
1696                                (setq lowest art))
1697                              (setq highest art)
1698                              (forward-line 1))
1699                          ;; Remove old NOV lines that have no articles.
1700                          (gnus-delete-line)))
1701                      (if (or (eobp)
1702                              (/= art article))
1703                          (beginning-of-line)
1704                        (gnus-delete-line))
1705                      ;; Nuke the article.
1706                      (when (file-exists-p
1707                             (setq file (gnus-agent-article-name
1708                                         (number-to-string article)
1709                                         group)))
1710                        (delete-file file))
1711                      ;; Schedule the history line for nuking.
1712                      (push (cdr elem) histories)))
1713                  (gnus-make-directory (file-name-directory nov-file))
1714                  (let ((coding-system-for-write
1715                         gnus-agent-file-coding-system))
1716                    (write-region (point-min) (point-max) nov-file nil 'silent))
1717                  ;; Delete the unwanted entries in the alist.
1718                  (setq gnus-agent-article-alist
1719                        (sort gnus-agent-article-alist 'car-less-than-car))
1720                  (let* ((alist gnus-agent-article-alist)
1721                         (prev (cons nil alist))
1722                         (first prev)
1723                         expired)
1724                    (while (and alist
1725                                (<= (caar alist) article))
1726                      (if (or (not (cdar alist))
1727                              (not (file-exists-p
1728                                    (gnus-agent-article-name
1729                                     (number-to-string
1730                                      (caar alist))
1731                                     group))))
1732                          (progn
1733                            (push (caar alist) expired)
1734                            (setcdr prev (setq alist (cdr alist))))
1735                        (setq prev alist
1736                              alist (cdr alist))))
1737                    (setq gnus-agent-article-alist (cdr first))
1738                    (gnus-agent-save-alist group)
1739                    ;; Mark all articles up to the first article
1740                    ;; in `gnus-article-alist' as read.
1741                    (when (and info (caar gnus-agent-article-alist))
1742                      (setcar (nthcdr 2 info)
1743                              (gnus-range-add
1744                               (nth 2 info)
1745                               (cons 1 (- (caar gnus-agent-article-alist) 1)))))
1746                    ;; Maybe everything has been expired from `gnus-article-alist'
1747                    ;; and so the above marking as read could not be conducted,
1748                    ;; or there are expired article within the range of the alist.
1749                    (when (and info
1750                               expired
1751                               (or (not (caar gnus-agent-article-alist))
1752                                   (> (car expired)
1753                                      (caar gnus-agent-article-alist))))
1754                      (setcar (nthcdr 2 info)
1755                              (gnus-add-to-range
1756                               (nth 2 info)
1757                               (nreverse expired))))
1758                    (gnus-dribble-enter
1759                     (concat "(gnus-group-set-info '"
1760                             (gnus-prin1-to-string info)
1761                             ")")))
1762                  (when lowest
1763                    (if (gnus-gethash group orig)
1764                        (setcar (gnus-gethash group orig) lowest)
1765                      (gnus-sethash group (cons lowest highest) orig))))
1766                expiry-hashtb)
1767               (set-buffer history)
1768               (setq histories (nreverse (sort histories '<)))
1769               (while histories
1770                 (goto-char (pop histories))
1771                 (gnus-delete-line))
1772               (gnus-agent-save-history)
1773               (gnus-agent-close-history)
1774               (gnus-write-active-file
1775                (gnus-agent-lib-file "active") orig))
1776             (gnus-message 4 "Expiry...done")))))))
1777
1778 ;;;###autoload
1779 (defun gnus-agent-batch ()
1780   (interactive)
1781   (let ((init-file-user "")
1782         (gnus-always-read-dribble-file t))
1783     (gnus))
1784   (gnus-group-send-queue)
1785   (gnus-agent-fetch-session))
1786
1787 (provide 'gnus-agent)
1788
1789 ;;; gnus-agent.el ends here