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

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