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

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