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

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