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
   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-handle-level gnus-level-subscribed
  57   "Groups on levels higher than this variable will be ignored by the Agent."
  58   :group 'gnus-agent
  59   :type 'integer)
  60
  61 (defcustom gnus-agent-expire-days 7
  62   "Read articles older than this will be expired."
  63   :group 'gnus-agent
  64   :type 'integer)
  65
  66 (defcustom gnus-agent-expire-all nil
  67   "If non-nil, also expire unread, ticked and dormant articles.
  68 If nil, only read articles will be expired."
  69   :group 'gnus-agent
  70   :type 'boolean)
  71
  72 (defcustom gnus-agent-group-mode-hook nil
  73   "Hook run in Agent group minor modes."
  74   :group 'gnus-agent
  75   :type 'hook)
  76
  77 ;; Extracted from gnus-xmas-redefine in order to preserve user settings
  78 (when (featurep 'xemacs)
  79   (add-hook 'gnus-agent-group-mode-hook 'gnus-xmas-agent-group-menu-add))
  80
  81 (defcustom gnus-agent-summary-mode-hook nil
  82   "Hook run in Agent summary minor modes."
  83   :group 'gnus-agent
  84   :type 'hook)
  85
  86 ;; Extracted from gnus-xmas-redefine in order to preserve user settings
  87 (when (featurep 'xemacs)
  88   (add-hook 'gnus-agent-summary-mode-hook 'gnus-xmas-agent-summary-menu-add))
  89
  90 (defcustom gnus-agent-server-mode-hook nil
  91   "Hook run in Agent summary minor modes."
  92   :group 'gnus-agent
  93   :type 'hook)
  94
  95 ;; Extracted from gnus-xmas-redefine in order to preserve user settings
  96 (when (featurep 'xemacs)
  97   (add-hook 'gnus-agent-server-mode-hook 'gnus-xmas-agent-server-menu-add))
  98
  99 (defcustom gnus-agent-confirmation-function 'y-or-n-p
 100   "Function to confirm when error happens."
 101   :version "21.1"
 102   :group 'gnus-agent
 103   :type 'function)
 104
 105 (defcustom gnus-agent-synchronize-flags 'ask
 106   "Indicate if flags are synchronized when you plug in.
 107 If this is `ask' the hook will query the user."
 108   :version "21.1"
 109   :type '(choice (const :tag "Always" t)
 110                  (const :tag "Never" nil)
 111                  (const :tag "Ask" ask))
 112   :group 'gnus-agent)
 113
 114 ;;; Internal variables
 115
 116 (defvar gnus-agent-history-buffers nil)
 117 (defvar gnus-agent-buffer-alist nil)
 118 (defvar gnus-agent-article-alist nil)
 119 (defvar gnus-agent-group-alist nil)
 120 (defvar gnus-agent-covered-methods nil)
 121 (defvar gnus-category-alist nil)
 122 (defvar gnus-agent-current-history nil)
 123 (defvar gnus-agent-overview-buffer nil)
 124 (defvar gnus-category-predicate-cache nil)
 125 (defvar gnus-category-group-cache nil)
 126 (defvar gnus-agent-spam-hashtb nil)
 127 (defvar gnus-agent-file-name nil)
 128 (defvar gnus-agent-send-mail-function nil)
 129 (defvar gnus-agent-file-coding-system 'raw-text)
 130
 131 ;; Dynamic variables
 132 (defvar gnus-headers)
 133 (defvar gnus-score)
 134
 135 ;;;
 136 ;;; Setup
 137 ;;;
 138
 139 (defun gnus-open-agent ()
 140   (setq gnus-agent t)
 141   (gnus-agent-read-servers)
 142   (gnus-category-read)
 143   (gnus-agent-create-buffer)
 144   (add-hook 'gnus-group-mode-hook 'gnus-agent-mode)
 145   (add-hook 'gnus-summary-mode-hook 'gnus-agent-mode)
 146   (add-hook 'gnus-server-mode-hook 'gnus-agent-mode))
 147
 148 (defun gnus-agent-create-buffer ()
 149   (if (gnus-buffer-live-p gnus-agent-overview-buffer)
 150       t
 151     (setq gnus-agent-overview-buffer
 152           (gnus-get-buffer-create " *Gnus agent overview*"))
 153     (with-current-buffer gnus-agent-overview-buffer
 154       (mm-enable-multibyte))
 155     nil))
 156
 157 (gnus-add-shutdown 'gnus-close-agent 'gnus)
 158
 159 (defun gnus-close-agent ()
 160   (setq gnus-agent-covered-methods nil
 161         gnus-category-predicate-cache nil
 162         gnus-category-group-cache nil
 163         gnus-agent-spam-hashtb nil)
 164   (gnus-kill-buffer gnus-agent-overview-buffer))
 165
 166 ;;;
 167 ;;; Utility functions
 168 ;;;
 169
 170 (defun gnus-agent-read-file (file)
 171   "Load FILE and do a `read' there."
 172   (with-temp-buffer
 173     (ignore-errors
 174       (nnheader-insert-file-contents file)
 175       (goto-char (point-min))
 176       (read (current-buffer)))))
 177
 178 (defsubst gnus-agent-method ()
 179   (concat (symbol-name (car gnus-command-method)) "/"
 180           (if (equal (cadr gnus-command-method) "")
 181               "unnamed"
 182             (cadr gnus-command-method))))
 183
 184 (defsubst gnus-agent-directory ()
 185   "Path of the Gnus agent directory."
 186   (nnheader-concat gnus-agent-directory
 187                    (nnheader-translate-file-chars (gnus-agent-method)) "/"))
 188
 189 (defun gnus-agent-lib-file (file)
 190   "The full path of the Gnus agent library FILE."
 191   (expand-file-name file
 192                     (file-name-as-directory
 193                      (expand-file-name "agent.lib" (gnus-agent-directory)))))
 194
 195 ;;; Fetching setup functions.
 196
 197 (defun gnus-agent-start-fetch ()
 198   "Initialize data structures for efficient fetching."
 199   (gnus-agent-open-history)
 200   (setq gnus-agent-current-history (gnus-agent-history-buffer))
 201   (gnus-agent-create-buffer))
 202
 203 (defun gnus-agent-stop-fetch ()
 204   "Save all data structures and clean up."
 205   (gnus-agent-save-history)
 206   (gnus-agent-close-history)
 207   (setq gnus-agent-spam-hashtb nil)
 208   (save-excursion
 209     (set-buffer nntp-server-buffer)
 210     (widen)))
 211
 212 (defmacro gnus-agent-with-fetch (&rest forms)
 213   "Do FORMS safely."
 214   `(unwind-protect
 215        (let ((gnus-agent-fetching t))
 216          (gnus-agent-start-fetch)
 217          ,@forms)
 218      (gnus-agent-stop-fetch)))
 219
 220 (put 'gnus-agent-with-fetch 'lisp-indent-function 0)
 221 (put 'gnus-agent-with-fetch 'edebug-form-spec '(body))
 222
 223 ;;;
 224 ;;; Mode infestation
 225 ;;;
 226
 227 (defvar gnus-agent-mode-hook nil
 228   "Hook run when installing agent mode.")
 229
 230 (defvar gnus-agent-mode nil)
 231 (defvar gnus-agent-mode-status '(gnus-agent-mode " Plugged"))
 232
 233 (defun gnus-agent-mode ()
 234   "Minor mode for providing a agent support in Gnus buffers."
 235   (let* ((buffer (progn (string-match "^gnus-\\(.*\\)-mode$"
 236                                       (symbol-name major-mode))
 237                         (match-string 1 (symbol-name major-mode))))
 238          (mode (intern (format "gnus-agent-%s-mode" buffer))))
 239     (set (make-local-variable 'gnus-agent-mode) t)
 240     (set mode nil)
 241     (set (make-local-variable mode) t)
 242     ;; Set up the menu.
 243     (when (gnus-visual-p 'agent-menu 'menu)
 244       (funcall (intern (format "gnus-agent-%s-make-menu-bar" buffer))))
 245     (unless (assq 'gnus-agent-mode minor-mode-alist)
 246       (push gnus-agent-mode-status minor-mode-alist))
 247     (unless (assq mode minor-mode-map-alist)
 248       (push (cons mode (symbol-value (intern (format "gnus-agent-%s-mode-map"
 249                                                      buffer))))
 250             minor-mode-map-alist))
 251     (when (eq major-mode 'gnus-group-mode)
 252       (gnus-agent-toggle-plugged gnus-plugged))
 253     (gnus-run-hooks 'gnus-agent-mode-hook
 254                     (intern (format "gnus-agent-%s-mode-hook" buffer)))))
 255
 256 (defvar gnus-agent-group-mode-map (make-sparse-keymap))
 257 (gnus-define-keys gnus-agent-group-mode-map
 258   "Ju" gnus-agent-fetch-groups
 259   "Jc" gnus-enter-category-buffer
 260   "Jj" gnus-agent-toggle-plugged
 261   "Js" gnus-agent-fetch-session
 262   "JY" gnus-agent-synchronize-flags
 263   "JS" gnus-group-send-drafts
 264   "Ja" gnus-agent-add-group
 265   "Jr" gnus-agent-remove-group)
 266
 267 (defun gnus-agent-group-make-menu-bar ()
 268   (unless (boundp 'gnus-agent-group-menu)
 269     (easy-menu-define
 270      gnus-agent-group-menu gnus-agent-group-mode-map ""
 271      '("Agent"
 272        ["Toggle plugged" gnus-agent-toggle-plugged t]
 273        ["List categories" gnus-enter-category-buffer t]
 274        ["Send drafts" gnus-group-send-drafts gnus-plugged]
 275        ("Fetch"
 276         ["All" gnus-agent-fetch-session gnus-plugged]
 277         ["Group" gnus-agent-fetch-group gnus-plugged])))))
 278
 279 (defvar gnus-agent-summary-mode-map (make-sparse-keymap))
 280 (gnus-define-keys gnus-agent-summary-mode-map
 281   "Jj" gnus-agent-toggle-plugged
 282   "J#" gnus-agent-mark-article
 283   "J\M-#" gnus-agent-unmark-article
 284   "@" gnus-agent-toggle-mark
 285   "Jc" gnus-agent-catchup)
 286
 287 (defun gnus-agent-summary-make-menu-bar ()
 288   (unless (boundp 'gnus-agent-summary-menu)
 289     (easy-menu-define
 290      gnus-agent-summary-menu gnus-agent-summary-mode-map ""
 291      '("Agent"
 292        ["Toggle plugged" gnus-agent-toggle-plugged t]
 293        ["Mark as downloadable" gnus-agent-mark-article t]
 294        ["Unmark as downloadable" gnus-agent-unmark-article t]
 295        ["Toggle mark" gnus-agent-toggle-mark t]
 296        ["Catchup undownloaded" gnus-agent-catchup t]))))
 297
 298 (defvar gnus-agent-server-mode-map (make-sparse-keymap))
 299 (gnus-define-keys gnus-agent-server-mode-map
 300   "Jj" gnus-agent-toggle-plugged
 301   "Ja" gnus-agent-add-server
 302   "Jr" gnus-agent-remove-server)
 303
 304 (defun gnus-agent-server-make-menu-bar ()
 305   (unless (boundp 'gnus-agent-server-menu)
 306     (easy-menu-define
 307      gnus-agent-server-menu gnus-agent-server-mode-map ""
 308      '("Agent"
 309        ["Toggle plugged" gnus-agent-toggle-plugged t]
 310        ["Add" gnus-agent-add-server t]
 311        ["Remove" gnus-agent-remove-server t]))))
 312
 313 (defun gnus-agent-toggle-plugged (plugged)
 314   "Toggle whether Gnus is unplugged or not."
 315   (interactive (list (not gnus-plugged)))
 316   (if plugged
 317       (progn
 318         (setq gnus-plugged plugged)
 319         (gnus-agent-possibly-synchronize-flags)
 320         (gnus-run-hooks 'gnus-agent-plugged-hook)
 321         (setcar (cdr gnus-agent-mode-status) " Plugged"))
 322     (gnus-agent-close-connections)
 323     (setq gnus-plugged plugged)
 324     (gnus-run-hooks 'gnus-agent-unplugged-hook)
 325     (setcar (cdr gnus-agent-mode-status) " Unplugged"))
 326   (set-buffer-modified-p t))
 327
 328 (defun gnus-agent-close-connections ()
 329   "Close all methods covered by the Gnus agent."
 330   (let ((methods gnus-agent-covered-methods))
 331     (while methods
 332       (gnus-close-server (pop methods)))))
 333
 334 ;;;###autoload
 335 (defun gnus-unplugged ()
 336   "Start Gnus unplugged."
 337   (interactive)
 338   (setq gnus-plugged nil)
 339   (gnus))
 340
 341 ;;;###autoload
 342 (defun gnus-plugged ()
 343   "Start Gnus plugged."
 344   (interactive)
 345   (setq gnus-plugged t)
 346   (gnus))
 347
 348 ;;;###autoload
 349 (defun gnus-agentize ()
 350   "Allow Gnus to be an offline newsreader.
 351 The normal usage of this command is to put the following as the
 352 last form in your `.gnus.el' file:
 353
 354 \(gnus-agentize)
 355
 356 This will modify the `gnus-setup-news-hook', and
 357 `message-send-mail-function' variables, and install the Gnus agent
 358 minor mode in all Gnus buffers."
 359   (interactive)
 360   (gnus-open-agent)
 361   (add-hook 'gnus-setup-news-hook 'gnus-agent-queue-setup)
 362   (unless gnus-agent-send-mail-function
 363     (setq gnus-agent-send-mail-function message-send-mail-function
 364           message-send-mail-function 'gnus-agent-send-mail))
 365   (unless gnus-agent-covered-methods
 366     (setq gnus-agent-covered-methods (list gnus-select-method))))
 367
 368 (defun gnus-agent-queue-setup ()
 369   "Make sure the queue group exists."
 370   (unless (gnus-gethash "nndraft:queue" gnus-newsrc-hashtb)
 371     (gnus-request-create-group "queue" '(nndraft ""))
 372     (let ((gnus-level-default-subscribed 1))
 373       (gnus-subscribe-group "nndraft:queue" nil '(nndraft "")))
 374     (gnus-group-set-parameter
 375      "nndraft:queue" 'gnus-dummy '((gnus-draft-mode)))))
 376
 377 (defun gnus-agent-send-mail ()
 378   (if gnus-plugged
 379       (funcall gnus-agent-send-mail-function)
 380     (goto-char (point-min))
 381     (re-search-forward
 382      (concat "^" (regexp-quote mail-header-separator) "\n"))
 383     (replace-match "\n")
 384     (gnus-agent-insert-meta-information 'mail)
 385     (gnus-request-accept-article "nndraft:queue" nil t t)))
 386
 387 (defun gnus-agent-insert-meta-information (type &optional method)
 388   "Insert meta-information into the message that says how it's to be posted.
 389 TYPE can be either `mail' or `news'.  If the latter, then METHOD can
 390 be a select method."
 391   (save-excursion
 392     (message-remove-header gnus-agent-meta-information-header)
 393     (goto-char (point-min))
 394     (insert gnus-agent-meta-information-header ": "
 395             (symbol-name type) " " (format "%S" method)
 396             "\n")
 397     (forward-char -1)
 398     (while (search-backward "\n" nil t)
 399       (replace-match "\\n" t t))))
 400
 401 (defun gnus-agent-restore-gcc ()
 402   "Restore GCC field from saved header."
 403   (save-excursion
 404     (goto-char (point-min))
 405     (while (re-search-forward (concat gnus-agent-gcc-header ":") nil t)
 406       (replace-match "Gcc:" 'fixedcase))))
 407
 408 (defun gnus-agent-any-covered-gcc ()
 409   (save-restriction
 410     (message-narrow-to-headers)
 411     (let* ((gcc (mail-fetch-field "gcc" nil t))
 412            (methods (and gcc
 413                          (mapcar 'gnus-inews-group-method
 414                                  (message-unquote-tokens
 415                                   (message-tokenize-header
 416                                    gcc " ,")))))
 417            covered)
 418       (while (and (not covered) methods)
 419         (setq covered
 420               (member (car methods) gnus-agent-covered-methods)
 421               methods (cdr methods)))
 422       covered)))
 423
 424 (defun gnus-agent-possibly-save-gcc ()
 425   "Save GCC if Gnus is unplugged."
 426   (when (and (not gnus-plugged) (gnus-agent-any-covered-gcc))
 427     (save-excursion
 428       (goto-char (point-min))
 429       (let ((case-fold-search t))
 430         (while (re-search-forward "^gcc:" nil t)
 431           (replace-match (concat gnus-agent-gcc-header ":") 'fixedcase))))))
 432
 433 (defun gnus-agent-possibly-do-gcc ()
 434   "Do GCC if Gnus is plugged."
 435   (when (or gnus-plugged (not (gnus-agent-any-covered-gcc)))
 436     (gnus-inews-do-gcc)))
 437
 438 ;;;
 439 ;;; Group mode commands
 440 ;;;
 441
 442 (defun gnus-agent-fetch-groups (n)
 443   "Put all new articles in the current groups into the Agent."
 444   (interactive "P")
 445   (unless gnus-plugged
 446     (error "Groups can't be fetched when Gnus is unplugged"))
 447   (gnus-group-iterate n 'gnus-agent-fetch-group))
 448
 449 (defun gnus-agent-fetch-group (group)
 450   "Put all new articles in GROUP into the Agent."
 451   (interactive (list (gnus-group-group-name)))
 452   (unless gnus-plugged
 453     (error "Groups can't be fetched when Gnus is unplugged"))
 454   (unless group
 455     (error "No group on the current line"))
 456   (let ((gnus-command-method (gnus-find-method-for-group group)))
 457     (gnus-agent-with-fetch
 458       (gnus-agent-fetch-group-1 group gnus-command-method)
 459       (gnus-message 5 "Fetching %s...done" group))))
 460
 461 (defun gnus-agent-add-group (category arg)
 462   "Add the current group to an agent category."
 463   (interactive
 464    (list
 465     (intern
 466      (completing-read
 467       "Add to category: "
 468       (mapcar (lambda (cat) (list (symbol-name (car cat))))
 469               gnus-category-alist)
 470       nil t))
 471     current-prefix-arg))
 472   (let ((cat (assq category gnus-category-alist))
 473         c groups)
 474     (gnus-group-iterate arg
 475       (lambda (group)
 476         (when (cadddr (setq c (gnus-group-category group)))
 477           (setf (cadddr c) (delete group (cadddr c))))
 478         (push group groups)))
 479     (setf (cadddr cat) (nconc (cadddr cat) groups))
 480     (gnus-category-write)))
 481
 482 (defun gnus-agent-remove-group (arg)
 483   "Remove the current group from its agent category, if any."
 484   (interactive "P")
 485   (let (c)
 486     (gnus-group-iterate arg
 487       (lambda (group)
 488         (when (cadddr (setq c (gnus-group-category group)))
 489           (setf (cadddr c) (delete group (cadddr c))))))
 490     (gnus-category-write)))
 491
 492 (defun gnus-agent-synchronize-flags ()
 493   "Synchronize unplugged flags with servers."
 494   (interactive)
 495   (save-excursion
 496     (dolist (gnus-command-method gnus-agent-covered-methods)
 497       (when (file-exists-p (gnus-agent-lib-file "flags"))
 498         (gnus-agent-synchronize-flags-server gnus-command-method)))))
 499
 500 (defun gnus-agent-possibly-synchronize-flags ()
 501   "Synchronize flags according to `gnus-agent-synchronize-flags'."
 502   (interactive)
 503   (save-excursion
 504     (dolist (gnus-command-method gnus-agent-covered-methods)
 505       (when (file-exists-p (gnus-agent-lib-file "flags"))
 506         (gnus-agent-possibly-synchronize-flags-server gnus-command-method)))))
 507
 508 (defun gnus-agent-synchronize-flags-server (method)
 509   "Synchronize flags set when unplugged for server."
 510   (let ((gnus-command-method method))
 511     (when (file-exists-p (gnus-agent-lib-file "flags"))
 512       (set-buffer (get-buffer-create " *Gnus Agent flag synchronize*"))
 513       (erase-buffer)
 514       (nnheader-insert-file-contents (gnus-agent-lib-file "flags"))
 515       (if (null (gnus-check-server gnus-command-method))
 516           (message "Couldn't open server %s" (nth 1 gnus-command-method))
 517         (while (not (eobp))
 518           (if (null (eval (read (current-buffer))))
 519               (progn (forward-line)
 520                      (kill-line -1))
 521             (write-file (gnus-agent-lib-file "flags"))
 522             (error "Couldn't set flags from file %s"
 523                    (gnus-agent-lib-file "flags"))))
 524         (delete-file (gnus-agent-lib-file "flags")))
 525       (kill-buffer nil))))
 526
 527 (defun gnus-agent-possibly-synchronize-flags-server (method)
 528   "Synchronize flags for server according to `gnus-agent-synchronize-flags'."
 529   (when (or (and gnus-agent-synchronize-flags
 530                  (not (eq gnus-agent-synchronize-flags 'ask)))
 531             (and (eq gnus-agent-synchronize-flags 'ask)
 532                  (gnus-y-or-n-p (format "Synchronize flags on server `%s'? "
 533                                         (cadr method)))))
 534     (gnus-agent-synchronize-flags-server method)))
 535
 536 ;;;
 537 ;;; Server mode commands
 538 ;;;
 539
 540 (defun gnus-agent-add-server (server)
 541   "Enroll SERVER in the agent program."
 542   (interactive (list (gnus-server-server-name)))
 543   (unless server
 544     (error "No server on the current line"))
 545   (let ((method (gnus-server-get-method nil (gnus-server-server-name))))
 546     (when (member method gnus-agent-covered-methods)
 547       (error "Server already in the agent program"))
 548     (push method gnus-agent-covered-methods)
 549     (gnus-server-update-server server)
 550     (gnus-agent-write-servers)
 551     (message "Entered %s into the Agent" server)))
 552
 553 (defun gnus-agent-remove-server (server)
 554   "Remove SERVER from the agent program."
 555   (interactive (list (gnus-server-server-name)))
 556   (unless server
 557     (error "No server on the current line"))
 558   (let ((method (gnus-server-get-method nil (gnus-server-server-name))))
 559     (unless (member method gnus-agent-covered-methods)
 560       (error "Server not in the agent program"))
 561     (setq gnus-agent-covered-methods
 562           (delete method gnus-agent-covered-methods))
 563     (gnus-server-update-server server)
 564     (gnus-agent-write-servers)
 565     (message "Removed %s from the agent" server)))
 566
 567 (defun gnus-agent-read-servers ()
 568   "Read the alist of covered servers."
 569   (setq gnus-agent-covered-methods
 570         (gnus-agent-read-file
 571          (nnheader-concat gnus-agent-directory "lib/servers"))))
 572
 573 (defun gnus-agent-write-servers ()
 574   "Write the alist of covered servers."
 575   (gnus-make-directory (nnheader-concat gnus-agent-directory "lib"))
 576   (let ((coding-system-for-write nnheader-file-coding-system)
 577         (file-name-coding-system nnmail-pathname-coding-system))
 578     (with-temp-file (nnheader-concat gnus-agent-directory "lib/servers")
 579       (prin1 gnus-agent-covered-methods (current-buffer)))))
 580
 581 ;;;
 582 ;;; Summary commands
 583 ;;;
 584
 585 (defun gnus-agent-mark-article (n &optional unmark)
 586   "Mark the next N articles as downloadable.
 587 If N is negative, mark backward instead.  If UNMARK is non-nil, remove
 588 the mark instead.  The difference between N and the actual number of
 589 articles marked is returned."
 590   (interactive "p")
 591   (let ((backward (< n 0))
 592         (n (abs n)))
 593     (while (and
 594             (> n 0)
 595             (progn
 596               (gnus-summary-set-agent-mark
 597                (gnus-summary-article-number) unmark)
 598               (zerop (gnus-summary-next-subject (if backward -1 1) nil t))))
 599       (setq n (1- n)))
 600     (when (/= 0 n)
 601       (gnus-message 7 "No more articles"))
 602     (gnus-summary-recenter)
 603     (gnus-summary-position-point)
 604     n))
 605
 606 (defun gnus-agent-unmark-article (n)
 607   "Remove the downloadable mark from the next N articles.
 608 If N is negative, unmark backward instead.  The difference between N and
 609 the actual number of articles unmarked is returned."
 610   (interactive "p")
 611   (gnus-agent-mark-article n t))
 612
 613 (defun gnus-agent-toggle-mark (n)
 614   "Toggle the downloadable mark from the next N articles.
 615 If N is negative, toggle backward instead.  The difference between N and
 616 the actual number of articles toggled is returned."
 617   (interactive "p")
 618   (gnus-agent-mark-article n 'toggle))
 619
 620 (defun gnus-summary-set-agent-mark (article &optional unmark)
 621   "Mark ARTICLE as downloadable."
 622   (let ((unmark (if (and (not (null unmark)) (not (eq t unmark)))
 623                     (memq article gnus-newsgroup-downloadable)
 624                   unmark)))
 625     (if unmark
 626         (progn
 627           (setq gnus-newsgroup-downloadable
 628                 (delq article gnus-newsgroup-downloadable))
 629           (push article gnus-newsgroup-undownloaded))
 630       (setq gnus-newsgroup-undownloaded
 631             (delq article gnus-newsgroup-undownloaded))
 632       (push article gnus-newsgroup-downloadable))
 633     (gnus-summary-update-mark
 634      (if unmark gnus-undownloaded-mark gnus-downloadable-mark)
 635      'unread)))
 636
 637 (defun gnus-agent-get-undownloaded-list ()
 638   "Mark all unfetched articles as read."
 639   (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name)))
 640     (when (and (not gnus-plugged)
 641                (gnus-agent-method-p gnus-command-method))
 642       (gnus-agent-load-alist gnus-newsgroup-name)
 643       ;; First mark all undownloaded articles as undownloaded.
 644       (let ((articles (append gnus-newsgroup-unreads
 645                               gnus-newsgroup-marked
 646                               gnus-newsgroup-dormant))
 647             article)
 648         (while (setq article (pop articles))
 649           (unless (or (cdr (assq article gnus-agent-article-alist))
 650                       (memq article gnus-newsgroup-downloadable)
 651                       (memq article gnus-newsgroup-cached))
 652             (push article gnus-newsgroup-undownloaded))))
 653       ;; Then mark downloaded downloadable as not-downloadable,
 654       ;; if you get my drift.
 655       (let ((articles gnus-newsgroup-downloadable)
 656             article)
 657         (while (setq article (pop articles))
 658           (when (cdr (assq article gnus-agent-article-alist))
 659             (setq gnus-newsgroup-downloadable
 660                   (delq article gnus-newsgroup-downloadable))))))))
 661
 662 (defun gnus-agent-catchup ()
 663   "Mark all undownloaded articles as read."
 664   (interactive)
 665   (save-excursion
 666     (while gnus-newsgroup-undownloaded
 667       (gnus-summary-mark-article
 668        (pop gnus-newsgroup-undownloaded) gnus-catchup-mark)))
 669   (gnus-summary-position-point))
 670
 671 ;;;
 672 ;;; Internal functions
 673 ;;;
 674
 675 (defun gnus-agent-save-active (method)
 676   (gnus-agent-save-active-1 method 'gnus-active-to-gnus-format))
 677
 678 (defun gnus-agent-save-active-1 (method function)
 679   (when (gnus-agent-method-p method)
 680     (let* ((gnus-command-method method)
 681            (new (gnus-make-hashtable (count-lines (point-min) (point-max))))
 682            (file (gnus-agent-lib-file "active")))
 683       (funcall function nil new)
 684       (gnus-agent-write-active file new)
 685       (erase-buffer)
 686       (nnheader-insert-file-contents file))))
 687
 688 (defun gnus-agent-write-active (file new)
 689   (let ((orig (gnus-make-hashtable (count-lines (point-min) (point-max))))
 690         (file (gnus-agent-lib-file "active"))
 691         elem osym)
 692     (when (file-exists-p file)
 693       (with-temp-buffer
 694         (nnheader-insert-file-contents file)
 695         (gnus-active-to-gnus-format nil orig))
 696       (mapatoms
 697        (lambda (sym)
 698          (when (and sym (boundp sym))
 699            (if (and (boundp (setq osym (intern (symbol-name sym) orig)))
 700                     (setq elem (symbol-value osym)))
 701                (setcdr elem (cdr (symbol-value sym)))
 702              (set (intern (symbol-name sym) orig) (symbol-value sym)))))
 703        new))
 704     (gnus-make-directory (file-name-directory file))
 705     (let ((coding-system-for-write gnus-agent-file-coding-system))
 706       ;; The hashtable contains real names of groups,  no more prefix
 707       ;; removing, so set `full' to `t'.
 708       (gnus-write-active-file file orig t))))
 709
 710 (defun gnus-agent-save-groups (method)
 711   (gnus-agent-save-active-1 method 'gnus-groups-to-gnus-format))
 712
 713 (defun gnus-agent-save-group-info (method group active)
 714   (when (gnus-agent-method-p method)
 715     (let* ((gnus-command-method method)
 716            (coding-system-for-write nnheader-file-coding-system)
 717            (file-name-coding-system nnmail-pathname-coding-system)
 718            (file (gnus-agent-lib-file "active"))
 719            oactive)
 720       (gnus-make-directory (file-name-directory file))
 721       (with-temp-file file
 722         ;; Emacs got problem to match non-ASCII group in multibyte buffer.
 723         (mm-disable-multibyte)
 724         (when (file-exists-p file)
 725           (nnheader-insert-file-contents file))
 726         (goto-char (point-min))
 727         (when (re-search-forward
 728                (concat "^" (regexp-quote group) " ") nil t)
 729           (save-excursion
 730             (save-restriction
 731               (narrow-to-region (match-beginning 0)
 732                                 (progn
 733                                   (forward-line 1)
 734                                   (point)))
 735               (setq oactive (car (nnmail-parse-active)))))
 736           (gnus-delete-line))
 737         (insert (format "%S %d %d y\n" (intern group)
 738                         (cdr active)
 739                         (or (car oactive) (car active))))
 740         (goto-char (point-max))
 741         (while (search-backward "\\." nil t)
 742           (delete-char 1))))))
 743
 744 (defun gnus-agent-group-path (group)
 745   "Translate GROUP into a path."
 746   (if nnmail-use-long-file-names
 747       (gnus-group-real-name group)
 748     (nnheader-translate-file-chars
 749      (nnheader-replace-chars-in-string
 750       (nnheader-replace-duplicate-chars-in-string
 751        (nnheader-replace-chars-in-string
 752         (gnus-group-real-name group)
 753         ?/ ?_)
 754        ?. ?_)
 755       ?. ?/))))
 756
 757 \f
 758
 759 (defun gnus-agent-method-p (method)
 760   "Say whether METHOD is covered by the agent."
 761   (member method gnus-agent-covered-methods))
 762
 763 (defun gnus-agent-get-function (method)
 764   (if (and (not gnus-plugged)
 765            (gnus-agent-method-p method))
 766       (progn
 767         (require 'nnagent)
 768         'nnagent)
 769     (car method)))
 770
 771 ;;; History functions
 772
 773 (defun gnus-agent-history-buffer ()
 774   (cdr (assoc (gnus-agent-method) gnus-agent-history-buffers)))
 775
 776 (defun gnus-agent-open-history ()
 777   (save-excursion
 778     (push (cons (gnus-agent-method)
 779                 (set-buffer (gnus-get-buffer-create
 780                              (format " *Gnus agent %s history*"
 781                                      (gnus-agent-method)))))
 782           gnus-agent-history-buffers)
 783     (mm-disable-multibyte) ;; everything is binary
 784     (erase-buffer)
 785     (insert "\n")
 786     (let ((file (gnus-agent-lib-file "history")))
 787       (when (file-exists-p file)
 788         (nnheader-insert-file-contents file))
 789       (set (make-local-variable 'gnus-agent-file-name) file))))
 790
 791 (defun gnus-agent-save-history ()
 792   (save-excursion
 793     (set-buffer gnus-agent-current-history)
 794     (gnus-make-directory (file-name-directory gnus-agent-file-name))
 795     (let ((coding-system-for-write gnus-agent-file-coding-system))
 796       (write-region (1+ (point-min)) (point-max)
 797                     gnus-agent-file-name nil 'silent))))
 798
 799 (defun gnus-agent-close-history ()
 800   (when (gnus-buffer-live-p gnus-agent-current-history)
 801     (kill-buffer gnus-agent-current-history)
 802     (setq gnus-agent-history-buffers
 803           (delq (assoc (gnus-agent-method) gnus-agent-history-buffers)
 804                &