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 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation; either version 2, or (at your option)
  10 ;; any later version.
  11
  12 ;; GNU Emacs is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  19 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20 ;; Boston, MA 02111-1307, USA.
  21
  22 ;;; Commentary:
  23
  24 ;;; Code:
  25
  26 (require 'gnus)
  27 (require 'gnus-cache)
  28 (require 'nnvirtual)
  29 (require 'gnus-sum)
  30 (require 'gnus-score)
  31 (eval-when-compile
  32   (if (featurep 'xemacs)
  33       (require 'itimer)
  34     (require 'timer))
  35   (require 'cl))
  36
  37 (defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/")
  38   "Where the Gnus agent will store its files."
  39   :group 'gnus-agent
  40   :type 'directory)
  41
  42 (defcustom gnus-agent-plugged-hook nil
  43   "Hook run when plugging into the network."
  44   :group 'gnus-agent
  45   :type 'hook)
  46
  47 (defcustom gnus-agent-unplugged-hook nil
  48   "Hook run when unplugging from the network."
  49   :group 'gnus-agent
  50   :type 'hook)
  51
  52 (defcustom gnus-agent-handle-level gnus-level-subscribed
  53   "Groups on levels higher than this variable will be ignored by the Agent."
  54   :group 'gnus-agent
  55   :type 'integer)
  56
  57 (defcustom gnus-agent-expire-days 7
  58   "Read articles older than this will be expired."
  59   :group 'gnus-agent
  60   :type 'integer)
  61
  62 (defcustom gnus-agent-expire-all nil
  63   "If non-nil, also expire unread, ticked and dormant articles.
  64 If nil, only read articles will be expired."
  65   :group 'gnus-agent
  66   :type 'boolean)
  67
  68 (defcustom gnus-agent-group-mode-hook nil
  69   "Hook run in Agent group minor modes."
  70   :group 'gnus-agent
  71   :type 'hook)
  72
  73 (defcustom gnus-agent-summary-mode-hook nil
  74   "Hook run in Agent summary minor modes."
  75   :group 'gnus-agent
  76   :type 'hook)
  77
  78 (defcustom gnus-agent-server-mode-hook nil
  79   "Hook run in Agent summary minor modes."
  80   :group 'gnus-agent
  81   :type 'hook)
  82
  83 (defcustom gnus-agent-confirmation-function 'y-or-n-p
  84   "Function to confirm when error happens."
  85   :version "21.1"
  86   :group 'gnus-agent
  87   :type 'function)
  88
  89 (defcustom gnus-agent-synchronize-flags 'ask
  90   "Indicate if flags are synchronized when you plug in.
  91 If this is `ask' the hook will query the user."
  92   :version "21.1"
  93   :type '(choice (const :tag "Always" t)
  94                  (const :tag "Never" nil)
  95                  (const :tag "Ask" ask))
  96   :group 'gnus-agent)
  97
  98 ;;; Internal variables
  99
 100 (defvar gnus-agent-history-buffers nil)
 101 (defvar gnus-agent-buffer-alist nil)
 102 (defvar gnus-agent-article-alist nil)
 103 (defvar gnus-agent-group-alist nil)
 104 (defvar gnus-agent-covered-methods nil)
 105 (defvar gnus-category-alist nil)
 106 (defvar gnus-agent-current-history nil)
 107 (defvar gnus-agent-overview-buffer nil)
 108 (defvar gnus-category-predicate-cache nil)
 109 (defvar gnus-category-group-cache nil)
 110 (defvar gnus-agent-spam-hashtb nil)
 111 (defvar gnus-agent-file-name nil)
 112 (defvar gnus-agent-send-mail-function nil)
 113 (defvar gnus-agent-file-coding-system 'raw-text)
 114
 115 ;; Dynamic variables
 116 (defvar gnus-headers)
 117 (defvar gnus-score)
 118
 119 ;;;
 120 ;;; Setup
 121 ;;;
 122
 123 (defun gnus-open-agent ()
 124   (setq gnus-agent t)
 125   (gnus-agent-read-servers)
 126   (gnus-category-read)
 127   (gnus-agent-create-buffer)
 128   (add-hook 'gnus-group-mode-hook 'gnus-agent-mode)
 129   (add-hook 'gnus-summary-mode-hook 'gnus-agent-mode)
 130   (add-hook 'gnus-server-mode-hook 'gnus-agent-mode))
 131
 132 (defun gnus-agent-create-buffer ()
 133   (if (gnus-buffer-live-p gnus-agent-overview-buffer)
 134       t
 135     (setq gnus-agent-overview-buffer
 136           (gnus-get-buffer-create " *Gnus agent overview*"))
 137     (with-current-buffer gnus-agent-overview-buffer
 138       (mm-enable-multibyte))
 139     nil))
 140
 141 (gnus-add-shutdown 'gnus-close-agent 'gnus)
 142
 143 (defun gnus-close-agent ()
 144   (setq gnus-agent-covered-methods nil
 145         gnus-category-predicate-cache nil
 146         gnus-category-group-cache nil
 147         gnus-agent-spam-hashtb nil)
 148   (gnus-kill-buffer gnus-agent-overview-buffer))
 149
 150 ;;;
 151 ;;; Utility functions
 152 ;;;
 153
 154 (defun gnus-agent-read-file (file)
 155   "Load FILE and do a `read' there."
 156   (with-temp-buffer
 157     (ignore-errors
 158       (nnheader-insert-file-contents file)
 159       (goto-char (point-min))
 160       (read (current-buffer)))))
 161
 162 (defsubst gnus-agent-method ()
 163   (concat (symbol-name (car gnus-command-method)) "/"
 164           (if (equal (cadr gnus-command-method) "")
 165               "unnamed"
 166             (cadr gnus-command-method))))
 167
 168 (defsubst gnus-agent-directory ()
 169   "Path of the Gnus agent directory."
 170   (nnheader-concat gnus-agent-directory
 171                    (nnheader-translate-file-chars (gnus-agent-method)) "/"))
 172
 173 (defun gnus-agent-lib-file (file)
 174   "The full path of the Gnus agent library FILE."
 175   (expand-file-name file
 176                     (file-name-as-directory
 177                      (expand-file-name "agent.lib" (gnus-agent-directory)))))
 178
 179 ;;; Fetching setup functions.
 180
 181 (defun gnus-agent-start-fetch ()
 182   "Initialize data structures for efficient fetching."
 183   (gnus-agent-open-history)
 184   (setq gnus-agent-current-history (gnus-agent-history-buffer))
 185   (gnus-agent-create-buffer))
 186
 187 (defun gnus-agent-stop-fetch ()
 188   "Save all data structures and clean up."
 189   (gnus-agent-save-history)
 190   (gnus-agent-close-history)
 191   (setq gnus-agent-spam-hashtb nil)
 192   (save-excursion
 193     (set-buffer nntp-server-buffer)
 194     (widen)))
 195
 196 (defmacro gnus-agent-with-fetch (&rest forms)
 197   "Do FORMS safely."
 198   `(unwind-protect
 199        (let ((gnus-agent-fetching t))
 200          (gnus-agent-start-fetch)
 201          ,@forms)
 202      (gnus-agent-stop-fetch)))
 203
 204 (put 'gnus-agent-with-fetch 'lisp-indent-function 0)
 205 (put 'gnus-agent-with-fetch 'edebug-form-spec '(body))
 206
 207 ;;;
 208 ;;; Mode infestation
 209 ;;;
 210
 211 (defvar gnus-agent-mode-hook nil
 212   "Hook run when installing agent mode.")
 213
 214 (defvar gnus-agent-mode nil)
 215 (defvar gnus-agent-mode-status '(gnus-agent-mode " Plugged"))
 216
 217 (defun gnus-agent-mode ()
 218   "Minor mode for providing a agent support in Gnus buffers."
 219   (let* ((buffer (progn (string-match "^gnus-\\(.*\\)-mode$"
 220                                       (symbol-name major-mode))
 221                         (match-string 1 (symbol-name major-mode))))
 222          (mode (intern (format "gnus-agent-%s-mode" buffer))))
 223     (set (make-local-variable 'gnus-agent-mode) t)
 224     (set mode nil)
 225     (set (make-local-variable mode) t)
 226     ;; Set up the menu.
 227     (when (gnus-visual-p 'agent-menu 'menu)
 228       (funcall (intern (format "gnus-agent-%s-make-menu-bar" buffer))))
 229     (unless (assq 'gnus-agent-mode minor-mode-alist)
 230       (push gnus-agent-mode-status minor-mode-alist))
 231     (unless (assq mode minor-mode-map-alist)
 232       (push (cons mode (symbol-value (intern (format "gnus-agent-%s-mode-map"
 233                                                      buffer))))
 234             minor-mode-map-alist))
 235     (when (eq major-mode 'gnus-group-mode)
 236       (gnus-agent-toggle-plugged gnus-plugged))
 237     (gnus-run-hooks 'gnus-agent-mode-hook
 238                     (intern (format "gnus-agent-%s-mode-hook" buffer)))))
 239
 240 (defvar gnus-agent-group-mode-map (make-sparse-keymap))
 241 (gnus-define-keys gnus-agent-group-mode-map
 242   "Ju" gnus-agent-fetch-groups
 243   "Jc" gnus-enter-category-buffer
 244   "Jj" gnus-agent-toggle-plugged
 245   "Js" gnus-agent-fetch-session
 246   "JY" gnus-agent-synchronize-flags
 247   "JS" gnus-group-send-drafts
 248   "Ja" gnus-agent-add-group
 249   "Jr" gnus-agent-remove-group)
 250
 251 (defun gnus-agent-group-make-menu-bar ()
 252   (unless (boundp 'gnus-agent-group-menu)
 253     (easy-menu-define
 254      gnus-agent-group-menu gnus-agent-group-mode-map ""
 255      '("Agent"
 256        ["Toggle plugged" gnus-agent-toggle-plugged t]
 257        ["List categories" gnus-enter-category-buffer t]
 258        ["Send drafts" gnus-group-send-drafts gnus-plugged]
 259        ("Fetch"
 260         ["All" gnus-agent-fetch-session gnus-plugged]
 261         ["Group" gnus-agent-fetch-group gnus-plugged])))))
 262
 263 (defvar gnus-agent-summary-mode-map (make-sparse-keymap))
 264 (gnus-define-keys gnus-agent-summary-mode-map
 265   "Jj" gnus-agent-toggle-plugged
 266   "J#" gnus-agent-mark-article
 267   "J\M-#" gnus-agent-unmark-article
 268   "@" gnus-agent-toggle-mark
 269   "Jc" gnus-agent-catchup)
 270
 271 (defun gnus-agent-summary-make-menu-bar ()
 272   (unless (boundp 'gnus-agent-summary-menu)
 273     (easy-menu-define
 274      gnus-agent-summary-menu gnus-agent-summary-mode-map ""
 275      '("Agent"
 276        ["Toggle plugged" gnus-agent-toggle-plugged t]
 277        ["Mark as downloadable" gnus-agent-mark-article t]
 278        ["Unmark as downloadable" gnus-agent-unmark-article t]
 279        ["Toggle mark" gnus-agent-toggle-mark t]
 280        ["Catchup undownloaded" gnus-agent-catchup t]))))
 281
 282 (defvar gnus-agent-server-mode-map (make-sparse-keymap))
 283 (gnus-define-keys gnus-agent-server-mode-map
 284   "Jj" gnus-agent-toggle-plugged
 285   "Ja" gnus-agent-add-server
 286   "Jr" gnus-agent-remove-server)
 287
 288 (defun gnus-agent-server-make-menu-bar ()
 289   (unless (boundp 'gnus-agent-server-menu)
 290     (easy-menu-define
 291      gnus-agent-server-menu gnus-agent-server-mode-map ""
 292      '("Agent"
 293        ["Toggle plugged" gnus-agent-toggle-plugged t]
 294        ["Add" gnus-agent-add-server t]
 295        ["Remove" gnus-agent-remove-server t]))))
 296
 297 (defun gnus-agent-toggle-plugged (plugged)
 298   "Toggle whether Gnus is unplugged or not."
 299   (interactive (list (not gnus-plugged)))
 300   (if plugged
 301       (progn
 302         (setq gnus-plugged plugged)
 303         (gnus-agent-possibly-synchronize-flags)
 304         (gnus-run-hooks 'gnus-agent-plugged-hook)
 305         (setcar (cdr gnus-agent-mode-status) " Plugged"))
 306     (gnus-agent-close-connections)
 307     (setq gnus-plugged plugged)
 308     (gnus-run-hooks 'gnus-agent-unplugged-hook)
 309     (setcar (cdr gnus-agent-mode-status) " Unplugged"))
 310   (set-buffer-modified-p t))
 311
 312 (defun gnus-agent-close-connections ()
 313   "Close all methods covered by the Gnus agent."
 314   (let ((methods gnus-agent-covered-methods))
 315     (while methods
 316       (gnus-close-server (pop methods)))))
 317
 318 ;;;###autoload
 319 (defun gnus-unplugged ()
 320   "Start Gnus unplugged."
 321   (interactive)
 322   (setq gnus-plugged nil)
 323   (gnus))
 324
 325 ;;;###autoload
 326 (defun gnus-plugged ()
 327   "Start Gnus plugged."
 328   (interactive)
 329   (setq gnus-plugged t)
 330   (gnus))
 331
 332 ;;;###autoload
 333 (defun gnus-agentize ()
 334   "Allow Gnus to be an offline newsreader.
 335 The normal usage of this command is to put the following as the
 336 last form in your `.gnus.el' file:
 337
 338 \(gnus-agentize)
 339
 340 This will modify the `gnus-before-startup-hook', `gnus-post-method',
 341 and `message-send-mail-function' variables, and install the Gnus
 342 agent minor mode in all Gnus buffers."
 343   (interactive)
 344   (gnus-open-agent)
 345   (add-hook 'gnus-setup-news-hook 'gnus-agent-queue-setup)
 346   (unless gnus-agent-send-mail-function
 347     (setq gnus-agent-send-mail-function message-send-mail-function
 348           message-send-mail-function 'gnus-agent-send-mail))
 349   (unless gnus-agent-covered-methods
 350     (setq gnus-agent-covered-methods (list gnus-select-method))))
 351
 352 (defun gnus-agent-queue-setup ()
 353   "Make sure the queue group exists."
 354   (unless (gnus-gethash "nndraft:queue" gnus-newsrc-hashtb)
 355     (gnus-request-create-group "queue" '(nndraft ""))
 356     (let ((gnus-level-default-subscribed 1))
 357       (gnus-subscribe-group "nndraft:queue" nil '(nndraft "")))
 358     (gnus-group-set-parameter
 359      "nndraft:queue" 'gnus-dummy '((gnus-draft-mode)))))
 360
 361 (defun gnus-agent-send-mail ()
 362   (if gnus-plugged
 363       (funcall gnus-agent-send-mail-function)
 364     (goto-char (point-min))
 365     (re-search-forward
 366      (concat "^" (regexp-quote mail-header-separator) "\n"))
 367     (replace-match "\n")
 368     (gnus-agent-insert-meta-information 'mail)
 369     (gnus-request-accept-article "nndraft:queue" nil t t)))
 370
 371 (defun gnus-agent-insert-meta-information (type &optional method)
 372   "Insert meta-information into the message that says how it's to be posted.
 373 TYPE can be either `mail' or `news'.  If the latter, then METHOD can
 374 be a select method."
 375   (save-excursion
 376     (message-remove-header gnus-agent-meta-information-header)
 377     (goto-char (point-min))
 378     (insert gnus-agent-meta-information-header ": "
 379             (symbol-name type) " " (format "%S" method)
 380             "\n")
 381     (forward-char -1)
 382     (while (search-backward "\n" nil t)
 383       (replace-match "\\n" t t))))
 384
 385 (defun gnus-agent-restore-gcc ()
 386   "Restore GCC field from saved header."
 387   (save-excursion
 388     (goto-char (point-min))
 389     (while (re-search-forward (concat gnus-agent-gcc-header ":") nil t)
 390       (replace-match "Gcc:" 'fixedcase))))
 391
 392 (defun gnus-agent-any-covered-gcc ()
 393   (save-restriction
 394     (message-narrow-to-headers)
 395     (let* ((gcc (mail-fetch-field "gcc" nil t))
 396            (methods (and gcc
 397                          (mapcar 'gnus-inews-group-method
 398                                  (message-unquote-tokens
 399                                   (message-tokenize-header
 400                                    gcc " ,")))))
 401            covered)
 402       (while (and (not covered) methods)
 403         (setq covered
 404               (member (car methods) gnus-agent-covered-methods)
 405               methods (cdr methods)))
 406       covered)))
 407
 408 (defun gnus-agent-possibly-save-gcc ()
 409   "Save GCC if Gnus is unplugged."
 410   (when (and (not gnus-plugged) (gnus-agent-any-covered-gcc))
 411     (save-excursion
 412       (goto-char (point-min))
 413       (let ((case-fold-search t))
 414         (while (re-search-forward "^gcc:" nil t)
 415           (replace-match (concat gnus-agent-gcc-header ":") 'fixedcase))))))
 416
 417 (defun gnus-agent-possibly-do-gcc ()
 418   "Do GCC if Gnus is plugged."
 419   (when (or gnus-plugged (not (gnus-agent-any-covered-gcc)))
 420     (gnus-inews-do-gcc)))
 421
 422 ;;;
 423 ;;; Group mode commands
 424 ;;;
 425
 426 (defun gnus-agent-fetch-groups (n)
 427   "Put all new articles in the current groups into the Agent."
 428   (interactive "P")
 429   (unless gnus-plugged
 430     (error "Groups can't be fetched when Gnus is unplugged"))
 431   (gnus-group-iterate n 'gnus-agent-fetch-group))
 432
 433 (defun gnus-agent-fetch-group (group)
 434   "Put all new articles in GROUP into the Agent."
 435   (interactive (list (gnus-group-group-name)))
 436   (unless gnus-plugged
 437     (error "Groups can't be fetched when Gnus is unplugged"))
 438   (unless group
 439     (error "No group on the current line"))
 440   (let ((gnus-command-method (gnus-find-method-for-group group)))
 441     (gnus-agent-with-fetch
 442       (gnus-agent-fetch-group-1 group gnus-command-method)
 443       (gnus-message 5 "Fetching %s...done" group))))
 444
 445 (defun gnus-agent-add-group (category arg)
 446   "Add the current group to an agent category."
 447   (interactive
 448    (list
 449     (intern
 450      (completing-read
 451       "Add to category: "
 452       (mapcar (lambda (cat) (list (symbol-name (car cat))))
 453               gnus-category-alist)
 454       nil t))
 455     current-prefix-arg))
 456   (let ((cat (assq category gnus-category-alist))
 457         c groups)
 458     (gnus-group-iterate arg
 459       (lambda (group)
 460         (when (cadddr (setq c (gnus-group-category group)))
 461           (setf (cadddr c) (delete group (cadddr c))))
 462         (push group groups)))
 463     (setf (cadddr cat) (nconc (cadddr cat) groups))
 464     (gnus-category-write)))
 465
 466 (defun gnus-agent-remove-group (arg)
 467   "Remove the current group from its agent category, if any."
 468   (interactive "P")
 469   (let (c)
 470     (gnus-group-iterate arg
 471       (lambda (group)
 472         (when (cadddr (setq c (gnus-group-category group)))
 473           (setf (cadddr c) (delete group (cadddr c))))))
 474     (gnus-category-write)))
 475
 476 (defun gnus-agent-synchronize-flags ()
 477   "Synchronize unplugged flags with servers."
 478   (interactive)
 479   (save-excursion
 480     (dolist (gnus-command-method gnus-agent-covered-methods)
 481       (when (file-exists-p (gnus-agent-lib-file "flags"))
 482         (gnus-agent-synchronize-flags-server gnus-command-method)))))
 483
 484 (defun gnus-agent-possibly-synchronize-flags ()
 485   "Synchronize flags according to `gnus-agent-synchronize-flags'."
 486   (interactive)
 487   (save-excursion
 488     (dolist (gnus-command-method gnus-agent-covered-methods)
 489       (when (file-exists-p (gnus-agent-lib-file "flags"))
 490         (gnus-agent-possibly-synchronize-flags-server gnus-command-method)))))
 491
 492 (defun gnus-agent-synchronize-flags-server (method)
 493   "Synchronize flags set when unplugged for server."
 494   (let ((gnus-command-method method))
 495     (when (file-exists-p (gnus-agent-lib-file "flags"))
 496       (set-buffer (get-buffer-create " *Gnus Agent flag synchronize*"))
 497       (erase-buffer)
 498       (nnheader-insert-file-contents (gnus-agent-lib-file "flags"))
 499       (if (null (gnus-check-server gnus-command-method))
 500           (message "Couldn't open server %s" (nth 1 gnus-command-method))
 501         (while (not (eobp))
 502           (if (null (eval (read (current-buffer))))
 503               (progn (forward-line)
 504                      (kill-line -1))
 505             (write-file (gnus-agent-lib-file "flags"))
 506             (error "Couldn't set flags from file %s"
 507                    (gnus-agent-lib-file "flags"))))
 508         (delete-file (gnus-agent-lib-file "flags")))
 509       (kill-buffer nil))))
 510
 511 (defun gnus-agent-possibly-synchronize-flags-server (method)
 512   "Synchronize flags for server according to `gnus-agent-synchronize-flags'."
 513   (when (or (and gnus-agent-synchronize-flags
 514                  (not (eq gnus-agent-synchronize-flags 'ask)))
 515             (and (eq gnus-agent-synchronize-flags 'ask)
 516                  (gnus-y-or-n-p (format "Synchronize flags on server `%s'? "
 517                                         (cadr method)))))
 518     (gnus-agent-synchronize-flags-server method)))
 519
 520 ;;;
 521 ;;; Server mode commands
 522 ;;;
 523
 524 (defun gnus-agent-add-server (server)
 525   "Enroll SERVER in the agent program."
 526   (interactive (list (gnus-server-server-name)))
 527   (unless server
 528     (error "No server on the current line"))
 529   (let ((method (gnus-server-get-method nil (gnus-server-server-name))))
 530     (when (member method gnus-agent-covered-methods)
 531       (error "Server already in the agent program"))
 532     (push method gnus-agent-covered-methods)
 533     (gnus-agent-write-servers)
 534     (message "Entered %s into the Agent" server)))
 535
 536 (defun gnus-agent-remove-server (server)
 537   "Remove SERVER from the agent program."
 538   (interactive (list (gnus-server-server-name)))
 539   (unless server
 540     (error "No server on the current line"))
 541   (let ((method (gnus-server-get-method nil (gnus-server-server-name))))
 542     (unless (member method gnus-agent-covered-methods)
 543       (error "Server not in the agent program"))
 544     (setq gnus-agent-covered-methods
 545           (delete method gnus-agent-covered-methods))
 546     (gnus-agent-write-servers)
 547     (message "Removed %s from the agent" server)))
 548
 549 (defun gnus-agent-read-servers ()
 550   "Read the alist of covered servers."
 551   (setq gnus-agent-covered-methods
 552         (gnus-agent-read-file
 553          (nnheader-concat gnus-agent-directory "lib/servers"))))
 554
 555 (defun gnus-agent-write-servers ()
 556   "Write the alist of covered servers."
 557   (gnus-make-directory (nnheader-concat gnus-agent-directory "lib"))
 558   (let ((coding-system-for-write nnheader-file-coding-system)
 559         (file-name-coding-system nnmail-pathname-coding-system))
 560     (with-temp-file (nnheader-concat gnus-agent-directory "lib/servers")
 561       (prin1 gnus-agent-covered-methods (current-buffer)))))
 562
 563 ;;;
 564 ;;; Summary commands
 565 ;;;
 566
 567 (defun gnus-agent-mark-article (n &optional unmark)
 568   "Mark the next N articles as downloadable.
 569 If N is negative, mark backward instead.  If UNMARK is non-nil, remove
 570 the mark instead.  The difference between N and the actual number of
 571 articles marked is returned."
 572   (interactive "p")
 573   (let ((backward (< n 0))
 574         (n (abs n)))
 575     (while (and
 576             (> n 0)
 577             (progn
 578               (gnus-summary-set-agent-mark
 579                (gnus-summary-article-number) unmark)
 580               (zerop (gnus-summary-next-subject (if backward -1 1) nil t))))
 581       (setq n (1- n)))
 582     (when (/= 0 n)
 583       (gnus-message 7 "No more articles"))
 584     (gnus-summary-recenter)
 585     (gnus-summary-position-point)
 586     n))
 587
 588 (defun gnus-agent-unmark-article (n)
 589   "Remove the downloadable mark from the next N articles.
 590 If N is negative, unmark backward instead.  The difference between N and
 591 the actual number of articles unmarked is returned."
 592   (interactive "p")
 593   (gnus-agent-mark-article n t))
 594
 595 (defun gnus-agent-toggle-mark (n)
 596   "Toggle the downloadable mark from the next N articles.
 597 If N is negative, toggle backward instead.  The difference between N and
 598 the actual number of articles toggled is returned."
 599   (interactive "p")
 600   (gnus-agent-mark-article n 'toggle))
 601
 602 (defun gnus-summary-set-agent-mark (article &optional unmark)
 603   "Mark ARTICLE as downloadable."
 604   (let ((unmark (if (and (not (null unmark)) (not (eq t unmark)))
 605                     (memq article gnus-newsgroup-downloadable)
 606                   unmark)))
 607     (if unmark
 608         (progn
 609           (setq gnus-newsgroup-downloadable
 610                 (delq article gnus-newsgroup-downloadable))
 611           (push article gnus-newsgroup-undownloaded))
 612       (setq gnus-newsgroup-undownloaded
 613             (delq article gnus-newsgroup-undownloaded))
 614       (push article gnus-newsgroup-downloadable))
 615     (gnus-summary-update-mark
 616      (if unmark gnus-undownloaded-mark gnus-downloadable-mark)
 617      'unread)))
 618
 619 (defun gnus-agent-get-undownloaded-list ()
 620   "Mark all unfetched articles as read."
 621   (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name)))
 622     (when (and (not gnus-plugged)
 623                (gnus-agent-method-p gnus-command-method))
 624       (gnus-agent-load-alist gnus-newsgroup-name)
 625       ;; First mark all undownloaded articles as undownloaded.
 626       (let ((articles (append gnus-newsgroup-unreads
 627                               gnus-newsgroup-marked
 628                               gnus-newsgroup-dormant))
 629             article)
 630         (while (setq article (pop articles))
 631           (unless (or (cdr (assq article gnus-agent-article-alist))
 632                       (memq article gnus-newsgroup-downloadable)
 633                       (memq article gnus-newsgroup-cached))
 634             (push article gnus-newsgroup-undownloaded))))
 635       ;; Then mark downloaded downloadable as not-downloadable,
 636       ;; if you get my drift.
 637       (let ((articles gnus-newsgroup-downloadable)
 638             article)
 639         (while (setq article (pop articles))
 640           (when (cdr (assq article gnus-agent-article-alist))
 641             (setq gnus-newsgroup-downloadable
 642                   (delq article gnus-newsgroup-downloadable))))))))
 643
 644 (defun gnus-agent-catchup ()
 645   "Mark all undownloaded articles as read."
 646   (interactive)
 647   (save-excursion
 648     (while gnus-newsgroup-undownloaded
 649       (gnus-summary-mark-article
 650        (pop gnus-newsgroup-undownloaded) gnus-catchup-mark)))
 651   (gnus-summary-position-point))
 652
 653 ;;;
 654 ;;; Internal functions
 655 ;;;
 656
 657 (defun gnus-agent-save-active (method)
 658   (gnus-agent-save-active-1 method 'gnus-active-to-gnus-format))
 659
 660 (defun gnus-agent-save-active-1 (method function)
 661   (when (gnus-agent-method-p method)
 662     (let* ((gnus-command-method method)
 663            (new (gnus-make-hashtable (count-lines (point-min) (point-max))))
 664            (file (gnus-agent-lib-file "active")))
 665       (funcall function nil new)
 666       (gnus-agent-write-active file new)
 667       (erase-buffer)
 668       (nnheader-insert-file-contents file))))
 669
 670 (defun gnus-agent-write-active (file new)
 671   (let ((orig (gnus-make-hashtable (count-lines (point-min) (point-max))))
 672         (file (gnus-agent-lib-file "active"))
 673         elem osym)
 674     (when (file-exists-p file)
 675       (with-temp-buffer
 676         (nnheader-insert-file-contents file)
 677         (gnus-active-to-gnus-format nil orig))
 678       (mapatoms
 679        (lambda (sym)
 680          (when (and sym (boundp sym))
 681            (if (and (boundp (setq osym (intern (symbol-name sym) orig)))
 682                     (setq elem (symbol-value osym)))
 683                (setcdr elem (cdr (symbol-value sym)))
 684              (set (intern (symbol-name sym) orig) (symbol-value sym)))))
 685        new))
 686     (gnus-make-directory (file-name-directory file))
 687     (let ((coding-system-for-write gnus-agent-file-coding-system))
 688       ;; The hashtable contains real names of groups,  no more prefix
 689       ;; removing, so set `full' to `t'.
 690       (gnus-write-active-file file orig t))))
 691
 692 (defun gnus-agent-save-groups (method)
 693   (gnus-agent-save-active-1 method 'gnus-groups-to-gnus-format))
 694
 695 (defun gnus-agent-save-group-info (method group active)
 696   (when (gnus-agent-method-p method)
 697     (let* ((gnus-command-method method)
 698            (coding-system-for-write nnheader-file-coding-system)
 699            (file-name-coding-system nnmail-pathname-coding-system)
 700            (file (gnus-agent-lib-file "active"))
 701            oactive)
 702       (gnus-make-directory (file-name-directory file))
 703       (with-temp-file file
 704         ;; Emacs got problem to match non-ASCII group in multibyte buffer.
 705         (mm-disable-multibyte)
 706         (when (file-exists-p file)
 707           (nnheader-insert-file-contents file))
 708         (goto-char (point-min))
 709         (when (re-search-forward
 710                (concat "^" (regexp-quote group) " ") nil t)
 711           (save-excursion
 712             (save-restriction
 713               (narrow-to-region (match-beginning 0)
 714                                 (progn
 715                                   (forward-line 1)
 716                                   (point)))
 717               (setq oactive (car (nnmail-parse-active)))))
 718           (gnus-delete-line))
 719         (insert (format "%S %d %d y\n" (intern group)
 720                         (cdr active)
 721                         (or (car oactive) (car active))))
 722         (goto-char (point-max))
 723         (while (search-backward "\\." nil t)
 724           (delete-char 1))))))
 725
 726 (defun gnus-agent-group-path (group)
 727   "Translate GROUP into a path."
 728   (if nnmail-use-long-file-names
 729       (gnus-group-real-name group)
 730     (nnheader-translate-file-chars
 731      (nnheader-replace-chars-in-string
 732       (nnheader-replace-duplicate-chars-in-string
 733        (nnheader-replace-chars-in-string
 734         (gnus-group-real-name group)
 735         ?/ ?_)
 736        ?. ?_)
 737       ?. ?/))))
 738
 739 \f
 740
 741 (defun gnus-agent-method-p (method)
 742   "Say whether METHOD is covered by the agent."
 743   (member method gnus-agent-covered-methods))
 744
 745 (defun gnus-agent-get-function (method)
 746   (if (and (not gnus-plugged)
 747            (gnus-agent-method-p method))
 748       (progn
 749         (require 'nnagent)
 750         'nnagent)
 751     (car method)))
 752
 753 ;;; History functions
 754
 755 (defun gnus-agent-history-buffer ()
 756   (cdr (assoc (gnus-agent-method) gnus-agent-history-buffers)))
 757
 758 (defun gnus-agent-open-history ()
 759   (save-excursion
 760     (push (cons (gnus-agent-method)
 761                 (set-buffer (gnus-get-buffer-create
 762                              (format " *Gnus agent %s history*"
 763                                      (gnus-agent-method)))))
 764           gnus-agent-history-buffers)
 765     (mm-disable-multibyte) ;; everything is binary
 766     (erase-buffer)
 767     (insert "\n")
 768     (let ((file (gnus-agent-lib-file "history")))
 769       (when (file-exists-p file)
 770         (nnheader-insert-file-contents file))
 771       (set (make-local-variable 'gnus-agent-file-name) file))))
 772
 773 (defun gnus-agent-save-history ()
 774   (save-excursion
 775     (set-buffer gnus-agent-current-history)
 776     (gnus-make-directory (file-name-directory gnus-agent-file-name))
 777     (let ((coding-system-for-write gnus-agent-file-coding-system))
 778       (write-region (1+ (point-min)) (point-max)
 779                     gnus-agent-file-name nil 'silent))))
 780
 781 (defun gnus-agent-close-history ()
 782   (when (gnus-buffer-live-p gnus-agent-current-history)
 783     (kill-buffer gnus-agent-current-history)
 784     (setq gnus-agent-history-buffers
 785           (delq (assoc (gnus-agent-method) gnus-agent-history-buffers)
 786                 gnus-agent-history-buffers))))
 787
 788 (defun gnus-agent-enter-history (id group-arts date)
 789   (save-excursion
 790     (set-buffer gnus-agent-current-history)
 791     (goto-char (point-max))
 792     (let ((p (point)))
 793       (insert id "\t" (number-to-string date) "\t")
 794       (while group-arts
 795         (insert (format "%S" (intern (caar group-arts)))
 796                 " " (number-to-string (cdr (pop group-arts)))
 797                 " "))
 798       (insert "\n")
 799       (while (search-backward "\\." p t)
 800         (delete-char 1)))))
 801
 802 (defun gnus-agent-article-in-history-p (id)
 803   (save-excursion
 804     (set-buffer (gnus-agent-history-buffer))
 805     (goto-char (point-min))
 806     (search-forward (concat "\n" id "\t") nil t)))
 807
 808 (defun gnus-agent-history-path (id)
 809   (save-excursion
 810     (set-buffer (gnus-agent-history-buffer))
 811     (goto-char (point-min))
 812     (when (search-forward (concat "\n" id "\t") nil t)
 813       (let ((method (gnus-agent-method)))
 814         (let (paths group)
 815           (while (not (numberp (setq group (read (current-buffer)))))
 816             (push (concat method "/" group) paths))
 817           (nreverse paths))))))
 818
 819 ;;;
 820 ;;; Fetching
 821 ;;;
 822
 823 (defun gnus-agent-fetch-articles (group articles)
 824   "Fetch ARTICLES from GROUP and put them into the Agent."
 825   (when articles
 826     ;; Prune off articles that we have already fetched.
 827     (while (and articles
 828                 (cdr (assq (car articles) gnus-agent-article-alist)))
 829       (pop articles))
 830     (let ((arts articles))
 831       (while (cdr arts)
 832         (if (cdr (assq (cadr arts) gnus-agent-article-alist))
 833             (setcdr arts (cddr arts))
 834           (setq arts (cdr arts)))))
 835     (when articles
 836       (let ((dir (concat
 837                   (gnus-agent-directory)
 838                   (gnus-agent-group-path group) "/"))
 839             (date (time-to-days (current-time)))
 840             (case-fold-search t)
 841             pos crosses id elem)
 842         (gnus-make-directory dir)
 843         (gnus-message 7 "Fetching articles for %s..." group)
 844         ;; Fetch the articles from the backend.
 845         (if (gnus-check-backend-function 'retrieve-articles group)
 846             (setq pos (gnus-retrieve-articles articles group))
 847           (with-temp-buffer
 848             (let (article)
 849               (while (setq article (pop articles))
 850                 (when (or
 851                        (gnus-backlog-request-article group article
 852                                                      nntp-server-buffer)
 853                        (gnus-request-article article group))
 854                   (goto-char (point-max))
 855                   (push (cons article (point)) pos)
 856                   (insert-buffer-substring nntp-server-buffer)))
 857               (copy-to-buffer nntp-server-buffer (point-min) (point-max))
 858               (setq pos (nreverse pos)))))
 859         ;; Then save these articles into the Agent.
 860         (save-excursion
 861           (set-buffer nntp-server-buffer)
 862           (while pos
 863             (narrow-to-region (cdar pos) (or (cdadr pos) (point-max)))
 864             (goto-char (point-min))
 865             (when (search-forward "\n\n" nil t)
 866               (when (search-backward "\nXrefs: " nil t)
 867                 ;; Handle crossposting.
 868                 (skip-chars-forward "^ ")
 869                 (skip-chars-forward " ")
 870                 (setq crosses nil)
 871                 (while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) +")
 872                   (push (cons (buffer-substring (match-beginning 1)
 873                                                 (match-end 1))
 874                               (buffer-substring (match-beginning 2)
 875                                                 (match-end 2)))
 876                         crosses)
 877                   (goto-char (match-end 0)))
 878                 (gnus-agent-crosspost crosses (caar pos))))
 879             (goto-char (point-min))
 880             (if (not (re-search-forward "^Message-ID: *<\\([^>\n]+\\)>" nil t))
 881                 (setq id "No-Message-ID-in-article")
 882               (setq id (buffer-substring (match-beginning 1) (match-end 1))))
 883             (let ((coding-system-for-write
 884                    gnus-agent-file-coding-system))
 885               (write-region (point-min) (point-max)
 886                             (concat dir (number-to-string (caar pos)))
 887                             nil 'silent))
 888             (when (setq elem (assq (caar pos) gnus-agent-article-alist))
 889               (setcdr elem t))
 890             (gnus-agent-enter-history
 891              id (or crosses (list (cons group (caar pos)))) date)
 892             (widen)
 893             (pop pos)))
 894         (gnus-agent-save-alist group)))))
 895
 896 (defun gnus-agent-crosspost (crosses article)
 897   (let (gnus-agent-article-alist group alist beg end)
 898     (save-excursion
 899       (set-buffer gnus-agent-overview-buffer)
 900       (when (nnheader-find-nov-line article)
 901         (forward-word 1)
 902         (setq beg (point))
 903         (setq end (progn (forward-line 1) (point)))))
 904     (while crosses
 905       (setq group (caar crosses))
 906       (unless (setq alist (assoc group gnus-agent-group-alist))
 907         (push (setq alist (list group (gnus-agent-load-alist (caar crosses))))
 908               gnus-agent-group-alist))
 909       (setcdr alist (cons (cons (cdar crosses) t) (cdr alist)))
 910       (save-excursion
 911         (set-buffer (gnus-get-buffer-create (format " *Gnus agent overview %s*"
 912                                                     group)))
 913         (when (= (point-max) (point-min))
 914           (push (cons group (current-buffer)) gnus-agent-buffer-alist)
 915           (ignore-errors
 916             (nnheader-insert-file-contents
 917              (gnus-agent-article-name ".overview" group))))
 918         (nnheader-find-nov-line (string-to-number (cdar crosses)))
 919         (insert (string-to-number (cdar crosses)))
 920         (insert-buffer-substring gnus-agent-overview-buffer beg end))
 921       (pop crosses))))
 922
 923 (defun gnus-agent-flush-cache ()
 924   (save-excursion
 925     (while gnus-agent-buffer-alist
 926       (set-buffer (cdar gnus-agent-buffer-alist))
 927       (let ((coding-system-for-write
 928              gnus-agent-file-coding-system))
 929         (write-region (point-min) (point-max)
 930                       (gnus-agent-article-name ".overview"
 931                                                (caar gnus-agent-buffer-alist))
 932                       nil 'silent))
 933       (pop gnus-agent-buffer-alist))
 934     (while gnus-agent-group-alist
 935       (with-temp-file (caar gnus-agent-group-alist)
 936         (princ (cdar gnus-agent-group-alist))
 937         (insert "\n"))
 938       (pop gnus-agent-group-alist))))
 939
 940 (defun gnus-agent-fetch-headers (group &optional force)
 941   (let ((articles (gnus-list-of-unread-articles group))
 942         (gnus-decode-encoded-word-function 'identity)
 943         (file (gnus-agent-article-name ".overview" group)))
 944     ;; Add article with marks to list of article headers we want to fetch.
 945     (dolist (arts (gnus-info-marks (gnus-get-info group)))
 946       (setq articles (gnus-union (gnus-uncompress-sequence (cdr arts))
 947                             articles)))
 948     (setq articles (sort articles '<))
 949     ;; Remove known articles.
 950     (when (gnus-agent-load-alist group)
 951       (setq articles (gnus-sorted-intersection
 952                       articles
 953                       (gnus-uncompress-range
 954                        (cons (1+ (caar (last gnus-agent-article-alist)))
 955                              (cdr (gnus-active group)))))))
 956     ;; Fetch them.
 957     (gnus-make-directory (nnheader-translate-file-chars
 958                           (file-name-directory file) t))
 959     (when articles
 960       (gnus-message 7 "Fetching headers for %s..." group)
 961       (save-excursion
 962         (set-buffer nntp-server-buffer)
 963         (unless (eq 'nov (gnus-retrieve-headers articles group))
 964           (nnvirtual-convert-headers))
 965         ;; Save these headers for later processing.
 966         (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max))
 967         (when (file-exists-p file)
 968           (gnus-agent-braid-nov group articles file))
 969         (let ((coding-system-for-write
 970                gnus-agent-file-coding-system))
 971           (write-region (point-min) (point-max) file nil 'silent))
 972         (gnus-agent-save-alist group articles nil)
 973         (gnus-agent-enter-history
 974          "last-header-fetched-for-session"
 975          (list (cons group (nth (- (length  articles) 1) articles)))
 976          (time-to-days (current-time)))
 977         articles))))
 978
 979 (defsubst gnus-agent-copy-nov-line (article)
 980   (let (b e)
 981     (set-buffer gnus-agent-overview-buffer)
 982     (setq b (point))
 983     (if (eq article (read (current-buffer)))
 984         (setq e (progn (forward-line 1) (point)))
 985       (progn
 986         (beginning-of-line)
 987         (setq e b)))
 988     (set-buffer nntp-server-buffer)
 989     (insert-buffer-substring gnus-agent-overview-buffer b e)))
 990
 991 (defun gnus-agent-braid-nov (group articles file)
 992   (set-buffer gnus-agent-overview-buffer)
 993   (goto-char (point-min))
 994   (set-buffer nntp-server-buffer)
 995   (erase-buffer)
 996   (nnheader-insert-file-contents file)
 997   (goto-char (point-max))
 998   (if (or (= (point-min) (point-max))
 999           (progn
1000             (forward-line -1)
1001             (< (read (current-buffer)) (car articles))))
1002       ;; We have only headers that are after the older headers,
1003       ;; so we just append them.
1004       (progn
1005         (goto-char (point-max))
1006         (insert-buffer-substring gnus-agent-overview-buffer))
1007     ;; We do it the hard way.
1008     (nnheader-find-nov-line (car articles))
1009     (gnus-agent-copy-nov-line (car articles))
1010     (pop articles)
1011     (while (and articles
1012                 (not (eobp)))
1013       (while (and (not (eobp))
1014                   (< (read (current-buffer)) (car articles)))
1015         (forward-line 1))
1016       (beginning-of-line)
1017       (unless (eobp)
1018         (gnus-agent-copy-nov-line (car articles))
1019         (setq articles (cdr articles))))
1020     (when articles
1021       (let (b e)
1022         (set-buffer gnus-agent-overview-buffer)
1023         (setq b (point)
1024               e (point-max))
1025         (set-buffer nntp-server-buffer)
1026         (insert-buffer-substring gnus-agent-overview-buffer b e)))))
1027
1028 (defun gnus-agent-load-alist (group &optional dir)
1029   "Load the article-state alist for GROUP."
1030   (setq gnus-agent-article-alist
1031         (gnus-agent-read-file
1032          (if dir
1033              (expand-file-name ".agentview" dir)
1034            (gnus-agent-article-name ".agentview" group)))))
1035
1036 (defun gnus-agent-save-alist (group &optional articles state dir)
1037   "Save the article-state alist for GROUP."
1038   (let ((file-name-coding-system nnmail-pathname-coding-system))
1039       (with-temp-file (if dir
1040                           (expand-file-name ".agentview" dir)
1041                         (gnus-agent-article-name ".agentview" group))
1042         (princ (setq gnus-agent-article-alist
1043                      (nconc gnus-agent-article-alist
1044                             (mapcar (lambda (article) (cons article state))
1045                                     articles)))
1046                (current-buffer))
1047         (insert "\n"))))
1048
1049 (defun gnus-agent-article-name (article group)
1050   (expand-file-name (if (stringp article) article (string-to-number article))
1051                     (file-name-as-directory
1052                      (expand-file-name (gnus-agent-group-path group)
1053                                        (gnus-agent-directory)))))
1054
1055 (defun gnus-agent-batch-confirmation (msg)
1056   "Show error message and return t."
1057   (gnus-message 1 msg)
1058   t)
1059
1060 ;;;###autoload
1061 (defun gnus-agent-batch-fetch ()
1062   "Start Gnus and fetch session."
1063   (interactive)
1064   (gnus)
1065   (let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation))
1066     (gnus-agent-fetch-session))
1067   (gnus-group-exit))
1068
1069 (defun gnus-agent-fetch-session ()
1070   "Fetch all articles and headers that are eligible for fetching."
1071   (interactive)
1072   (unless gnus-agent-covered-methods
1073     (error "No servers are covered by the Gnus agent"))
1074   (unless gnus-plugged
1075     (error "Can't fetch articles while Gnus is unplugged"))
1076   (let ((methods gnus-agent-covered-methods)
1077         groups group gnus-command-method)
1078     (save-excursion
1079       (while methods
1080         (condition-case err
1081             (progn
1082               (setq gnus-command-method (car methods))
1083               (when (or (gnus-server-opened gnus-command-method)
1084                         (gnus-open-server gnus-command-method))
1085                 (setq groups (gnus-groups-from-server (car methods)))
1086                 (gnus-agent-with-fetch
1087                   (while (setq group (pop groups))
1088                     (when (<= (gnus-group-level group) gnus-agent-handle-level)
1089                       (gnus-agent-fetch-group-1 group gnus-command-method))))))
1090           (error
1091            (unless (funcall gnus-agent-confirmation-function
1092                             (format "Error (%s).  Continue? " err))
1093              (error "Cannot fetch articles into the Gnus agent.")))
1094           (quit
1095            (unless (funcall gnus-agent-confirmation-function
1096                             (format "Quit (%s).  Continue? " err))
1097              (signal 'quit "Cannot fetch articles into the Gnus agent."))))
1098         (pop methods))
1099       (gnus-message 6 "Finished fetching articles into the Gnus agent"))))
1100
1101 (defun gnus-agent-fetch-group-1 (group method)
1102   "Fetch GROUP."
1103   (let ((gnus-command-method method)
1104         (gnus-newsgroup-name group)
1105         gnus-newsgroup-dependencies gnus-newsgroup-headers
1106         gnus-newsgroup-scored gnus-headers gnus-score
1107         gnus-use-cache articles arts
1108         category predicate info marks score-param
1109         (gnus-summary-expunge-below gnus-summary-expunge-below)
1110         (gnus-summary-mark-below gnus-summary-mark-below)
1111         (gnus-orphan-score gnus-orphan-score)
1112         ;; Maybe some other gnus-summary local variables should also
1113         ;; be put here.
1114         )
1115     (unless (gnus-check-group group)
1116       (error "Can't open server for %s" group))
1117     ;; Fetch headers.
1118     (when (and (or (gnus-active group) (gnus-activate-group group))
1119                (setq articles (gnus-agent-fetch-headers group))
1120                (let ((nntp-server-buffer gnus-agent-overview-buffer))
1121                  ;; Parse them and see which articles we want to fetch.
1122                  (setq gnus-newsgroup-dependencies
1123                        (make-vector (length articles) 0))
1124                  (setq gnus-newsgroup-headers
1125                        (gnus-get-newsgroup-headers-xover articles nil nil
1126                                                          group))
1127                  ;; `gnus-agent-overview-buffer' may be killed for
1128                  ;; timeout reason.  If so, recreate it.
1129                  (gnus-agent-create-buffer)))
1130       (setq category (gnus-group-category group))
1131       (setq predicate
1132             (gnus-get-predicate
1133              (or (gnus-group-find-parameter group 'agent-predicate t)
1134                  (cadr category))))
1135       (if (memq (caaddr predicate) '(gnus-agent-true gnus-agent-false))
1136           ;; Simple implementation
1137           (setq arts
1138                 (and (eq (caaddr predicate) 'gnus-agent-true) articles))
1139         (setq arts nil)
1140         (setq score-param
1141               (or (gnus-group-get-parameter group 'agent-score t)
1142                   (caddr category)))
1143         ;; Translate score-param into real one
1144         (cond
1145          ((not score-param))
1146          ((eq score-param 'file)
1147           (setq score-param (gnus-all-score-files group)))
1148          ((stringp (car score-param)))
1149          (t
1150           (setq score-param (list (list score-param)))))
1151         (when score-param
1152           (gnus-score-headers score-param))
1153         (while (setq gnus-headers (pop gnus-newsgroup-headers))
1154           (setq gnus-score
1155                 (or (cdr (assq (mail-header-number gnus-headers)
1156                                gnus-newsgroup-scored))
1157                     gnus-summary-default-score))
1158           (when (funcall predicate)
1159             (push (mail-header-number gnus-headers)
1160                   arts))))
1161       ;; Fetch the articles.
1162       (when arts
1163         (gnus-agent-fetch-articles group arts)))
1164     ;; Perhaps we have some additional articles to fetch.
1165     (setq arts (assq 'download (gnus-info-marks
1166                                 (setq info (gnus-get-info group)))))
1167     (when (cdr arts)
1168       (gnus-agent-fetch-articles
1169        group (gnus-uncompress-range (cdr arts)))
1170       (setq marks (delq arts (gnus-info-marks info)))
1171       (gnus-info-set-marks info marks)
1172       (gnus-dribble-enter
1173        (concat "(gnus-group-set-info '"
1174                (gnus-prin1-to-string info)
1175                ")")))))
1176
1177 ;;;
1178 ;;; Agent Category Mode
1179 ;;;
1180
1181 (defvar gnus-category-mode-hook nil
1182   "Hook run in `gnus-category-mode' buffers.")
1183
1184 (defvar gnus-category-line-format "     %(%20c%): %g\n"
1185   "Format of category lines.")
1186
1187 (defvar gnus-category-mode-line-format "Gnus: %%b"
1188   "The format specification for the category mode line.")
1189
1190 (defvar gnus-agent-short-article 100
1191   "Articles that have fewer lines than this are short.")
1192
1193 (defvar gnus-agent-long-article 200
1194   "Articles that have more lines than this are long.")
1195
1196 (defvar gnus-agent-low-score 0
1197   "Articles that have a score lower than this have a low score.")
1198
1199 (defvar gnus-agent-high-score 0
1200   "Articles that have a score higher than this have a high score.")
1201
1202
1203 ;;; Internal variables.
1204
1205 (defvar gnus-category-buffer "*Agent Category*")
1206
1207 (defvar gnus-category-line-format-alist
1208   `((?c gnus-tmp-name ?s)
1209     (?g gnus-tmp-groups ?d)))
1210
1211 (defvar gnus-category-mode-line-format-alist
1212   `((?u user-defined ?s)))
1213
1214 (defvar gnus-category-line-format-spec nil)
1215 (defvar gnus-category-mode-line-format-spec nil)
1216
1217 (defvar gnus-category-mode-map nil)
1218 (put 'gnus-category-mode 'mode-class 'special)
1219
1220 (unless gnus-category-mode-map
1221   (setq gnus-category-mode-map (make-sparse-keymap))
1222   (suppress-keymap gnus-category-mode-map)
1223
1224   (gnus-define-keys gnus-category-mode-map
1225     "q" gnus-category-exit
1226     "k" gnus-category-kill
1227     "c" gnus-category-copy
1228     "a" gnus-category-add
1229     "p" gnus-category-edit-predicate
1230     "g" gnus-category-edit-groups
1231     "s" gnus-category-edit-score
1232     "l" gnus-category-list
1233
1234     "\C-c\C-i" gnus-info-find-node
1235     "\C-c\C-b" gnus-bug))
1236
1237 (defvar gnus-category-menu-hook nil
1238   "*Hook run after the creation of the menu.")
1239
1240 (defun gnus-category-make-menu-bar ()
1241   (gnus-turn-off-edit-menu 'category)
1242   (unless (boundp 'gnus-category-menu)
1243     (easy-menu-define
1244      gnus-category-menu gnus-category-mode-map ""
1245      '("Categories"
1246        ["Add" gnus-category-add t]
1247        ["Kill" gnus-category-kill t]
1248        ["Copy" gnus-category-copy t]
1249        ["Edit predicate" gnus-category-edit-predicate t]
1250        ["Edit score" gnus-category-edit-score t]
1251        ["Edit groups" gnus-category-edit-groups t]
1252        ["Exit" gnus-category-exit t]))
1253
1254     (gnus-run-hooks 'gnus-category-menu-hook)))
1255
1256 (defun gnus-category-mode ()
1257   "Major mode for listing and editing agent categories.
1258
1259 All normal editing commands are switched off.
1260 \\<gnus-category-mode-map>
1261 For more in-depth information on this mode, read the manual
1262 (`\\[gnus-info-find-node]').
1263
1264 The following commands are available:
1265
1266 \\{gnus-category-mode-map}"
1267   (interactive)
1268   (when (gnus-visual-p 'category-menu 'menu)
1269     (gnus-category-make-menu-bar))
1270   (kill-all-local-variables)
1271   (gnus-simplify-mode-line)
1272   (setq major-mode 'gnus-category-mode)
1273   (setq mode-name "Category")
1274   (gnus-set-default-directory)
1275   (setq mode-line-process nil)
1276   (use-local-map gnus-category-mode-map)
1277   (buffer-disable-undo)
1278   (setq truncate-lines t)
1279   (setq buffer-read-only t)
1280   (gnus-run-hooks 'gnus-category-mode-hook))
1281
1282 (defalias 'gnus-category-position-point 'gnus-goto-colon)
1283
1284 (defun gnus-category-insert-line (category)
1285   (let* ((gnus-tmp-name (car category))
1286          (gnus-tmp-groups (length (cadddr category))))
1287     (beginning-of-line)
1288     (gnus-add-text-properties
1289      (point)
1290      (prog1 (1+ (point))
1291        ;; Insert the text.
1292        (eval gnus-category-line-format-spec))
1293      (list 'gnus-category gnus-tmp-name))))
1294
1295 (defun gnus-enter-category-buffer ()
1296   "Go to the Category buffer."
1297   (interactive)
1298   (gnus-category-setup-buffer)
1299   (gnus-configure-windows 'category)
1300   (gnus-category-prepare))
1301
1302 (defun gnus-category-setup-buffer ()
1303   (unless (get-buffer gnus-category-buffer)
1304     (save-excursion
1305       (set-buffer (gnus-get-buffer-create gnus-category-buffer))
1306       (gnus-category-mode))))
1307
1308 (defun gnus-category-prepare ()
1309   (gnus-set-format 'category-mode)
1310   (gnus-set-format 'category t)
1311   (let ((alist gnus-category-alist)
1312         (buffer-read-only nil))
1313     (erase-buffer)
1314     (while alist
1315       (gnus-category-insert-line (pop alist)))
1316     (goto-char (point-min))
1317     (gnus-category-position-point)))
1318
1319 (defun gnus-category-name ()
1320   (or (get-text-property (gnus-point-at-bol) 'gnus-category)
1321       (error "No category on the current line")))
1322
1323 (defun gnus-category-read ()
1324   "Read the category alist."
1325   (setq gnus-category-alist
1326         (or (gnus-agent-read-file
1327              (nnheader-concat gnus-agent-directory "lib/categories"))
1328             (list (list 'default 'short nil nil)))))
1329
1330 (defun gnus-category-write ()
1331   "Write the category alist."
1332   (setq gnus-category-predicate-cache nil
1333         gnus-category-group-cache nil)
1334   (gnus-make-directory (nnheader-concat gnus-agent-directory "lib"))
1335   (with-temp-file (nnheader-concat gnus-agent-directory "lib/categories")
1336     (prin1 gnus-category-alist (current-buffer))))
1337
1338 (defun gnus-category-edit-predicate (category)
1339   "Edit the predicate for CATEGORY."
1340   (interactive (list (gnus-category-name)))
1341   (let ((info (assq category gnus-category-alist)))
1342     (gnus-edit-form
1343      (cadr info) (format "Editing the predicate for category %s" category)
1344      `(lambda (predicate)
1345         (setcar (cdr (assq ',category gnus-category-alist)) predicate)
1346         (gnus-category-write)
1347         (gnus-category-list)))))
1348
1349 (defun gnus-category-edit-score (category)
1350   "Edit the score expression for CATEGORY."
1351   (interactive (list (gnus-category-name)))
1352   (let ((info (assq category gnus-category-alist)))
1353     (gnus-edit-form
1354      (caddr info)
1355      (format "Editing the score expression for category %s" category)
1356      `(lambda (groups)
1357         (setcar (cddr (assq ',category gnus-category-alist)) groups)
1358         (gnus-category-write)
1359         (gnus-category-list)))))
1360
1361 (defun gnus-category-edit-groups (category)
1362   "Edit the group list for CATEGORY."
1363   (interactive (list (gnus-category-name)))
1364   (let ((info (assq category gnus-category-alist)))
1365     (gnus-edit-form
1366      (cadddr info) (format "Editing the group list for category %s" category)
1367      `(lambda (groups)
1368         (setcar (nthcdr 3 (assq ',category gnus-category-alist)) groups)
1369         (gnus-category-write)
1370         (gnus-category-list)))))
1371
1372 (defun gnus-category-kill (category)
1373   "Kill the current category."
1374   (interactive (list (gnus-category-name)))
1375   (let ((info (assq category gnus-category-alist))
1376         (buffer-read-only nil))
1377     (gnus-delete-line)
1378     (setq gnus-category-alist (delq info gnus-category-alist))
1379     (gnus-category-write)))
1380
1381 (defun gnus-category-copy (category to)
1382   "Copy the current category."
1383   (interactive (list (gnus-category-name) (intern (read-string "New name: "))))
1384   (let ((info (assq category gnus-category-alist)))
1385     (push (list to (gnus-copy-sequence (cadr info))
1386                 (gnus-copy-sequence (caddr info)) nil)
1387           gnus-category-alist)
1388     (gnus-category-write)
1389     (gnus-category-list)))
1390
1391 (defun gnus-category-add (category)
1392   "Create a new category."
1393   (interactive "SCategory name: ")
1394   (when (assq category gnus-category-alist)
1395     (error "Category %s already exists" category))
1396   (push (list category 'false nil nil)
1397         gnus-category-alist)
1398   (gnus-category-write)
1399   (gnus-category-list))
1400
1401 (defun gnus-category-list ()
1402   "List all categories."
1403   (interactive)
1404   (gnus-category-prepare))
1405
1406 (defun gnus-category-exit ()
1407   "Return to the group buffer."
1408   (interactive)
1409   (kill-buffer (current-buffer))
1410   (gnus-configure-windows 'group t))
1411
1412 ;; To avoid having 8-bit characters in the source file.
1413 (defvar gnus-category-not (list '! 'not (intern (format "%c" 172))))
1414
1415 (defvar gnus-category-predicate-alist
1416   '((spam . gnus-agent-spam-p)
1417     (short . gnus-agent-short-p)