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

   1 ;;; gnus-agent.el --- unplugged support for Gnus
   2
   3 ;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005 Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  22 ;; Boston, MA 02110-1301, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (require 'gnus)
  29 (require 'gnus-cache)
  30 (require 'nnmail)
  31 (require 'nnvirtual)
  32 (require 'gnus-sum)
  33 (require 'gnus-score)
  34 (require 'gnus-srvr)
  35 (require 'gnus-util)
  36 (eval-when-compile
  37   (if (featurep 'xemacs)
  38       (require 'itimer)
  39     (require 'timer))
  40   (require 'cl))
  41
  42 (eval-and-compile
  43   (autoload 'gnus-server-update-server "gnus-srvr")
  44   (autoload 'gnus-agent-customize-category "gnus-cus")
  45 )
  46
  47 (defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/")
  48   "Where the Gnus agent will store its files."
  49   :group 'gnus-agent
  50   :type 'directory)
  51
  52 (defcustom gnus-agent-plugged-hook nil
  53   "Hook run when plugging into the network."
  54   :group 'gnus-agent
  55   :type 'hook)
  56
  57 (defcustom gnus-agent-unplugged-hook nil
  58   "Hook run when unplugging from the network."
  59   :group 'gnus-agent
  60   :type 'hook)
  61
  62 (defcustom gnus-agent-fetched-hook nil
  63   "Hook run when finished fetching articles."
  64   :version "22.1"
  65   :group 'gnus-agent
  66   :type 'hook)
  67
  68 (defcustom gnus-agent-handle-level gnus-level-subscribed
  69   "Groups on levels higher than this variable will be ignored by the Agent."
  70   :group 'gnus-agent
  71   :type 'integer)
  72
  73 (defcustom gnus-agent-expire-days 7
  74   "Read articles older than this will be expired.
  75 If you wish to disable Agent expiring, see `gnus-agent-enable-expiration'."
  76   :group 'gnus-agent
  77   :type '(number :tag "days"))
  78
  79 (defcustom gnus-agent-expire-all nil
  80   "If non-nil, also expire unread, ticked and dormant articles.
  81 If nil, only read articles will be expired."
  82   :group 'gnus-agent
  83   :type 'boolean)
  84
  85 (defcustom gnus-agent-group-mode-hook nil
  86   "Hook run in Agent group minor modes."
  87   :group 'gnus-agent
  88   :type 'hook)
  89
  90 ;; Extracted from gnus-xmas-redefine in order to preserve user settings
  91 (when (featurep 'xemacs)
  92   (add-hook 'gnus-agent-group-mode-hook 'gnus-xmas-agent-group-menu-add))
  93
  94 (defcustom gnus-agent-summary-mode-hook nil
  95   "Hook run in Agent summary minor modes."
  96   :group 'gnus-agent
  97   :type 'hook)
  98
  99 ;; Extracted from gnus-xmas-redefine in order to preserve user settings
 100 (when (featurep 'xemacs)
 101   (add-hook 'gnus-agent-summary-mode-hook 'gnus-xmas-agent-summary-menu-add))
 102
 103 (defcustom gnus-agent-server-mode-hook nil
 104   "Hook run in Agent summary minor modes."
 105   :group 'gnus-agent
 106   :type 'hook)
 107
 108 ;; Extracted from gnus-xmas-redefine in order to preserve user settings
 109 (when (featurep 'xemacs)
 110   (add-hook 'gnus-agent-server-mode-hook 'gnus-xmas-agent-server-menu-add))
 111
 112 (defcustom gnus-agent-confirmation-function 'y-or-n-p
 113   "Function to confirm when error happens."
 114   :version "21.1"
 115   :group 'gnus-agent
 116   :type 'function)
 117
 118 (defcustom gnus-agent-synchronize-flags nil
 119   "Indicate if flags are synchronized when you plug in.
 120 If this is `ask' the hook will query the user."
 121   ;; If the default switches to something else than nil, then the function
 122   ;; should be fixed not be exceedingly slow.  See 2005-09-20 ChangeLog entry.
 123   :version "21.1"
 124   :type '(choice (const :tag "Always" t)
 125                  (const :tag "Never" nil)
 126                  (const :tag "Ask" ask))
 127   :group 'gnus-agent)
 128
 129 (defcustom gnus-agent-go-online 'ask
 130   "Indicate if offline servers go online when you plug in.
 131 If this is `ask' the hook will query the user."
 132   :version "21.3"
 133   :type '(choice (const :tag "Always" t)
 134                  (const :tag "Never" nil)
 135                  (const :tag "Ask" ask))
 136   :group 'gnus-agent)
 137
 138 (defcustom gnus-agent-mark-unread-after-downloaded t
 139   "Indicate whether to mark articles unread after downloaded."
 140   :version "21.1"
 141   :type 'boolean
 142   :group 'gnus-agent)
 143
 144 (defcustom gnus-agent-download-marks '(download)
 145   "Marks for downloading."
 146   :version "21.1"
 147   :type '(repeat (symbol :tag "Mark"))
 148   :group 'gnus-agent)
 149
 150 (defcustom gnus-agent-consider-all-articles nil
 151   "When non-nil, the agent will let the agent predicate decide
 152 whether articles need to be downloaded or not, for all articles.  When
 153 nil, the default, the agent will only let the predicate decide
 154 whether unread articles are downloaded or not.  If you enable this,
 155 groups with large active ranges may open slower and you may also want
 156 to look into the agent expiry settings to block the expiration of
 157 read articles as they would just be downloaded again."
 158   :version "22.1"
 159   :type 'boolean
 160   :group 'gnus-agent)
 161
 162 (defcustom gnus-agent-max-fetch-size 10000000 ;; 10 Mb
 163   "Chunk size for `gnus-agent-fetch-session'.
 164 The function will split its article fetches into chunks smaller than
 165 this limit."
 166   :version "22.1"
 167   :group 'gnus-agent
 168   :type 'integer)
 169
 170 (defcustom gnus-agent-enable-expiration 'ENABLE
 171   "The default expiration state for each group.
 172 When set to ENABLE, the default, `gnus-agent-expire' will expire old
 173 contents from a group's local storage.  This value may be overridden
 174 to disable expiration in specific categories, topics, and groups.  Of
 175 course, you could change gnus-agent-enable-expiration to DISABLE then
 176 enable expiration per categories, topics, and groups."
 177   :version "22.1"
 178   :group 'gnus-agent
 179   :type '(radio (const :format "Enable " ENABLE)
 180                 (const :format "Disable " DISABLE)))
 181
 182 (defcustom gnus-agent-expire-unagentized-dirs t
 183   "*Whether expiration should expire in unagentized directories.
 184 Have gnus-agent-expire scan the directories under
 185 \(gnus-agent-directory) for groups that are no longer agentized.
 186 When found, offer to remove them."
 187   :version "22.1"
 188   :type 'boolean
 189   :group 'gnus-agent)
 190
 191 (defcustom gnus-agent-auto-agentize-methods '(nntp nnimap)
 192   "Initially, all servers from these methods are agentized.
 193 The user may remove or add servers using the Server buffer.
 194 See Info node `(gnus)Server Buffer'."
 195   :version "22.1"
 196   :type '(repeat symbol)
 197   :group 'gnus-agent)
 198
 199 (defcustom gnus-agent-queue-mail t
 200   "Whether and when outgoing mail should be queued by the agent.
 201 When `always', always queue outgoing mail.  When nil, never
 202 queue.  Otherwise, queue if and only if unplugged."
 203   :version "22.1"
 204   :group 'gnus-agent
 205   :type '(radio (const :format "Always" always)
 206                 (const :format "Never" nil)
 207                 (const :format "When plugged" t)))
 208
 209 (defcustom gnus-agent-prompt-send-queue nil
 210   "If non-nil, `gnus-group-send-queue' will prompt if called when
 211 unplugged."
 212   :version "22.1"
 213   :group 'gnus-agent
 214   :type 'boolean)
 215
 216 (defcustom gnus-agent-article-alist-save-format 1
 217   "Indicates whether to use compression(2), verses no
 218   compression(1), when writing agentview files.  The compressed
 219   files do save space but load times are 6-7 times higher.  A
 220   group must be opened then closed for the agentview to be
 221   updated using the new format."
 222   :version "22.1"
 223   :group 'gnus-agent
 224   :type '(radio (const :format "Compressed" 2)
 225                 (const :format "Uncompressed" 1)))
 226
 227 ;;; Internal variables
 228
 229 (defvar gnus-agent-history-buffers nil)
 230 (defvar gnus-agent-buffer-alist nil)
 231 (defvar gnus-agent-article-alist nil
 232   "An assoc list identifying the articles whose headers have been fetched.
 233 If successfully fetched, these headers will be stored in the group's overview
 234 file.  The key of each assoc pair is the article ID, the value of each assoc
 235 pair is a flag indicating whether the identified article has been downloaded
 236 \(gnus-agent-fetch-articles sets the value to the day of the download).
 237 NOTES:
 238 1) The last element of this list can not be expired as some
 239    routines (for example, get-agent-fetch-headers) use the last
 240    value to track which articles have had their headers retrieved.
 241 2) The function `gnus-agent-regenerate' may destructively modify the value.")
 242 (defvar gnus-agent-group-alist nil)
 243 (defvar gnus-category-alist nil)
 244 (defvar gnus-agent-current-history nil)
 245 (defvar gnus-agent-overview-buffer nil)
 246 (defvar gnus-category-predicate-cache nil)
 247 (defvar gnus-category-group-cache nil)
 248 (defvar gnus-agent-spam-hashtb nil)
 249 (defvar gnus-agent-file-name nil)
 250 (defvar gnus-agent-send-mail-function nil)
 251 (defvar gnus-agent-file-coding-system 'raw-text)
 252 (defvar gnus-agent-file-loading-cache nil)
 253 (defvar gnus-agent-total-fetched-hashtb nil)
 254 (defvar gnus-agent-inhibit-update-total-fetched-for nil)
 255 (defvar gnus-agent-need-update-total-fetched-for nil)
 256
 257 ;; Dynamic variables
 258 (defvar gnus-headers)
 259 (defvar gnus-score)
 260
 261 ;;;
 262 ;;; Setup
 263 ;;;
 264
 265 (defun gnus-open-agent ()
 266   (setq gnus-agent t)
 267   (gnus-agent-read-servers)
 268   (gnus-category-read)
 269   (gnus-agent-create-buffer)
 270   (add-hook 'gnus-group-mode-hook 'gnus-agent-mode)
 271   (add-hook 'gnus-summary-mode-hook 'gnus-agent-mode)
 272   (add-hook 'gnus-server-mode-hook 'gnus-agent-mode))
 273
 274 (defun gnus-agent-create-buffer ()
 275   (if (gnus-buffer-live-p gnus-agent-overview-buffer)
 276       t
 277     (setq gnus-agent-overview-buffer
 278           (gnus-get-buffer-create " *Gnus agent overview*"))
 279     (with-current-buffer gnus-agent-overview-buffer
 280       (mm-enable-multibyte))
 281     nil))
 282
 283 (gnus-add-shutdown 'gnus-close-agent 'gnus)
 284
 285 (defun gnus-close-agent ()
 286   (setq gnus-category-predicate-cache nil
 287         gnus-category-group-cache nil
 288         gnus-agent-spam-hashtb nil)
 289   (gnus-kill-buffer gnus-agent-overview-buffer))
 290
 291 ;;;
 292 ;;; Utility functions
 293 ;;;
 294
 295 (defmacro gnus-agent-with-refreshed-group (group &rest body)
 296   "Performs the body then updates the group's line in the group
 297 buffer.  Automatically blocks multiple updates due to recursion."
 298 `(prog1 (let ((gnus-agent-inhibit-update-total-fetched-for t)) ,@body)
 299      (when (and gnus-agent-need-update-total-fetched-for
 300                 (not gnus-agent-inhibit-update-total-fetched-for))
 301         (save-excursion
 302           (set-buffer gnus-group-buffer)
 303           (setq gnus-agent-need-update-total-fetched-for nil)
 304           (gnus-group-update-group ,group t)))))
 305
 306 (defun gnus-agent-read-file (file)
 307   "Load FILE and do a `read' there."
 308   (with-temp-buffer
 309     (ignore-errors
 310       (nnheader-insert-file-contents file)
 311       (goto-char (point-min))
 312       (read (current-buffer)))))
 313
 314 (defsubst gnus-agent-method ()
 315   (concat (symbol-name (car gnus-command-method)) "/"
 316           (if (equal (cadr gnus-command-method) "")
 317               "unnamed"
 318             (cadr gnus-command-method))))
 319
 320 (defsubst gnus-agent-directory ()
 321   "The name of the Gnus agent directory."
 322   (nnheader-concat gnus-agent-directory
 323                    (nnheader-translate-file-chars (gnus-agent-method)) "/"))
 324
 325 (defun gnus-agent-lib-file (file)
 326   "The full name of the Gnus agent library FILE."
 327   (expand-file-name file
 328                     (file-name-as-directory
 329                      (expand-file-name "agent.lib" (gnus-agent-directory)))))
 330
 331 (defun gnus-agent-cat-set-property (category property value)
 332   (if value
 333       (setcdr (or (assq property category)
 334               (let ((cell (cons property nil)))
 335                     (setcdr category (cons cell (cdr category)))
 336                     cell)) value)
 337     (let ((category category))
 338       (while (cond ((eq property (caadr category))
 339                     (setcdr category (cddr category))
 340                     nil)
 341                    (t
 342                     (setq category (cdr category)))))))
 343   category)
 344
 345 (eval-when-compile
 346   (defmacro gnus-agent-cat-defaccessor (name prop-name)
 347     "Define accessor and setter methods for manipulating a list of the form
 348 \(NAME (PROPERTY1 VALUE1) ... (PROPERTY_N VALUE_N)).
 349 Given the call (gnus-agent-cat-defaccessor func PROPERTY1), the list may be
 350 manipulated as follows:
 351   (func LIST): Returns VALUE1
 352   (setf (func LIST) NEW_VALUE1): Replaces VALUE1 with NEW_VALUE1."
 353     `(progn (defmacro ,name (category)
 354               (list (quote cdr) (list (quote assq)
 355                                       (quote (quote ,prop-name)) category)))
 356
 357             (define-setf-method ,name (category)
 358               (let* ((--category--temp-- (make-symbol "--category--"))
 359                      (--value--temp-- (make-symbol "--value--")))
 360                 (list (list --category--temp--) ; temporary-variables
 361                       (list category)           ; value-forms
 362                       (list --value--temp--)    ; store-variables
 363                       (let* ((category --category--temp--) ; store-form
 364                              (value --value--temp--))
 365                         (list (quote gnus-agent-cat-set-property)
 366                               category
 367                               (quote (quote ,prop-name))
 368                               value))
 369                       (list (quote ,name) --category--temp--) ; access-form
 370                       )))))
 371   )
 372
 373 (defmacro gnus-agent-cat-name (category)
 374   `(car ,category))
 375
 376 (gnus-agent-cat-defaccessor
 377  gnus-agent-cat-days-until-old             agent-days-until-old)
 378 (gnus-agent-cat-defaccessor
 379  gnus-agent-cat-enable-expiration          agent-enable-expiration)
 380 (gnus-agent-cat-defaccessor
 381  gnus-agent-cat-groups                     agent-groups)
 382 (gnus-agent-cat-defaccessor
 383  gnus-agent-cat-high-score                 agent-high-score)
 384 (gnus-agent-cat-defaccessor
 385  gnus-agent-cat-length-when-long           agent-long-article)
 386 (gnus-agent-cat-defaccessor
 387  gnus-agent-cat-length-when-short          agent-short-article)
 388 (gnus-agent-cat-defaccessor
 389  gnus-agent-cat-low-score                  agent-low-score)
 390 (gnus-agent-cat-defaccessor
 391  gnus-agent-cat-predicate                  agent-predicate)
 392 (gnus-agent-cat-defaccessor
 393  gnus-agent-cat-score-file                 agent-score)
 394 (gnus-agent-cat-defaccessor
 395  gnus-agent-cat-enable-undownloaded-faces  agent-enable-undownloaded-faces)
 396
 397
 398 ;; This form is equivalent to defsetf except that it calls make-symbol
 399 ;; whereas defsetf calls gensym (Using gensym creates a run-time
 400 ;; dependency on the CL library).
 401
 402 (eval-and-compile
 403   (define-setf-method gnus-agent-cat-groups (category)
 404     (let* ((--category--temp-- (make-symbol "--category--"))
 405            (--groups--temp-- (make-symbol "--groups--")))
 406       (list (list --category--temp--)
 407             (list category)
 408             (list --groups--temp--)
 409             (let* ((category --category--temp--)
 410                    (groups --groups--temp--))
 411               (list (quote gnus-agent-set-cat-groups) category groups))
 412             (list (quote gnus-agent-cat-groups) --category--temp--))))
 413   )
 414
 415 (defun gnus-agent-set-cat-groups (category groups)
 416   (unless (eq groups 'ignore)
 417     (let ((new-g groups)
 418           (old-g (gnus-agent-cat-groups category)))
 419       (cond ((eq new-g old-g)
 420              ;; gnus-agent-add-group is fiddling with the group
 421              ;; list. Still, Im done.
 422              nil
 423              )
 424             ((eq new-g (cdr old-g))
 425              ;; gnus-agent-add-group is fiddling with the group list
 426              (setcdr (or (assq 'agent-groups category)
 427                          (let ((cell (cons 'agent-groups nil)))
 428                            (setcdr category (cons cell (cdr category)))
 429                            cell)) new-g))
 430             (t
 431              (let ((groups groups))
 432                (while groups
 433                  (let* ((group        (pop groups))
 434                         (old-category (gnus-group-category group)))
 435                    (if (eq category old-category)
 436                        nil
 437                      (setf (gnus-agent-cat-groups old-category)
 438                            (delete group (gnus-agent-cat-groups
 439                                           old-category))))))
 440                ;; Purge cache as preceeding loop invalidated it.
 441                (setq gnus-category-group-cache nil))
 442
 443              (setcdr (or (assq 'agent-groups category)
 444                          (let ((cell (cons 'agent-groups nil)))
 445                            (setcdr category (cons cell (cdr category)))
 446                            cell)) groups))))))
 447
 448 (defsubst gnus-agent-cat-make (name &optional default-agent-predicate)
 449   (list name `(agent-predicate . ,(or default-agent-predicate 'false))))
 450
 451 ;;; Fetching setup functions.
 452
 453 (defun gnus-agent-start-fetch ()
 454   "Initialize data structures for efficient fetching."
 455   (gnus-agent-create-buffer))
 456
 457 (defun gnus-agent-stop-fetch ()
 458   "Save all data structures and clean up."
 459   (setq gnus-agent-spam-hashtb nil)
 460   (save-excursion
 461     (set-buffer nntp-server-buffer)
 462     (widen)))
 463
 464 (defmacro gnus-agent-with-fetch (&rest forms)
 465   "Do FORMS safely."
 466   `(unwind-protect
 467        (let ((gnus-agent-fetching t))
 468          (gnus-agent-start-fetch)
 469          ,@forms)
 470      (gnus-agent-stop-fetch)))
 471
 472 (put 'gnus-agent-with-fetch 'lisp-indent-function 0)
 473 (put 'gnus-agent-with-fetch 'edebug-form-spec '(body))
 474
 475 (defmacro gnus-agent-append-to-list (tail value)
 476   `(setq ,tail (setcdr ,tail (cons ,value nil))))
 477
 478 (defmacro gnus-agent-message (level &rest args)
 479   `(if (<= ,level gnus-verbose)
 480        (message ,@args)))
 481
 482 ;;;
 483 ;;; Mode infestation
 484 ;;;
 485
 486 (defvar gnus-agent-mode-hook nil
 487   "Hook run when installing agent mode.")
 488
 489 (defvar gnus-agent-mode nil)
 490 (defvar gnus-agent-mode-status '(gnus-agent-mode " Plugged"))
 491
 492 (defun gnus-agent-mode ()
 493   "Minor mode for providing a agent support in Gnus buffers."
 494   (let* ((buffer (progn (string-match "^gnus-\\(.*\\)-mode$"
 495                                       (symbol-name major-mode))
 496                         (match-string 1 (symbol-name major-mode))))
 497          (mode (intern (format "gnus-agent-%s-mode" buffer))))
 498     (set (make-local-variable 'gnus-agent-mode) t)
 499     (set mode nil)
 500     (set (make-local-variable mode) t)
 501     ;; Set up the menu.
 502     (when (gnus-visual-p 'agent-menu 'menu)
 503       (funcall (intern (format "gnus-agent-%s-make-menu-bar" buffer))))
 504     (unless (assq 'gnus-agent-mode minor-mode-alist)
 505       (push gnus-agent-mode-status minor-mode-alist))
 506     (unless (assq mode minor-mode-map-alist)
 507       (push (cons mode (symbol-value (intern (format "gnus-agent-%s-mode-map"
 508                                                      buffer))))
 509             minor-mode-map-alist))
 510     (when (eq major-mode 'gnus-group-mode)
 511       (let ((init-plugged gnus-plugged)
 512             (gnus-agent-go-online nil))
 513         ;; g-a-t-p does nothing when gnus-plugged isn't changed.
 514         ;; Therefore, make certain that the current value does not
 515         ;; match the desired initial value.
 516         (setq gnus-plugged :unknown)
 517         (gnus-agent-toggle-plugged init-plugged)))
 518     (gnus-run-hooks 'gnus-agent-mode-hook
 519                     (intern (format "gnus-agent-%s-mode-hook" buffer)))))
 520
 521 (defvar gnus-agent-group-mode-map (make-sparse-keymap))
 522 (gnus-define-keys gnus-agent-group-mode-map
 523   "Ju" gnus-agent-fetch-groups
 524   "Jc" gnus-enter-category-buffer
 525   "Jj" gnus-agent-toggle-plugged
 526   "Js" gnus-agent-fetch-session
 527   "JY" gnus-agent-synchronize-flags
 528   "JS" gnus-group-send-queue
 529   "Ja" gnus-agent-add-group
 530   "Jr" gnus-agent-remove-group
 531   "Jo" gnus-agent-toggle-group-plugged)
 532
 533 (defun gnus-agent-group-make-menu-bar ()
 534   (unless (boundp 'gnus-agent-group-menu)
 535     (easy-menu-define
 536      gnus-agent-group-menu gnus-agent-group-mode-map ""
 537      '("Agent"
 538        ["Toggle plugged" gnus-agent-toggle-plugged t]
 539        ["Toggle group plugged" gnus-agent-toggle-group-plugged t]
 540        ["List categories" gnus-enter-category-buffer t]
 541        ["Add (current) group to category" gnus-agent-add-group t]
 542        ["Remove (current) group from category" gnus-agent-remove-group t]
 543        ["Send queue" gnus-group-send-queue gnus-plugged]
 544        ("Fetch"
 545         ["All" gnus-agent-fetch-session gnus-plugged]
 546         ["Group" gnus-agent-fetch-group gnus-plugged])
 547        ["Synchronize flags" gnus-agent-synchronize-flags t]
 548        ))))
 549
 550 (defvar gnus-agent-summary-mode-map (make-sparse-keymap))
 551 (gnus-define-keys gnus-agent-summary-mode-map
 552   "Jj" gnus-agent-toggle-plugged
 553   "Ju" gnus-agent-summary-fetch-group
 554   "JS" gnus-agent-fetch-group
 555   "Js" gnus-agent-summary-fetch-series
 556   "J#" gnus-agent-mark-article
 557   "J\M-#" gnus-agent-unmark-article
 558   "@" gnus-agent-toggle-mark
 559   "Jc" gnus-agent-catchup)
 560
 561 (defun gnus-agent-summary-make-menu-bar ()
 562   (unless (boundp 'gnus-agent-summary-menu)
 563     (easy-menu-define
 564      gnus-agent-summary-menu gnus-agent-summary-mode-map ""
 565      '("Agent"
 566        ["Toggle plugged" gnus-agent-toggle-plugged t]
 567        ["Mark as downloadable" gnus-agent-mark-article t]
 568        ["Unmark as downloadable" gnus-agent-unmark-article t]
 569        ["Toggle mark" gnus-agent-toggle-mark t]
 570        ["Fetch downloadable" gnus-agent-summary-fetch-group t]
 571        ["Catchup undownloaded" gnus-agent-catchup t]))))
 572
 573 (defvar gnus-agent-server-mode-map (make-sparse-keymap))
 574 (gnus-define-keys gnus-agent-server-mode-map
 575   "Jj" gnus-agent-toggle-plugged
 576   "Ja" gnus-agent-add-server
 577   "Jr" gnus-agent-remove-server)
 578
 579 (defun gnus-agent-server-make-menu-bar ()
 580   (unless (boundp 'gnus-agent-server-menu)
 581     (easy-menu-define
 582      gnus-agent-server-menu gnus-agent-server-mode-map ""
 583      '("Agent"
 584        ["Toggle plugged" gnus-agent-toggle-plugged t]
 585        ["Add" gnus-agent-add-server t]
 586        ["Remove" gnus-agent-remove-server t]))))
 587
 588 (defun gnus-agent-make-mode-line-string (string mouse-button mouse-func)
 589   (if (and (fboundp 'propertize)
 590            (fboundp 'make-mode-line-mouse-map))
 591       (propertize string 'local-map
 592                   (make-mode-line-mouse-map mouse-button mouse-func)
 593                   'mouse-face 'mode-line-highlight)
 594     string))
 595
 596 (defun gnus-agent-toggle-plugged (set-to)
 597   "Toggle whether Gnus is unplugged or not."
 598   (interactive (list (not gnus-plugged)))
 599   (cond ((eq set-to gnus-plugged)
 600          nil)
 601         (set-to
 602          (setq gnus-plugged set-to)
 603          (gnus-run-hooks 'gnus-agent-plugged-hook)
 604          (setcar (cdr gnus-agent-mode-status)
 605                  (gnus-agent-make-mode-line-string " Plugged"
 606                                                    'mouse-2
 607                                                    'gnus-agent-toggle-plugged))
 608          (gnus-agent-go-online gnus-agent-go-online)
 609          (gnus-agent-possibly-synchronize-flags))
 610         (t
 611          (gnus-agent-close-connections)
 612          (setq gnus-plugged set-to)
 613          (gnus-run-hooks 'gnus-agent-unplugged-hook)
 614          (setcar (cdr gnus-agent-mode-status)
 615                  (gnus-agent-make-mode-line-string " Unplugged"
 616                                                    'mouse-2
 617                                                    'gnus-agent-toggle-plugged))))
 618   (set-buffer-modified-p t))
 619
 620 (defmacro gnus-agent-while-plugged (&rest body)
 621   `(let ((original-gnus-plugged gnus-plugged))
 622     (unwind-protect
 623         (progn (gnus-agent-toggle-plugged t)
 624                ,@body)
 625       (gnus-agent-toggle-plugged original-gnus-plugged))))
 626
 627 (put 'gnus-agent-while-plugged 'lisp-indent-function 0)
 628 (put 'gnus-agent-while-plugged 'edebug-form-spec '(body))
 629
 630 (defun gnus-agent-close-connections ()
 631   "Close all methods covered by the Gnus agent."
 632   (let ((methods (gnus-agent-covered-methods)))
 633     (while methods
 634       (gnus-close-server (pop methods)))))
 635
 636 ;;;###autoload
 637 (defun gnus-unplugged ()
 638   "Start Gnus unplugged."
 639   (interactive)
 640   (setq gnus-plugged nil)
 641   (gnus))
 642
 643 ;;;###autoload
 644 (defun gnus-plugged ()
 645   "Start Gnus plugged."
 646   (interactive)
 647   (setq gnus-plugged t)
 648   (gnus))
 649
 650 ;;;###autoload
 651 (defun gnus-slave-unplugged (&optional arg)
 652   "Read news as a slave unplugged."
 653   (interactive "P")
 654   (setq gnus-plugged nil)
 655   (gnus arg nil 'slave))
 656
 657 ;;;###autoload
 658 (defun gnus-agentize ()
 659   "Allow Gnus to be an offline newsreader.
 660
 661 The gnus-agentize function is now called internally by gnus when
 662 gnus-agent is set.  If you wish to avoid calling gnus-agentize,
 663 customize gnus-agent to nil.
 664
 665 This will modify the `gnus-setup-news-hook', and
 666 `message-send-mail-real-function' variables, and install the Gnus agent
 667 minor mode in all Gnus buffers."
 668   (interactive)
 669   (gnus-open-agent)
 670   (add-hook 'gnus-setup-news-hook 'gnus-agent-queue-setup)
 671   (unless gnus-agent-send-mail-function
 672     (setq gnus-agent-send-mail-function
 673           (or message-send-mail-real-function
 674               (function (lambda () (funcall message-send-mail-function))))
 675           message-send-mail-real-function 'gnus-agent-send-mail))
 676
 677   ;; If the servers file doesn't exist, auto-agentize some servers and
 678   ;; save the servers file so this auto-agentizing isn't invoked
 679   ;; again.
 680   (unless (file-exists-p (nnheader-concat gnus-agent-directory "lib/servers"))
 681     (gnus-message 3 "First time agent user, agentizing remote groups...")
 682     (mapc
 683      (lambda (server-or-method)
 684        (let ((method (gnus-server-to-method server-or-method)))
 685          (when (memq (car method)
 686                      gnus-agent-auto-agentize-methods)
 687            (push (gnus-method-to-server method)
 688                  gnus-agent-covered-methods)
 689            (setq gnus-agent-method-p-cache nil))))
 690      (cons gnus-select-method gnus-secondary-select-methods))
 691     (gnus-agent-write-servers)))
 692
 693 (defun gnus-agent-queue-setup (&optional group-name)
 694   "Make sure the queue group exists.
 695 Optional arg GROUP-NAME allows to specify another group."
 696   (unless (gnus-gethash (format "nndraft:%s" (or group-name "queue"))
 697                         gnus-newsrc-hashtb)
 698     (gnus-request-create-group (or group-name "queue") '(nndraft ""))
 699     (let ((gnus-level-default-subscribed 1))
 700       (gnus-subscribe-group (format "nndraft:%s" (or group-name "queue"))
 701                             nil '(nndraft "")))
 702     (gnus-group-set-parameter
 703      (format "nndraft:%s" (or group-name "queue"))
 704      'gnus-dummy '((gnus-draft-mode)))))
 705
 706 (defun gnus-agent-send-mail ()
 707   (if (or (not gnus-agent-queue-mail)
 708           (and gnus-plugged (not (eq gnus-agent-queue-mail 'always))))
 709       (funcall gnus-agent-send-mail-function)
 710     (goto-char (point-min))
 711     (re-search-forward
 712      (concat "^" (regexp-quote mail-header-separator) "\n"))
 713     (replace-match "\n")
 714     (gnus-agent-insert-meta-information 'mail)
 715     (gnus-request-accept-article "nndraft:queue" nil t t)))
 716
 717 (defun gnus-agent-insert-meta-information (type &optional method)
 718   "Insert meta-information into the message that says how it's to be posted.
 719 TYPE can be either `mail' or `news'.  If the latter, then METHOD can
 720 be a select method."
 721   (save-excursion
 722     (message-remove-header gnus-agent-meta-information-header)
 723     (goto-char (point-min))
 724     (insert gnus-agent-meta-information-header ": "
 725             (symbol-name type) " " (format "%S" method)
 726             "\n")
 727     (forward-char -1)
 728     (while (search-backward "\n" nil t)
 729       (replace-match "\\n" t t))))
 730
 731 (defun gnus-agent-restore-gcc ()
 732   "Restore GCC field from saved header."
 733   (save-excursion
 734     (goto-char (point-min))
 735     (while (re-search-forward
 736             (concat "^" (regexp-quote gnus-agent-gcc-header) ":") nil t)
 737       (replace-match "Gcc:" 'fixedcase))))
 738
 739 (defun gnus-agent-any-covered-gcc ()
 740   (save-restriction
 741     (message-narrow-to-headers)
 742     (let* ((gcc (mail-fetch-field "gcc" nil t))
 743            (methods (and gcc
 744                          (mapcar 'gnus-inews-group-method
 745                                  (message-unquote-tokens
 746                                   (message-tokenize-header
 747                                    gcc " ,")))))
 748            covered)
 749       (while (and (not covered) methods)
 750         (setq covered (gnus-agent-method-p (car methods))
 751               methods (cdr methods)))
 752       covered)))
 753
 754 ;;;###autoload
 755 (defun gnus-agent-possibly-save-gcc ()
 756   "Save GCC if Gnus is unplugged."
 757   (when (and (not gnus-plugged) (gnus-agent-any-covered-gcc))
 758     (save-excursion
 759       (goto-char (point-min))
 760       (let ((case-fold-search t))
 761         (while (re-search-forward "^gcc:" nil t)
 762           (replace-match (concat gnus-agent-gcc-header ":") 'fixedcase))))))
 763
 764 (defun gnus-agent-possibly-do-gcc ()
 765   "Do GCC if Gnus is plugged."
 766   (when (or gnus-plugged (not (gnus-agent-any-covered-gcc)))
 767     (gnus-inews-do-gcc)))
 768
 769 ;;;
 770 ;;; Group mode commands
 771 ;;;
 772
 773 (defun gnus-agent-fetch-groups (n)
 774   "Put all new articles in the current groups into the Agent."
 775   (interactive "P")
 776   (unless gnus-plugged
 777     (error "Groups can't be fetched when Gnus is unplugged"))
 778   (gnus-group-iterate n 'gnus-agent-fetch-group))
 779
 780 (defun gnus-agent-fetch-group (&optional group)
 781   "Put all new articles in GROUP into the Agent."
 782   (interactive (list (gnus-group-group-name)))
 783   (setq group (or group gnus-newsgroup-name))
 784   (unless group
 785     (error "No group on the current line"))
 786
 787   (gnus-agent-while-plugged
 788     (let ((gnus-command-method (gnus-find-method-for-group group)))
 789       (gnus-agent-with-fetch
 790         (gnus-agent-fetch-group-1 group gnus-command-method)
 791         (gnus-message 5 "Fetching %s...done" group)))))
 792
 793 (defun gnus-agent-add-group (category arg)
 794   "Add the current group to an agent category."
 795   (interactive
 796    (list
 797     (intern
 798      (completing-read
 799       "Add to category: "
 800       (mapcar (lambda (cat) (list (symbol-name (car cat))))
 801               gnus-category-alist)
 802       nil t))
 803     current-prefix-arg))
 804   (let ((cat (assq category gnus-category-alist))
 805         c groups)
 806     (gnus-group-iterate arg
 807       (lambda (group)
 808         (when (gnus-agent-cat-groups (setq c (gnus-group-category group)))
 809           (setf (gnus-agent-cat-groups c)
 810                 (delete group (gnus-agent-cat-groups c))))
 811         (push group groups)))
 812     (setf (gnus-agent-cat-groups cat)
 813           (nconc (gnus-agent-cat-groups cat) groups))
 814     (gnus-category-write)))
 815
 816 (defun gnus-agent-remove-group (arg)
 817   "Remove the current group from its agent category, if any."
 818   (interactive "P")
 819   (let (c)
 820     (gnus-group-iterate arg
 821       (lambda (group)
 822         (when (gnus-agent-cat-groups (setq c (gnus-group-category group)))
 823           (setf (gnus-agent-cat-groups c)
 824                 (delete group (gnus-agent-cat-groups c))))))
 825     (gnus-category-write)))
 826
 827 (defun gnus-agent-synchronize-flags ()
 828   "Synchronize unplugged flags with servers."
 829   (interactive)
 830   (save-excursion
 831     (dolist (gnus-command-method (gnus-agent-covered-methods))
 832       (when (file-exists-p (gnus-agent-lib-file "flags"))
 833         (gnus-agent-synchronize-flags-server gnus-command-method)))))
 834
 835 (defun gnus-agent-possibly-synchronize-flags ()
 836   "Synchronize flags according to `gnus-agent-synchronize-flags'."
 837   (interactive)
 838   (save-excursion
 839     (dolist (gnus-command-method (gnus-agent-covered-methods))
 840       (when (and (file-exists-p (gnus-agent-lib-file "flags"))
 841                  (eq (gnus-server-status gnus-command-method) 'ok))
 842         (gnus-agent-possibly-synchronize-flags-server gnus-command-method)))))
 843
 844 (defun gnus-agent-synchronize-flags-server (method)
 845   "Synchronize flags set when unplugged for server."
 846   (let ((gnus-command-method method)
 847         (gnus-agent nil))
 848     (when (file-exists-p (gnus-agent-lib-file "flags"))
 849       (set-buffer (get-buffer-create " *Gnus Agent flag synchronize*"))
 850       (erase-buffer)
 851       (nnheader-insert-file-contents (gnus-agent-lib-file "flags"))
 852       (cond ((null gnus-plugged)
 853              (gnus-message
 854               1 "You must be plugged to synchronize flags with server %s"
 855               (nth 1 gnus-command-method)))
 856             ((null (gnus-check-server gnus-command-method))
 857              (gnus-message
 858               1 "Couldn't open server %s" (nth 1 gnus-command-method)))
 859             (t
 860              (condition-case err
 861                  (while t
 862                    (let ((bgn (point)))
 863                      (eval (read (current-buffer)))
 864                      (delete-region bgn (point))))
 865                (end-of-file
 866                 (delete-file (gnus-agent-lib-file "flags")))
 867                (error
 868                 (let ((file (gnus-agent-lib-file "flags")))
 869                   (write-region (point-min) (point-max)
 870                                 (gnus-agent-lib-file "flags") nil 'silent)
 871                   (error "Couldn't set flags from file %s due to %s"
 872                          file (error-message-string err)))))))
 873       (kill-buffer nil))))
 874
 875 (defun gnus-agent-possibly-synchronize-flags-server (method)
 876   "Synchronize flags for server according to `gnus-agent-synchronize-flags'."
 877   (when (or (and gnus-agent-synchronize-flags
 878                  (not (eq gnus-agent-synchronize-flags 'ask)))
 879             (and (eq gnus-agent-synchronize-flags 'ask)
 880                  (gnus-y-or-n-p (format "Synchronize flags on server `%s'? "
 881                                         (cadr method)))))
 882     (gnus-agent-synchronize-flags-server method)))
 883
 884 ;;;###autoload
 885 (defun gnus-agent-rename-group (old-group new-group)
 886   "Rename fully-qualified OLD-GROUP as NEW-GROUP.  Always updates the agent, even when
 887 disabled, as the old agent files would corrupt gnus when the agent was
 888 next enabled. Depends upon the caller to determine whether group renaming is supported."
 889   (let* ((old-command-method (gnus-find-method-for-group old-group))
 890          (old-path           (directory-file-name
 891                               (let (gnus-command-method old-command-method)
 892                                 (gnus-agent-group-pathname old-group))))
 893          (new-command-method (gnus-find-method-for-group new-group))
 894          (new-path           (directory-file-name
 895                               (let (gnus-command-method new-command-method)
 896                                 (gnus-agent-group-pathname new-group)))))
 897     (gnus-rename-file old-path new-path t)
 898
 899     (let* ((old-real-group (gnus-group-real-name old-group))
 900            (new-real-group (gnus-group-real-name new-group))
 901            (old-active (gnus-agent-get-group-info old-command-method old-real-group)))
 902       (gnus-agent-save-group-info old-command-method old-real-group nil)
 903       (gnus-agent-save-group-info new-command-method new-real-group old-active)
 904
 905       (let ((old-local (gnus-agent-get-local old-group
 906                                              old-real-group old-command-method)))
 907         (gnus-agent-set-local old-group
 908                               nil nil
 909                               old-real-group old-command-method)
 910         (gnus-agent-set-local new-group
 911                               (car old-local) (cdr old-local)
 912                               new-real-group new-command-method)))))
 913
 914 ;;;###autoload
 915 (defun gnus-agent-delete-group (group)
 916   "Delete fully-qualified GROUP.  Always updates the agent, even when
 917 disabled, as the old agent files would corrupt gnus when the agent was
 918 next enabled. Depends upon the caller to determine whether group deletion is supported."
 919   (let* ((command-method (gnus-find-method-for-group group))
 920          (path           (directory-file-name
 921                           (let (gnus-command-method command-method)
 922                             (gnus-agent-group-pathname group)))))
 923     (gnus-delete-directory path)
 924
 925     (let* ((real-group (gnus-group-real-name group)))
 926       (gnus-agent-save-group-info command-method real-group nil)
 927
 928       (let ((local (gnus-agent-get-local group
 929                                          real-group command-method)))
 930         (gnus-agent-set-local group
 931                               nil nil
 932                               real-group command-method)))))
 933
 934 ;;;
 935 ;;; Server mode commands
 936 ;;;
 937
 938 (defun gnus-agent-add-server ()
 939   "Enroll SERVER in the agent program."
 940   (interactive)
 941   (let* ((server       (gnus-server-server-name))
 942          (named-server (gnus-server-named-server))
 943          (method       (and server
 944                             (gnus-server-get-method nil server))))
 945     (unless server
 946       (error "No server on the current line"))
 947
 948     (when (gnus-agent-method-p method)
 949       (error "Server already in the agent program"))
 950
 951     (push named-server gnus-agent-covered-methods)
 952
 953     (setq gnus-agent-method-p-cache nil)
 954     (gnus-server-update-server server)
 955     (gnus-agent-write-servers)
 956     (gnus-message 1 "Entered %s into the Agent" server)))
 957
 958 (defun gnus-agent-remove-server ()
 959   "Remove SERVER from the agent program."
 960   (interactive)
 961   (let* ((server       (gnus-server-server-name))
 962          (named-server (gnus-server-named-server)))
 963     (unless server
 964       (error "No server on the current line"))
 965
 966     (unless (member named-server gnus-agent-covered-methods)
 967       (error "Server not in the agent program"))
 968
 969     (setq gnus-agent-covered-methods
 970           (delete named-server gnus-agent-covered-methods)
 971           gnus-agent-method-p-cache nil)
 972
 973     (gnus-server-update-server server)
 974     (gnus-agent-write-servers)
 975     (gnus-message 1 "Removed %s from the agent" server)))
 976
 977 (defun gnus-agent-read-servers ()
 978   "Read the alist of covered servers."
 979   (setq gnus-agent-covered-methods
 980         (gnus-agent-read-file
 981          (nnheader-concat gnus-agent-directory "lib/servers"))
 982         gnus-agent-method-p-cache nil)
 983
 984   ;; I am called so early in start-up that I can not validate server
 985   ;; names.  When that is the case, I skip the validation.  That is
 986   ;; alright as the gnus startup code calls the validate methods
 987   ;; directly.
 988   (if gnus-server-alist
 989       (gnus-agent-read-servers-validate)))
 990
 991 (defun gnus-agent-read-servers-validate ()
 992   (mapcar (lambda (server-or-method)
 993             (let* ((server (if (stringp server-or-method)
 994                                server-or-method
 995                              (gnus-method-to-server server-or-method)))
 996                    (method (gnus-server-to-method server)))
 997               (if method
 998                   (unless (member server gnus-agent-covered-methods)
 999                     (push server gnus-agent-covered-methods)
1000                     (setq gnus-agent-method-p-cache nil))
1001                 (gnus-message 1 "Ignoring disappeared server `%s'" server))))
1002           (prog1 gnus-agent-covered-methods
1003             (setq gnus-agent-covered-methods nil))))
1004
1005 (defun gnus-agent-read-servers-validate-native (native-method)
1006   (setq gnus-agent-covered-methods
1007         (mapcar (lambda (method)
1008                   (if (or (not method)
1009                           (equal method native-method))
1010                       "native"
1011                     method)) gnus-agent-covered-methods)))
1012
1013 (defun gnus-agent-write-servers ()
1014   "Write the alist of covered servers."
1015   (gnus-make-directory (nnheader-concat gnus-agent-directory "lib"))
1016   (let ((coding-system-for-write nnheader-file-coding-system)
1017         (file-name-coding-system nnmail-pathname-coding-system))
1018     (with-temp-file (nnheader-concat gnus-agent-directory "lib/servers")
1019       (prin1 gnus-agent-covered-methods
1020              (current-buffer)))))
1021
1022 ;;;
1023 ;;; Summary commands
1024 ;;;
1025
1026 (defun gnus-agent-mark-article (n &optional unmark)
1027   "Mark the next N articles as downloadable.
1028 If N is negative, mark backward instead.  If UNMARK is non-nil, remove
1029 the mark instead.  The difference between N and the actual number of
1030 articles marked is returned."
1031   (interactive "p")
1032   (let ((backward (< n 0))
1033         (n (abs n)))
1034     (while (and
1035             (> n 0)
1036             (progn
1037               (gnus-summary-set-agent-mark
1038                (gnus-summary-article-number) unmark)
1039               (zerop (gnus-summary-next-subject (if backward -1 1) nil t))))
1040       (setq n (1- n)))
1041     (when (/= 0 n)
1042       (gnus-message 7 "No more articles"))
1043     (gnus-summary-recenter)
1044     (gnus-summary-position-point)
1045     n))
1046
1047 (defun gnus-agent-unmark-article (n)
1048   "Remove the downloadable mark from the next N articles.
1049 If N is negative, unmark backward instead.  The difference between N and
1050 the actual number of articles unmarked is returned."
1051   (interactive "p")
1052   (gnus-agent-mark-article n t))
1053
1054 (defun gnus-agent-toggle-mark (n)
1055   "Toggle the downloadable mark from the next N articles.
1056 If N is negative, toggle backward instead.  The difference between N and
1057 the actual number of articles toggled is returned."
1058   (interactive "p")
1059   (gnus-agent-mark-article n 'toggle))
1060
1061 (defun gnus-summary-set-agent-mark (article &optional unmark)
1062   "Mark ARTICLE as downloadable.  If UNMARK is nil, article is marked.
1063 When UNMARK is t, the article is unmarked.  For any other value, the
1064 article's mark is toggled."
1065   (let ((unmark (cond ((eq nil unmark)
1066                        nil)
1067                       ((eq t unmark)
1068                        t)
1069                       (t
1070                        (memq article gnus-newsgroup-downloadable)))))
1071     (when (gnus-summary-goto-subject article nil t)
1072       (gnus-summary-update-mark
1073        (if unmark
1074            (progn
1075              (setq gnus-newsgroup-downloadable
1076                    (delq article gnus-newsgroup-downloadable))
1077              (gnus-article-mark article))
1078          (setq gnus-newsgroup-downloadable
1079                (gnus-add-to-sorted-list gnus-newsgroup-downloadable article))
1080          gnus-downloadable-mark)
1081        'unread))))
1082
1083 ;;;###autoload
1084 (defun gnus-agent-get-undownloaded-list ()
1085   "Construct list of articles that have not been downloaded."
1086   (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name)))
1087     (when (set (make-local-variable 'gnus-newsgroup-agentized)
1088                (gnus-agent-method-p gnus-command-method))
1089       (let* ((alist (gnus-agent-load-alist gnus-newsgroup-name))
1090              (headers (sort (mapcar (lambda (h)
1091                                       (mail-header-number h))
1092                                     gnus-newsgroup-headers) '<))
1093              (cached (and gnus-use-cache gnus-newsgroup-cached))
1094              (undownloaded (list nil))
1095              (tail-undownloaded undownloaded)
1096              (unfetched (list nil))
1097              (tail-unfetched unfetched))
1098         (while (and alist headers)
1099           (let ((a (caar alist))
1100                 (h (car headers)))
1101             (cond ((< a h)
1102                    ;; Ignore IDs in the alist that are not being
1103                    ;; displayed in the summary.
1104                    (setq alist (cdr alist)))
1105                   ((> a h)
1106                    ;; Headers that are not in the alist should be
1107                    ;; fictious (see nnagent-retrieve-headers); they
1108                    ;; imply that this article isn't in the agent.
1109                    (gnus-agent-append-to-list tail-undownloaded h)
1110                    (gnus-agent-append-to-list tail-unfetched    h)
1111                    (setq headers (cdr headers)))
1112                   ((cdar alist)
1113                    (setq alist (cdr alist))
1114              &nbs