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, 2005,
   4 ;;   2006, 2007, 2008, 2009, 2010  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 3 of the License, or
  12 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;;; Code:
  25
  26 (require 'gnus)
  27 (require 'gnus-cache)
  28 (require 'nnmail)
  29 (require 'nnvirtual)
  30 (require 'gnus-sum)
  31 (require 'gnus-score)
  32 (require 'gnus-srvr)
  33 (require 'gnus-util)
  34 (eval-when-compile
  35   (if (featurep 'xemacs)
  36       (require 'itimer)
  37     (require 'timer))
  38   (require 'cl))
  39
  40 (autoload 'gnus-server-update-server "gnus-srvr")
  41 (autoload 'gnus-agent-customize-category "gnus-cus")
  42
  43 (defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/")
  44   "Where the Gnus agent will store its files."
  45   :group 'gnus-agent
  46   :type 'directory)
  47
  48 (defcustom gnus-agent-plugged-hook nil
  49   "Hook run when plugging into the network."
  50   :group 'gnus-agent
  51   :type 'hook)
  52
  53 (defcustom gnus-agent-unplugged-hook nil
  54   "Hook run when unplugging from the network."
  55   :group 'gnus-agent
  56   :type 'hook)
  57
  58 (defcustom gnus-agent-fetched-hook nil
  59   "Hook run when finished fetching articles."
  60   :version "22.1"
  61   :group 'gnus-agent
  62   :type 'hook)
  63
  64 (defcustom gnus-agent-handle-level gnus-level-subscribed
  65   "Groups on levels higher than this variable will be ignored by the Agent."
  66   :group 'gnus-agent
  67   :type 'integer)
  68
  69 (defcustom gnus-agent-expire-days 7
  70   "Read articles older than this will be expired.
  71 If you wish to disable Agent expiring, see `gnus-agent-enable-expiration'."
  72   :group 'gnus-agent
  73   :type '(number :tag "days"))
  74
  75 (defcustom gnus-agent-expire-all nil
  76   "If non-nil, also expire unread, ticked and dormant articles.
  77 If nil, only read articles will be expired."
  78   :group 'gnus-agent
  79   :type 'boolean)
  80
  81 (defcustom gnus-agent-group-mode-hook nil
  82   "Hook run in Agent group 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-group-mode-hook 'gnus-xmas-agent-group-menu-add))
  89
  90 (defcustom gnus-agent-summary-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-summary-mode-hook 'gnus-xmas-agent-summary-menu-add))
  98
  99 (defcustom gnus-agent-server-mode-hook nil
 100   "Hook run in Agent summary minor modes."
 101   :group 'gnus-agent
 102   :type 'hook)
 103
 104 ;; Extracted from gnus-xmas-redefine in order to preserve user settings
 105 (when (featurep 'xemacs)
 106   (add-hook 'gnus-agent-server-mode-hook 'gnus-xmas-agent-server-menu-add))
 107
 108 (defcustom gnus-agent-confirmation-function 'y-or-n-p
 109   "Function to confirm when error happens."
 110   :version "21.1"
 111   :group 'gnus-agent
 112   :type 'function)
 113
 114 (defcustom gnus-agent-synchronize-flags nil
 115   "Indicate if flags are synchronized when you plug in.
 116 If this is `ask' the hook will query the user."
 117   ;; If the default switches to something else than nil, then the function
 118   ;; should be fixed not be exceedingly slow.  See 2005-09-20 ChangeLog entry.
 119   :version "21.1"
 120   :type '(choice (const :tag "Always" t)
 121                  (const :tag "Never" nil)
 122                  (const :tag "Ask" ask))
 123   :group 'gnus-agent)
 124
 125 (defcustom gnus-agent-go-online 'ask
 126   "Indicate if offline servers go online when you plug in.
 127 If this is `ask' the hook will query the user."
 128   :version "21.3"
 129   :type '(choice (const :tag "Always" t)
 130                  (const :tag "Never" nil)
 131                  (const :tag "Ask" ask))
 132   :group 'gnus-agent)
 133
 134 (defcustom gnus-agent-mark-unread-after-downloaded t
 135   "Indicate whether to mark articles unread after downloaded."
 136   :version "21.1"
 137   :type 'boolean
 138   :group 'gnus-agent)
 139
 140 (defcustom gnus-agent-download-marks '(download)
 141   "Marks for downloading."
 142   :version "21.1"
 143   :type '(repeat (symbol :tag "Mark"))
 144   :group 'gnus-agent)
 145
 146 (defcustom gnus-agent-consider-all-articles nil
 147   "When non-nil, the agent will let the agent predicate decide
 148 whether articles need to be downloaded or not, for all articles.  When
 149 nil, the default, the agent will only let the predicate decide
 150 whether unread articles are downloaded or not.  If you enable this,
 151 groups with large active ranges may open slower and you may also want
 152 to look into the agent expiry settings to block the expiration of
 153 read articles as they would just be downloaded again."
 154   :version "22.1"
 155   :type 'boolean
 156   :group 'gnus-agent)
 157
 158 (defcustom gnus-agent-max-fetch-size 10000000 ;; 10 Mb
 159   "Chunk size for `gnus-agent-fetch-session'.
 160 The function will split its article fetches into chunks smaller than
 161 this limit."
 162   :version "22.1"
 163   :group 'gnus-agent
 164   :type 'integer)
 165
 166 (defcustom gnus-agent-enable-expiration 'ENABLE
 167   "The default expiration state for each group.
 168 When set to ENABLE, the default, `gnus-agent-expire' will expire old
 169 contents from a group's local storage.  This value may be overridden
 170 to disable expiration in specific categories, topics, and groups.  Of
 171 course, you could change gnus-agent-enable-expiration to DISABLE then
 172 enable expiration per categories, topics, and groups."
 173   :version "22.1"
 174   :group 'gnus-agent
 175   :type '(radio (const :format "Enable " ENABLE)
 176                 (const :format "Disable " DISABLE)))
 177
 178 (defcustom gnus-agent-expire-unagentized-dirs t
 179   "*Whether expiration should expire in unagentized directories.
 180 Have gnus-agent-expire scan the directories under
 181 \(gnus-agent-directory) for groups that are no longer agentized.
 182 When found, offer to remove them."
 183   :version "22.1"
 184   :type 'boolean
 185   :group 'gnus-agent)
 186
 187 (defcustom gnus-agent-auto-agentize-methods nil
 188   "Initially, all servers from these methods are agentized.
 189 The user may remove or add servers using the Server buffer.
 190 See Info node `(gnus)Server Buffer'."
 191   :version "22.1"
 192   :type '(repeat symbol)
 193   :group 'gnus-agent)
 194
 195 (defcustom gnus-agent-queue-mail t
 196   "Whether and when outgoing mail should be queued by the agent.
 197 When `always', always queue outgoing mail.  When nil, never
 198 queue.  Otherwise, queue if and only if unplugged."
 199   :version "22.1"
 200   :group 'gnus-agent
 201   :type '(radio (const :format "Always" always)
 202                 (const :format "Never" nil)
 203                 (const :format "When unplugged" t)))
 204
 205 (defcustom gnus-agent-prompt-send-queue nil
 206   "If non-nil, `gnus-group-send-queue' will prompt if called when
 207 unplugged."
 208   :version "22.1"
 209   :group 'gnus-agent
 210   :type 'boolean)
 211
 212 (defcustom gnus-agent-article-alist-save-format 1
 213   "Indicates whether to use compression(2), versus no
 214 compression(1), when writing agentview files.  The compressed
 215 files do save space but load times are 6-7 times higher.  A group
 216 must be opened then closed for the agentview to be updated using
 217 the new format."
 218   ;; Wouldn't symbols instead numbers be nicer?  --rsteib
 219   :version "22.1"
 220   :group 'gnus-agent
 221   :type '(radio (const :format "Compressed" 2)
 222                 (const :format "Uncompressed" 1)))
 223
 224 ;;; Internal variables
 225
 226 (defvar gnus-agent-history-buffers nil)
 227 (defvar gnus-agent-buffer-alist nil)
 228 (defvar gnus-agent-article-alist nil
 229   "An assoc list identifying the articles whose headers have been fetched.
 230 If successfully fetched, these headers will be stored in the group's overview
 231 file.  The key of each assoc pair is the article ID, the value of each assoc
 232 pair is a flag indicating whether the identified article has been downloaded
 233 \(gnus-agent-fetch-articles sets the value to the day of the download).
 234 NOTES:
 235 1) The last element of this list can not be expired as some
 236    routines (for example, get-agent-fetch-headers) use the last
 237    value to track which articles have had their headers retrieved.
 238 2) The function `gnus-agent-regenerate' may destructively modify the value.")
 239 (defvar gnus-agent-group-alist nil)
 240 (defvar gnus-category-alist nil)
 241 (defvar gnus-agent-current-history nil)
 242 (defvar gnus-agent-overview-buffer nil)
 243 (defvar gnus-category-predicate-cache nil)
 244 (defvar gnus-category-group-cache nil)
 245 (defvar gnus-agent-spam-hashtb nil)
 246 (defvar gnus-agent-file-name nil)
 247 (defvar gnus-agent-send-mail-function nil)
 248 (defvar gnus-agent-file-coding-system 'raw-text)
 249 (defvar gnus-agent-file-loading-cache nil)
 250 (defvar gnus-agent-total-fetched-hashtb nil)
 251 (defvar gnus-agent-inhibit-update-total-fetched-for nil)
 252 (defvar gnus-agent-need-update-total-fetched-for nil)
 253
 254 ;; Dynamic variables
 255 (defvar gnus-headers)
 256 (defvar gnus-score)
 257
 258 ;; Added to support XEmacs
 259 (eval-and-compile
 260   (unless (fboundp 'directory-files-and-attributes)
 261     (defun directory-files-and-attributes (directory
 262                                            &optional full match nosort)
 263       (let (result)
 264         (dolist (file (directory-files directory full match nosort))
 265           (push (cons file (file-attributes file)) result))
 266         (nreverse result)))))
 267
 268 ;;;
 269 ;;; Setup
 270 ;;;
 271
 272 (defun gnus-open-agent ()
 273   (setq gnus-agent t)
 274   (gnus-agent-read-servers)
 275   (gnus-category-read)
 276   (gnus-agent-create-buffer)
 277   (add-hook 'gnus-group-mode-hook 'gnus-agent-mode)
 278   (add-hook 'gnus-summary-mode-hook 'gnus-agent-mode)
 279   (add-hook 'gnus-server-mode-hook 'gnus-agent-mode))
 280
 281 (defun gnus-agent-create-buffer ()
 282   (if (gnus-buffer-live-p gnus-agent-overview-buffer)
 283       t
 284     (setq gnus-agent-overview-buffer
 285           (gnus-get-buffer-create " *Gnus agent overview*"))
 286     (with-current-buffer gnus-agent-overview-buffer
 287       (mm-enable-multibyte))
 288     nil))
 289
 290 (gnus-add-shutdown 'gnus-close-agent 'gnus)
 291
 292 (defun gnus-close-agent ()
 293   (setq gnus-category-predicate-cache nil
 294         gnus-category-group-cache nil
 295         gnus-agent-spam-hashtb nil)
 296   (gnus-kill-buffer gnus-agent-overview-buffer))
 297
 298 ;;;
 299 ;;; Utility functions
 300 ;;;
 301
 302 (defmacro gnus-agent-with-refreshed-group (group &rest body)
 303   "Performs the body then updates the group's line in the group
 304 buffer.  Automatically blocks multiple updates due to recursion."
 305 `(prog1 (let ((gnus-agent-inhibit-update-total-fetched-for t)) ,@body)
 306      (when (and gnus-agent-need-update-total-fetched-for
 307                 (not gnus-agent-inhibit-update-total-fetched-for))
 308         (with-current-buffer gnus-group-buffer
 309           (setq gnus-agent-need-update-total-fetched-for nil)
 310           (gnus-group-update-group ,group t)))))
 311
 312 (defun gnus-agent-read-file (file)
 313   "Load FILE and do a `read' there."
 314   (with-temp-buffer
 315     (ignore-errors
 316       (nnheader-insert-file-contents file)
 317       (goto-char (point-min))
 318       (read (current-buffer)))))
 319
 320 (defsubst gnus-agent-method ()
 321   (concat (symbol-name (car gnus-command-method)) "/"
 322           (if (equal (cadr gnus-command-method) "")
 323               "unnamed"
 324             (cadr gnus-command-method))))
 325
 326 (defsubst gnus-agent-directory ()
 327   "The name of the Gnus agent directory."
 328   (nnheader-concat gnus-agent-directory
 329                    (nnheader-translate-file-chars (gnus-agent-method)) "/"))
 330
 331 (defun gnus-agent-lib-file (file)
 332   "The full name of the Gnus agent library FILE."
 333   (expand-file-name file
 334                     (file-name-as-directory
 335                      (expand-file-name "agent.lib" (gnus-agent-directory)))))
 336
 337 (defun gnus-agent-cat-set-property (category property value)
 338   (if value
 339       (setcdr (or (assq property category)
 340               (let ((cell (cons property nil)))
 341                     (setcdr category (cons cell (cdr category)))
 342                     cell)) value)
 343     (let ((category category))
 344       (while (cond ((eq property (caadr category))
 345                     (setcdr category (cddr category))
 346                     nil)
 347                    (t
 348                     (setq category (cdr category)))))))
 349   category)
 350
 351 (eval-when-compile
 352   (defmacro gnus-agent-cat-defaccessor (name prop-name)
 353     "Define accessor and setter methods for manipulating a list of the form
 354 \(NAME (PROPERTY1 VALUE1) ... (PROPERTY_N VALUE_N)).
 355 Given the call (gnus-agent-cat-defaccessor func PROPERTY1), the list may be
 356 manipulated as follows:
 357   (func LIST): Returns VALUE1
 358   (setf (func LIST) NEW_VALUE1): Replaces VALUE1 with NEW_VALUE1."
 359     `(progn (defmacro ,name (category)
 360               (list (quote cdr) (list (quote assq)
 361                                       (quote (quote ,prop-name)) category)))
 362
 363             (define-setf-method ,name (category)
 364               (let* ((--category--temp-- (make-symbol "--category--"))
 365                      (--value--temp-- (make-symbol "--value--")))
 366                 (list (list --category--temp--) ; temporary-variables
 367                       (list category)           ; value-forms
 368                       (list --value--temp--)    ; store-variables
 369                       (let* ((category --category--temp--) ; store-form
 370                              (value --value--temp--))
 371                         (list (quote gnus-agent-cat-set-property)
 372                               category
 373                               (quote (quote ,prop-name))
 374                               value))
 375                       (list (quote ,name) --category--temp--) ; access-form
 376                       )))))
 377   )
 378
 379 (defmacro gnus-agent-cat-name (category)
 380   `(car ,category))
 381
 382 (gnus-agent-cat-defaccessor
 383  gnus-agent-cat-days-until-old             agent-days-until-old)
 384 (gnus-agent-cat-defaccessor
 385  gnus-agent-cat-enable-expiration          agent-enable-expiration)
 386 (gnus-agent-cat-defaccessor
 387  gnus-agent-cat-groups                     agent-groups)
 388 (gnus-agent-cat-defaccessor
 389  gnus-agent-cat-high-score                 agent-high-score)
 390 (gnus-agent-cat-defaccessor
 391  gnus-agent-cat-length-when-long           agent-long-article)
 392 (gnus-agent-cat-defaccessor
 393  gnus-agent-cat-length-when-short          agent-short-article)
 394 (gnus-agent-cat-defaccessor
 395  gnus-agent-cat-low-score                  agent-low-score)
 396 (gnus-agent-cat-defaccessor
 397  gnus-agent-cat-predicate                  agent-predicate)
 398 (gnus-agent-cat-defaccessor
 399  gnus-agent-cat-score-file                 agent-score)
 400 (gnus-agent-cat-defaccessor
 401  gnus-agent-cat-enable-undownloaded-faces  agent-enable-undownloaded-faces)
 402
 403
 404 ;; This form is equivalent to defsetf except that it calls make-symbol
 405 ;; whereas defsetf calls gensym (Using gensym creates a run-time
 406 ;; dependency on the CL library).
 407
 408 (eval-and-compile
 409   (define-setf-method gnus-agent-cat-groups (category)
 410     (let* ((--category--temp-- (make-symbol "--category--"))
 411            (--groups--temp-- (make-symbol "--groups--")))
 412       (list (list --category--temp--)
 413             (list category)
 414             (list --groups--temp--)
 415             (let* ((category --category--temp--)
 416                    (groups --groups--temp--))
 417               (list (quote gnus-agent-set-cat-groups) category groups))
 418             (list (quote gnus-agent-cat-groups) --category--temp--))))
 419   )
 420
 421 (defun gnus-agent-set-cat-groups (category groups)
 422   (unless (eq groups 'ignore)
 423     (let ((new-g groups)
 424           (old-g (gnus-agent-cat-groups category)))
 425       (cond ((eq new-g old-g)
 426              ;; gnus-agent-add-group is fiddling with the group
 427              ;; list. Still, Im done.
 428              nil
 429              )
 430             ((eq new-g (cdr old-g))
 431              ;; gnus-agent-add-group is fiddling with the group list
 432              (setcdr (or (assq 'agent-groups category)
 433                          (let ((cell (cons 'agent-groups nil)))
 434                            (setcdr category (cons cell (cdr category)))
 435                            cell)) new-g))
 436             (t
 437              (let ((groups groups))
 438                (while groups
 439                  (let* ((group        (pop groups))
 440                         (old-category (gnus-group-category group)))
 441                    (if (eq category old-category)
 442                        nil
 443                      (setf (gnus-agent-cat-groups old-category)
 444                            (delete group (gnus-agent-cat-groups
 445                                           old-category))))))
 446                ;; Purge cache as preceeding loop invalidated it.
 447                (setq gnus-category-group-cache nil))
 448
 449              (setcdr (or (assq 'agent-groups category)
 450                          (let ((cell (cons 'agent-groups nil)))
 451                            (setcdr category (cons cell (cdr category)))
 452                            cell)) groups))))))
 453
 454 (defsubst gnus-agent-cat-make (name &optional default-agent-predicate)
 455   (list name `(agent-predicate . ,(or default-agent-predicate 'false))))
 456
 457 (defun gnus-agent-read-group ()
 458   "Read a group name in the minibuffer, with completion."
 459   (let ((def (or (gnus-group-group-name) gnus-newsgroup-name)))
 460     (when def
 461       (setq def (gnus-group-decoded-name def)))
 462     (gnus-group-completing-read nil nil t nil nil def)))
 463
 464 ;;; Fetching setup functions.
 465
 466 (defun gnus-agent-start-fetch ()
 467   "Initialize data structures for efficient fetching."
 468   (gnus-agent-create-buffer))
 469
 470 (defun gnus-agent-stop-fetch ()
 471   "Save all data structures and clean up."
 472   (setq gnus-agent-spam-hashtb nil)
 473   (with-current-buffer nntp-server-buffer
 474     (widen)))
 475
 476 (defmacro gnus-agent-with-fetch (&rest forms)
 477   "Do FORMS safely."
 478   `(unwind-protect
 479        (let ((gnus-agent-fetching t))
 480          (gnus-agent-start-fetch)
 481          ,@forms)
 482      (gnus-agent-stop-fetch)))
 483
 484 (put 'gnus-agent-with-fetch 'lisp-indent-function 0)
 485 (put 'gnus-agent-with-fetch 'edebug-form-spec '(body))
 486
 487 (defmacro gnus-agent-append-to-list (tail value)
 488   `(setq ,tail (setcdr ,tail (cons ,value nil))))
 489
 490 (defmacro gnus-agent-message (level &rest args)
 491   `(if (<= ,level gnus-verbose)
 492        (message ,@args)))
 493
 494 ;;;
 495 ;;; Mode infestation
 496 ;;;
 497
 498 (defvar gnus-agent-mode-hook nil
 499   "Hook run when installing agent mode.")
 500
 501 (defvar gnus-agent-mode nil)
 502 (defvar gnus-agent-mode-status '(gnus-agent-mode " Plugged"))
 503
 504 (defun gnus-agent-mode ()
 505   "Minor mode for providing a agent support in Gnus buffers."
 506   (let* ((buffer (progn (string-match "^gnus-\\(.*\\)-mode$"
 507                                       (symbol-name major-mode))
 508                         (match-string 1 (symbol-name major-mode))))
 509          (mode (intern (format "gnus-agent-%s-mode" buffer))))
 510     (set (make-local-variable 'gnus-agent-mode) t)
 511     (set mode nil)
 512     (set (make-local-variable mode) t)
 513     ;; Set up the menu.
 514     (when (gnus-visual-p 'agent-menu 'menu)
 515       (funcall (intern (format "gnus-agent-%s-make-menu-bar" buffer))))
 516     (unless (assq mode minor-mode-alist)
 517       (push (cons mode (cdr gnus-agent-mode-status)) minor-mode-alist))
 518     (unless (assq mode minor-mode-map-alist)
 519       (push (cons mode (symbol-value (intern (format "gnus-agent-%s-mode-map"
 520                                                      buffer))))
 521             minor-mode-map-alist))
 522     (when (eq major-mode 'gnus-group-mode)
 523       (let ((init-plugged gnus-plugged)
 524             (gnus-agent-go-online nil))
 525         ;; g-a-t-p does nothing when gnus-plugged isn't changed.
 526         ;; Therefore, make certain that the current value does not
 527         ;; match the desired initial value.
 528         (setq gnus-plugged :unknown)
 529         (gnus-agent-toggle-plugged init-plugged)))
 530     (gnus-run-hooks 'gnus-agent-mode-hook
 531                     (intern (format "gnus-agent-%s-mode-hook" buffer)))))
 532
 533 (defvar gnus-agent-group-mode-map (make-sparse-keymap))
 534 (gnus-define-keys gnus-agent-group-mode-map
 535   "Ju" gnus-agent-fetch-groups
 536   "Jc" gnus-enter-category-buffer
 537   "Jj" gnus-agent-toggle-plugged
 538   "Js" gnus-agent-fetch-session
 539