1;;; gnus-agent.el --- unplugged support for Gnus 2 3;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 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. 75If 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. 81If 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 t 119 "Indicate if flags are synchronized when you plug in. 120If 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. 131If 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 152whether articles need to be downloaded or not, for all articles. When 153nil, the default, the agent will only let the predicate decide 154whether unread articles are downloaded or not. If you enable this, 155groups with large active ranges may open slower and you may also want 156to look into the agent expiry settings to block the expiration of 157read 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'. 164The function will split its article fetches into chunks smaller than 165this 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. 172When set to ENABLE, the default, `gnus-agent-expire' will expire old 173contents from a group's local storage. This value may be overridden 174to disable expiration in specific categories, topics, and groups. Of 175course, you could change gnus-agent-enable-expiration to DISABLE then 176enable 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. 184Have gnus-agent-expire scan the directories under 185\(gnus-agent-directory) for groups that are no longer agentized. 186When 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. 193The user may remove or add servers using the Server buffer. 194See 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. 201When `always', always queue outgoing mail. When nil, never 202queue. 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 unplugged" t))) 208 209(defcustom gnus-agent-prompt-send-queue nil 210 "If non-nil, `gnus-group-send-queue' will prompt if called when 211unplugged." 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), versus no 218compression(1), when writing agentview files. The compressed 219files do save space but load times are 6-7 times higher. A group 220must be opened then closed for the agentview to be updated using 221the new format." 222 ;; Wouldn't symbols instead numbers be nicer? --rsteib 223 :version "22.1" 224 :group 'gnus-agent 225 :type '(radio (const :format "Compressed" 2) 226 (const :format "Uncompressed" 1))) 227 228;;; Internal variables 229 230(defvar gnus-agent-history-buffers nil) 231(defvar gnus-agent-buffer-alist nil) 232(defvar gnus-agent-article-alist nil 233 "An assoc list identifying the articles whose headers have been fetched. 234If successfully fetched, these headers will be stored in the group's overview 235file. The key of each assoc pair is the article ID, the value of each assoc 236pair is a flag indicating whether the identified article has been downloaded 237\(gnus-agent-fetch-articles sets the value to the day of the download). 238NOTES: 2391) The last element of this list can not be expired as some 240 routines (for example, get-agent-fetch-headers) use the last 241 value to track which articles have had their headers retrieved. 2422) The function `gnus-agent-regenerate' may destructively modify the value.") 243(defvar gnus-agent-group-alist nil) 244(defvar gnus-category-alist nil) 245(defvar gnus-agent-current-history nil) 246(defvar gnus-agent-overview-buffer nil) 247(defvar gnus-category-predicate-cache nil) 248(defvar gnus-category-group-cache nil) 249(defvar gnus-agent-spam-hashtb nil) 250(defvar gnus-agent-file-name nil) 251(defvar gnus-agent-send-mail-function nil) 252(defvar gnus-agent-file-coding-system 'raw-text) 253(defvar gnus-agent-file-loading-cache nil) 254 255;; Dynamic variables 256(defvar gnus-headers) 257(defvar gnus-score) 258 259;;; 260;;; Setup 261;;; 262 263(defun gnus-open-agent () 264 (setq gnus-agent t) 265 (gnus-agent-read-servers) 266 (gnus-category-read) 267 (gnus-agent-create-buffer) 268 (add-hook 'gnus-group-mode-hook 'gnus-agent-mode) 269 (add-hook 'gnus-summary-mode-hook 'gnus-agent-mode) 270 (add-hook 'gnus-server-mode-hook 'gnus-agent-mode)) 271 272(defun gnus-agent-create-buffer () 273 (if (gnus-buffer-live-p gnus-agent-overview-buffer) 274 t 275 (setq gnus-agent-overview-buffer 276 (gnus-get-buffer-create " *Gnus agent overview*")) 277 (with-current-buffer gnus-agent-overview-buffer 278 (mm-enable-multibyte)) 279 nil)) 280 281(gnus-add-shutdown 'gnus-close-agent 'gnus) 282 283(defun gnus-close-agent () 284 (setq gnus-category-predicate-cache nil 285 gnus-category-group-cache nil 286 gnus-agent-spam-hashtb nil) 287 (gnus-kill-buffer gnus-agent-overview-buffer)) 288 289;;; 290;;; Utility functions 291;;; 292 293(defun gnus-agent-read-file (file) 294 "Load FILE and do a `read' there." 295 (with-temp-buffer 296 (ignore-errors 297 (nnheader-insert-file-contents file) 298 (goto-char (point-min)) 299 (read (current-buffer))))) 300 301(defsubst gnus-agent-method () 302 (concat (symbol-name (car gnus-command-method)) "/" 303 (if (equal (cadr gnus-command-method) "") 304 "unnamed" 305 (cadr gnus-command-method)))) 306 307(defsubst gnus-agent-directory () 308 "The name of the Gnus agent directory." 309 (nnheader-concat gnus-agent-directory 310 (nnheader-translate-file-chars (gnus-agent-method)) "/")) 311 312(defun gnus-agent-lib-file (file) 313 "The full name of the Gnus agent library FILE." 314 (expand-file-name file 315 (file-name-as-directory 316 (expand-file-name "agent.lib" (gnus-agent-directory))))) 317 318(defun gnus-agent-cat-set-property (category property value) 319 (if value 320 (setcdr (or (assq property category) 321 (let ((cell (cons property nil))) 322 (setcdr category (cons cell (cdr category))) 323 cell)) value) 324 (let ((category category)) 325 (while (cond ((eq property (caadr category)) 326 (setcdr category (cddr category)) 327 nil) 328 (t 329 (setq category (cdr category))))))) 330 category) 331 332(eval-when-compile 333 (defmacro gnus-agent-cat-defaccessor (name prop-name) 334 "Define accessor and setter methods for manipulating a list of the form 335\(NAME (PROPERTY1 VALUE1) ... (PROPERTY_N VALUE_N)). 336Given the call (gnus-agent-cat-defaccessor func PROPERTY1), the list may be 337manipulated as follows: 338 (func LIST): Returns VALUE1 339 (setf (func LIST) NEW_VALUE1): Replaces VALUE1 with NEW_VALUE1." 340 `(progn (defmacro ,name (category) 341 (list (quote cdr) (list (quote assq) 342 (quote (quote ,prop-name)) category))) 343 344 (define-setf-method ,name (category) 345 (let* ((--category--temp-- (make-symbol "--category--")) 346 (--value--temp-- (make-symbol "--value--"))) 347 (list (list --category--temp--) ; temporary-variables 348 (list category) ; value-forms 349 (list --value--temp--) ; store-variables 350 (let* ((category --category--temp--) ; store-form 351 (value --value--temp--)) 352 (list (quote gnus-agent-cat-set-property) 353 category 354 (quote (quote ,prop-name)) 355 value)) 356 (list (quote ,name) --category--temp--) ; access-form 357 ))))) 358 ) 359 360(defmacro gnus-agent-cat-name (category) 361 `(car ,category)) 362 363(gnus-agent-cat-defaccessor 364 gnus-agent-cat-days-until-old agent-days-until-old) 365(gnus-agent-cat-defaccessor 366 gnus-agent-cat-enable-expiration agent-enable-expiration) 367(gnus-agent-cat-defaccessor 368 gnus-agent-cat-groups agent-groups) 369(gnus-agent-cat-defaccessor 370 gnus-agent-cat-high-score agent-high-score) 371(gnus-agent-cat-defaccessor 372 gnus-agent-cat-length-when-long agent-long-article) 373(gnus-agent-cat-defaccessor 374 gnus-agent-cat-length-when-short agent-short-article) 375(gnus-agent-cat-defaccessor 376 gnus-agent-cat-low-score agent-low-score) 377(gnus-agent-cat-defaccessor 378 gnus-agent-cat-predicate agent-predicate) 379(gnus-agent-cat-defaccessor 380 gnus-agent-cat-score-file agent-score) 381(gnus-agent-cat-defaccessor 382 gnus-agent-cat-enable-undownloaded-faces agent-enable-undownloaded-faces) 383 384 385;; This form is equivalent to defsetf except that it calls make-symbol 386;; whereas defsetf calls gensym (Using gensym creates a run-time 387;; dependency on the CL library). 388 389(eval-and-compile 390 (define-setf-method gnus-agent-cat-groups (category) 391 (let* ((--category--temp-- (make-symbol "--category--")) 392 (--groups--temp-- (make-symbol "--groups--"))) 393 (list (list --category--temp--) 394 (list category) 395 (list --groups--temp--) 396 (let* ((category --category--temp--) 397 (groups --groups--temp--)) 398 (list (quote gnus-agent-set-cat-groups) category groups)) 399 (list (quote gnus-agent-cat-groups) --category--temp--)))) 400 ) 401 402(defun gnus-agent-set-cat-groups (category groups) 403 (unless (eq groups 'ignore) 404 (let ((new-g groups) 405 (old-g (gnus-agent-cat-groups category))) 406 (cond ((eq new-g old-g) 407 ;; gnus-agent-add-group is fiddling with the group 408 ;; list. Still, Im done. 409 nil 410 ) 411 ((eq new-g (cdr old-g)) 412 ;; gnus-agent-add-group is fiddling with the group list 413 (setcdr (or (assq 'agent-groups category) 414 (let ((cell (cons 'agent-groups nil))) 415 (setcdr category (cons cell (cdr category))) 416 cell)) new-g)) 417 (t 418 (let ((groups groups)) 419 (while groups 420 (let* ((group (pop groups)) 421 (old-category (gnus-group-category group))) 422 (if (eq category old-category) 423 nil 424 (setf (gnus-agent-cat-groups old-category) 425 (delete group (gnus-agent-cat-groups 426 old-category)))))) 427 ;; Purge cache as preceeding loop invalidated it. 428 (setq gnus-category-group-cache nil)) 429 430 (setcdr (or (assq 'agent-groups category) 431 (let ((cell (cons 'agent-groups nil))) 432 (setcdr category (cons cell (cdr category))) 433 cell)) groups)))))) 434 435(defsubst gnus-agent-cat-make (name &optional default-agent-predicate) 436 (list name `(agent-predicate . ,(or default-agent-predicate 'false)))) 437 438;;; Fetching setup functions. 439 440(defun gnus-agent-start-fetch () 441 "Initialize data structures for efficient fetching." 442 (gnus-agent-create-buffer)) 443 444(defun gnus-agent-stop-fetch () 445 "Save all data structures and clean up." 446 (setq gnus-agent-spam-hashtb nil) 447 (save-excursion 448 (set-buffer nntp-server-buffer) 449 (widen))) 450 451(defmacro gnus-agent-with-fetch (&rest forms) 452 "Do FORMS safely." 453 `(unwind-protect 454 (let ((gnus-agent-fetching t)) 455 (gnus-agent-start-fetch) 456 ,@forms) 457 (gnus-agent-stop-fetch))) 458 459(put 'gnus-agent-with-fetch 'lisp-indent-function 0) 460(put 'gnus-agent-with-fetch 'edebug-form-spec '(body)) 461 462(defmacro gnus-agent-append-to-list (tail value) 463 `(setq ,tail (setcdr ,tail (cons ,value nil)))) 464 465(defmacro gnus-agent-message (level &rest args) 466 `(if (<= ,level gnus-verbose) 467 (message ,@args))) 468 469;;; 470;;; Mode infestation 471;;; 472 473(defvar gnus-agent-mode-hook nil 474 "Hook run when installing agent mode.") 475 476(defvar gnus-agent-mode nil) 477(defvar gnus-agent-mode-status '(gnus-agent-mode " Plugged")) 478 479(defun gnus-agent-mode () 480 "Minor mode for providing a agent support in Gnus buffers." 481 (let* ((buffer (progn (string-match "^gnus-\\(.*\\)-mode$" 482 (symbol-name major-mode)) 483 (match-string 1 (symbol-name major-mode)))) 484 (mode (intern (format "gnus-agent-%s-mode" buffer)))) 485 (set (make-local-variable 'gnus-agent-mode) t) 486 (set mode nil) 487 (set (make-local-variable mode) t) 488 ;; Set up the menu. 489 (when (gnus-visual-p 'agent-menu 'menu) 490 (funcall (intern (format "gnus-agent-%s-make-menu-bar" buffer)))) 491 (unless (assq 'gnus-agent-mode minor-mode-alist) 492 (push gnus-agent-mode-status minor-mode-alist)) 493 (unless (assq mode minor-mode-map-alist) 494 (push (cons mode (symbol-value (intern (format "gnus-agent-%s-mode-map" 495 buffer)))) 496 minor-mode-map-alist)) 497 (when (eq major-mode 'gnus-group-mode) 498 (let ((init-plugged gnus-plugged) 499 (gnus-agent-go-online nil)) 500 ;; g-a-t-p does nothing when gnus-plugged isn't changed. 501 ;; Therefore, make certain that the current value does not 502 ;; match the desired initial value. 503 (setq gnus-plugged :unknown) 504 (gnus-agent-toggle-plugged init-plugged))) 505 (gnus-run-hooks 'gnus-agent-mode-hook 506 (intern (format "gnus-agent-%s-mode-hook" buffer))))) 507 508(defvar gnus-agent-group-mode-map (make-sparse-keymap)) 509(gnus-define-keys gnus-agent-group-mode-map 510 "Ju" gnus-agent-fetch-groups 511 "Jc" gnus-enter-category-buffer 512 "Jj" gnus-agent-toggle-plugged 513 "Js" gnus-agent-fetch-session 514 "JY" gnus-agent-synchronize-flags 515 "JS" gnus-group-send-queue 516 "Ja" gnus-agent-add-group 517 "Jr" gnus-agent-remove-group 518 "Jo" gnus-agent-toggle-group-plugged) 519 520(defun gnus-agent-group-make-menu-bar () 521 (unless (boundp 'gnus-agent-group-menu) 522 (easy-menu-define 523 gnus-agent-group-menu gnus-agent-group-mode-map "" 524 '("Agent" 525 ["Toggle plugged" gnus-agent-toggle-plugged t] 526 ["Toggle group plugged" gnus-agent-toggle-group-plugged t] 527 ["List categories" gnus-enter-category-buffer t] 528 ["Add (current) group to category" gnus-agent-add-group t] 529 ["Remove (current) group from category" gnus-agent-remove-group t] 530 ["Send queue" gnus-group-send-queue gnus-plugged] 531 ("Fetch" 532 ["All" gnus-agent-fetch-session gnus-plugged] 533 ["Group" gnus-agent-fetch-group gnus-plugged]) 534 ["Synchronize flags" gnus-agent-synchronize-flags t] 535 )))) 536 537(defvar gnus-agent-summary-mode-map (make-sparse-keymap)) 538(gnus-define-keys gnus-agent-summary-mode-map 539 "Jj" gnus-agent-toggle-plugged 540 "Ju" gnus-agent-summary-fetch-group 541 "JS" gnus-agent-fetch-group 542 "Js" gnus-agent-summary-fetch-series 543 "J#" gnus-agent-mark-article 544 "J\M-#" gnus-agent-unmark-article 545 "@" gnus-agent-toggle-mark 546 "Jc" gnus-agent-catchup) 547 548(defun gnus-agent-summary-make-menu-bar () 549 (unless (boundp 'gnus-agent-summary-menu) 550 (easy-menu-define 551 gnus-agent-summary-menu gnus-agent-summary-mode-map "" 552 '("Agent" 553 ["Toggle plugged" gnus-agent-toggle-plugged t] 554 ["Mark as downloadable" gnus-agent-mark-article t] 555 ["Unmark as downloadable" gnus-agent-unmark-article t] 556 ["Toggle mark" gnus-agent-toggle-mark t] 557 ["Fetch downloadable" gnus-agent-summary-fetch-group t] 558 ["Catchup undownloaded" gnus-agent-catchup t])))) 559 560(defvar gnus-agent-server-mode-map (make-sparse-keymap)) 561(gnus-define-keys gnus-agent-server-mode-map 562 "Jj" gnus-agent-toggle-plugged 563 "Ja" gnus-agent-add-server 564 "Jr" gnus-agent-remove-server) 565 566(defun gnus-agent-server-make-menu-bar () 567 (unless (boundp 'gnus-agent-server-menu) 568 (easy-menu-define 569 gnus-agent-server-menu gnus-agent-server-mode-map "" 570 '("Agent" 571 ["Toggle plugged" gnus-agent-toggle-plugged t] 572 ["Add" gnus-agent-add-server t] 573 ["Remove" gnus-agent-remove-server t])))) 574 575(defun gnus-agent-make-mode-line-string (string mouse-button mouse-func) 576 (if (and (fboundp 'propertize) 577 (fboundp 'make-mode-line-mouse-map)) 578 (propertize string 'local-map 579 (make-mode-line-mouse-map mouse-button mouse-func) 580 'mouse-face 581 (cond ((and (featurep 'xemacs) 582 ;; XEmacs' `facep' only checks for a face 583 ;; object, not for a face name, so it's useless 584 ;; to check with `facep'. 585 (find-face 'modeline)) 586 'modeline) 587 ((facep 'mode-line-highlight) ;; Emacs 22 588 'mode-line-highlight) 589 ((facep 'mode-line) ;; Emacs 21 590 'mode-line)) ) 591 string)) 592 593(defun gnus-agent-toggle-plugged (set-to) 594 "Toggle whether Gnus is unplugged or not." 595 (interactive (list (not gnus-plugged))) 596 (cond ((eq set-to gnus-plugged) 597 nil) 598 (set-to 599 (setq gnus-plugged set-to) 600 (gnus-run-hooks 'gnus-agent-plugged-hook) 601 (setcar (cdr gnus-agent-mode-status) 602 (gnus-agent-make-mode-line-string " Plugged" 603 'mouse-2 604 'gnus-agent-toggle-plugged)) 605 (gnus-agent-go-online gnus-agent-go-online) 606 (gnus-agent-possibly-synchronize-flags)) 607 (t 608 (gnus-agent-close-connections) 609 (setq gnus-plugged set-to) 610 (gnus-run-hooks 'gnus-agent-unplugged-hook) 611 (setcar (cdr gnus-agent-mode-status) 612 (gnus-agent-make-mode-line-string " Unplugged" 613 'mouse-2 614 'gnus-agent-toggle-plugged)))) 615 (set-buffer-modified-p t)) 616 617(defmacro gnus-agent-while-plugged (&rest body) 618 `(let ((original-gnus-plugged gnus-plugged)) 619 (unwind-protect 620 (progn (gnus-agent-toggle-plugged t) 621 ,@body) 622 (gnus-agent-toggle-plugged original-gnus-plugged)))) 623 624(put 'gnus-agent-while-plugged 'lisp-indent-function 0) 625(put 'gnus-agent-while-plugged 'edebug-form-spec '(body)) 626 627(defun gnus-agent-close-connections () 628 "Close all methods covered by the Gnus agent." 629 (let ((methods (gnus-agent-covered-methods))) 630 (while methods 631 (gnus-close-server (pop methods))))) 632 633;;;###autoload 634(defun gnus-unplugged () 635 "Start Gnus unplugged." 636 (interactive) 637 (setq gnus-plugged nil) 638 (gnus)) 639 640;;;###autoload 641(defun gnus-plugged () 642 "Start Gnus plugged." 643 (interactive) 644 (setq gnus-plugged t) 645 (gnus)) 646 647;;;###autoload 648(defun gnus-slave-unplugged (&optional arg) 649 "Read news as a slave unplugged." 650 (interactive "P") 651 (setq gnus-plugged nil) 652 (gnus arg nil 'slave)) 653 654;;;###autoload 655(defun gnus-agentize () 656 "Allow Gnus to be an offline newsreader. 657 658The gnus-agentize function is now called internally by gnus when 659gnus-agent is set. If you wish to avoid calling gnus-agentize, 660customize gnus-agent to nil. 661 662This will modify the `gnus-setup-news-hook', and 663`message-send-mail-real-function' variables, and install the Gnus agent 664minor mode in all Gnus buffers." 665 (interactive) 666 (gnus-open-agent) 667 (add-hook 'gnus-setup-news-hook 'gnus-agent-queue-setup) 668 (unless gnus-agent-send-mail-function 669 (setq gnus-agent-send-mail-function 670 (or message-send-mail-real-function 671 (function (lambda () (funcall message-send-mail-function)))) 672 message-send-mail-real-function 'gnus-agent-send-mail)) 673 674 ;; If the servers file doesn't exist, auto-agentize some servers and 675 ;; save the servers file so this auto-agentizing isn't invoked 676 ;; again. 677 (unless (file-exists-p (nnheader-concat gnus-agent-directory "lib/servers")) 678 (gnus-message 3 "First time agent user, agentizing remote groups...") 679 (mapc 680 (lambda (server-or-method) 681 (let ((method (gnus-server-to-method server-or-method))) 682 (when (memq (car method) 683 gnus-agent-auto-agentize-methods) 684 (push (gnus-method-to-server method) 685 gnus-agent-covered-methods) 686 (setq gnus-agent-method-p-cache nil)))) 687 (cons gnus-select-method gnus-secondary-select-methods)) 688 (gnus-agent-write-servers))) 689 690(defun gnus-agent-queue-setup (&optional group-name) 691 "Make sure the queue group exists. 692Optional arg GROUP-NAME allows to specify another group." 693 (unless (gnus-gethash (format "nndraft:%s" (or group-name "queue")) 694 gnus-newsrc-hashtb) 695 (gnus-request-create-group (or group-name "queue") '(nndraft "")) 696 (let ((gnus-level-default-subscribed 1)) 697 (gnus-subscribe-group (format "nndraft:%s" (or group-name "queue")) 698 nil '(nndraft ""))) 699 (gnus-group-set-parameter 700 (format "nndraft:%s" (or group-name "queue")) 701 'gnus-dummy '((gnus-draft-mode))))) 702 703(defun gnus-agent-send-mail () 704 (if (or (not gnus-agent-queue-mail) 705 (and gnus-plugged (not (eq gnus-agent-queue-mail 'always)))) 706 (funcall gnus-agent-send-mail-function) 707 (goto-char (point-min)) 708 (re-search-forward 709 (concat "^" (regexp-quote mail-header-separator) "\n")) 710 (replace-match "\n") 711 (gnus-agent-insert-meta-information 'mail) 712 (gnus-request-accept-article "nndraft:queue" nil t t))) 713 714(defun gnus-agent-insert-meta-information (type &optional method) 715 "Insert meta-information into the message that says how it's to be posted. 716TYPE can be either `mail' or `news'. If the latter, then METHOD can 717be a select method." 718 (save-excursion 719 (message-remove-header gnus-agent-meta-information-header) 720 (goto-char (point-min)) 721 (insert gnus-agent-meta-information-header ": " 722 (symbol-name type) " " (format "%S" method) 723 "\n") 724 (forward-char -1) 725 (while (search-backward "\n" nil t) 726 (replace-match "\\n" t t)))) 727 728(defun gnus-agent-restore-gcc () 729 "Restore GCC field from saved header." 730 (save-excursion 731 (goto-char (point-min)) 732 (while (re-search-forward 733 (concat "^" (regexp-quote gnus-agent-gcc-header) ":") nil t) 734 (replace-match "Gcc:" 'fixedcase)))) 735 736(defun gnus-agent-any-covered-gcc () 737 (save-restriction 738 (message-narrow-to-headers) 739 (let* ((gcc (mail-fetch-field "gcc" nil t)) 740 (methods (and gcc 741 (mapcar 'gnus-inews-group-method 742 (message-unquote-tokens 743 (message-tokenize-header 744 gcc " ,"))))) 745 covered) 746 (while (and (not covered) methods) 747 (setq covered (gnus-agent-method-p (car methods)) 748 methods (cdr methods))) 749 covered))) 750 751;;;###autoload 752(defun gnus-agent-possibly-save-gcc () 753 "Save GCC if Gnus is unplugged." 754 (when (and (not gnus-plugged) (gnus-agent-any-covered-gcc)) 755 (save-excursion 756 (goto-char (point-min)) 757 (let ((case-fold-search t)) 758 (while (re-search-forward "^gcc:" nil t) 759 (replace-match (concat gnus-agent-gcc-header ":") 'fixedcase)))))) 760 761(defun gnus-agent-possibly-do-gcc () 762 "Do GCC if Gnus is plugged." 763 (when (or gnus-plugged (not (gnus-agent-any-covered-gcc))) 764 (gnus-inews-do-gcc))) 765 766;;; 767;;; Group mode commands 768;;; 769 770(defun gnus-agent-fetch-groups (n) 771 "Put all new articles in the current groups into the Agent." 772 (interactive "P") 773 (unless gnus-plugged 774 (error "Groups can't be fetched when Gnus is unplugged")) 775 (gnus-group-iterate n 'gnus-agent-fetch-group)) 776 777(defun gnus-agent-fetch-group (&optional group) 778 "Put all new articles in GROUP into the Agent." 779 (interactive (list (gnus-group-group-name))) 780 (setq group (or group gnus-newsgroup-name)) 781 (unless group 782 (error "No group on the current line")) 783 784 (gnus-agent-while-plugged 785 (let ((gnus-command-method (gnus-find-method-for-group group))) 786 (gnus-agent-with-fetch 787 (gnus-agent-fetch-group-1 group gnus-command-method) 788 (gnus-message 5 "Fetching %s...done" group))))) 789 790(defun gnus-agent-add-group (category arg) 791 "Add the current group to an agent category." 792 (interactive 793 (list 794 (intern 795 (completing-read 796 "Add to category: " 797 (mapcar (lambda (cat) (list (symbol-name (car cat)))) 798 gnus-category-alist) 799 nil t)) 800 current-prefix-arg)) 801 (let ((cat (assq category gnus-category-alist)) 802 c groups) 803 (gnus-group-iterate arg 804 (lambda (group) 805 (when (gnus-agent-cat-groups (setq c (gnus-group-category group))) 806 (setf (gnus-agent-cat-groups c) 807 (delete group (gnus-agent-cat-groups c)))) 808 (push group groups))) 809 (setf (gnus-agent-cat-groups cat) 810 (nconc (gnus-agent-cat-groups cat) groups)) 811 (gnus-category-write))) 812 813(defun gnus-agent-remove-group (arg) 814 "Remove the current group from its agent category, if any." 815 (interactive "P") 816 (let (c) 817 (gnus-group-iterate arg 818 (lambda (group) 819 (when (gnus-agent-cat-groups (setq c (gnus-group-category group))) 820 (setf (gnus-agent-cat-groups c) 821 (delete group (gnus-agent-cat-groups c)))))) 822 (gnus-category-write))) 823 824(defun gnus-agent-synchronize-flags () 825 "Synchronize unplugged flags with servers." 826 (interactive) 827 (save-excursion 828 (dolist (gnus-command-method (gnus-agent-covered-methods)) 829 (when (file-exists-p (gnus-agent-lib-file "flags")) 830 (gnus-agent-synchronize-flags-server gnus-command-method))))) 831 832(defun gnus-agent-possibly-synchronize-flags () 833 "Synchronize flags according to `gnus-agent-synchronize-flags'." 834 (interactive) 835 (save-excursion 836 (dolist (gnus-command-method (gnus-agent-covered-methods)) 837 (when (and (file-exists-p (gnus-agent-lib-file "flags")) 838 (eq (gnus-server-status gnus-command-method) 'ok)) 839 (gnus-agent-possibly-synchronize-flags-server gnus-command-method))))) 840 841(defun gnus-agent-synchronize-flags-server (method) 842 "Synchronize flags set when unplugged for server." 843 (let ((gnus-command-method method) 844 (gnus-agent nil)) 845 (when (file-exists-p (gnus-agent-lib-file "flags")) 846 (set-buffer (get-buffer-create " *Gnus Agent flag synchronize*")) 847 (erase-buffer) 848 (nnheader-insert-file-contents (gnus-agent-lib-file "flags")) 849 (cond ((null gnus-plugged) 850 (gnus-message 851 1 "You must be plugged to synchronize flags with server %s" 852 (nth 1 gnus-command-method))) 853 ((null (gnus-check-server gnus-command-method)) 854 (gnus-message 855 1 "Couldn't open server %s" (nth 1 gnus-command-method))) 856 (t 857 (condition-case err 858 (while t 859 (let ((bgn (point))) 860 (eval (read (current-buffer))) 861 (delete-region bgn (point)))) 862 (end-of-file 863 (delete-file (gnus-agent-lib-file "flags"))) 864 (error 865 (let ((file (gnus-agent-lib-file "flags"))) 866 (write-region (point-min) (point-max) 867 (gnus-agent-lib-file "flags") nil 'silent) 868 (error "Couldn't set flags from file %s due to %s" 869 file (error-message-string err))))))) 870 (kill-buffer nil)))) 871 872(defun gnus-agent-possibly-synchronize-flags-server (method) 873 "Synchronize flags for server according to `gnus-agent-synchronize-flags'." 874 (when (or (and gnus-agent-synchronize-flags 875 (not (eq gnus-agent-synchronize-flags 'ask))) 876 (and (eq gnus-agent-synchronize-flags 'ask) 877 (gnus-y-or-n-p (format "Synchronize flags on server `%s'? " 878 (cadr method))))) 879 (gnus-agent-synchronize-flags-server method))) 880 881;;;###autoload 882(defun gnus-agent-rename-group (old-group new-group) 883 "Rename fully-qualified OLD-GROUP as NEW-GROUP. 884Always updates the agent, even when disabled, as the old agent 885files would corrupt gnus when the agent was next enabled. 886Depends upon the caller to determine whether group renaming is 887supported." 888 (let* ((old-command-method (gnus-find-method-for-group old-group)) 889 (old-path (directory-file-name 890 (let (gnus-command-method old-command-method) 891 (gnus-agent-group-pathname old-group)))) 892 (new-command-method (gnus-find-method-for-group new-group)) 893 (new-path (directory-file-name 894 (let (gnus-command-method new-command-method) 895 (gnus-agent-group-pathname new-group))))) 896 (gnus-rename-file old-path new-path t) 897 898 (let* ((old-real-group (gnus-group-real-name old-group)) 899 (new-real-group (gnus-group-real-name new-group)) 900 (old-active (gnus-agent-get-group-info old-command-method old-real-group))) 901 (gnus-agent-save-group-info old-command-method old-real-group nil) 902 (gnus-agent-save-group-info new-command-method new-real-group old-active) 903 904 (let ((old-local (gnus-agent-get-local old-group 905 old-real-group old-command-method))) 906 (gnus-agent-set-local old-group 907 nil nil 908 old-real-group old-command-method) 909 (gnus-agent-set-local new-group 910 (car old-local) (cdr old-local) 911 new-real-group new-command-method))))) 912 913;;;###autoload 914(defun gnus-agent-delete-group (group) 915 "Delete fully-qualified GROUP. 916Always updates the agent, even when disabled, as the old agent 917files would corrupt gnus when the agent was next enabled. 918Depends upon the caller to determine whether group deletion is 919supported." 920 (let* ((command-method (gnus-find-method-for-group group)) 921 (path (directory-file-name 922 (let (gnus-command-method command-method) 923 (gnus-agent-group-pathname group))))) 924 (gnus-delete-directory path) 925 926 (let* ((real-group (gnus-group-real-name group))) 927 (gnus-agent-save-group-info command-method real-group nil) 928 929 (let ((local (gnus-agent-get-local group 930 real-group command-method))) 931 (gnus-agent-set-local group 932 nil nil 933 real-group command-method))))) 934 935;;; 936;;; Server mode commands 937;;; 938 939(defun gnus-agent-add-server () 940 "Enroll SERVER in the agent program." 941 (interactive) 942 (let* ((server (gnus-server-server-name)) 943 (named-server (gnus-server-named-server)) 944 (method (and server 945 (gnus-server-get-method nil server)))) 946 (unless server 947 (error "No server on the current line")) 948 949 (when (gnus-agent-method-p method) 950 (error "Server already in the agent program")) 951 952 (push named-server gnus-agent-covered-methods) 953 954 (setq gnus-agent-method-p-cache nil) 955 (gnus-server-update-server server) 956 (gnus-agent-write-servers) 957 (gnus-message 1 "Entered %s into the Agent" server))) 958 959(defun gnus-agent-remove-server () 960 "Remove SERVER from the agent program." 961 (interactive) 962 (let* ((server (gnus-server-server-name)) 963 (named-server (gnus-server-named-server))) 964 (unless server 965 (error "No server on the current line")) 966 967 (unless (member named-server gnus-agent-covered-methods) 968 (error "Server not in the agent program")) 969 970 (setq gnus-agent-covered-methods 971 (delete named-server gnus-agent-covered-methods) 972 gnus-agent-method-p-cache nil) 973 974 (gnus-server-update-server server) 975 (gnus-agent-write-servers) 976 (gnus-message 1 "Removed %s from the agent" server))) 977 978(defun gnus-agent-read-servers () 979 "Read the alist of covered servers." 980 (setq gnus-agent-covered-methods 981 (gnus-agent-read-file 982 (nnheader-concat gnus-agent-directory "lib/servers")) 983 gnus-agent-method-p-cache nil) 984 985 ;; I am called so early in start-up that I can not validate server 986 ;; names. When that is the case, I skip the validation. That is 987 ;; alright as the gnus startup code calls the validate methods 988 ;; directly. 989 (if gnus-server-alist 990 (gnus-agent-read-servers-validate))) 991 992(defun gnus-agent-read-servers-validate () 993 (mapcar (lambda (server-or-method) 994 (let* ((server (if (stringp server-or-method) 995 server-or-method 996 (gnus-method-to-server server-or-method))) 997 (method (gnus-server-to-method server))) 998 (if method 999 (unless (member server gnus-agent-covered-methods) 1000 (push server gnus-agent-covered-methods) 1001 (setq gnus-agent-method-p-cache nil)) 1002 (gnus-message 1 "Ignoring disappeared server `%s'" server)))) 1003 (prog1 gnus-agent-covered-methods 1004 (setq gnus-agent-covered-methods nil)))) 1005 1006(defun gnus-agent-read-servers-validate-native (native-method) 1007 (setq gnus-agent-covered-methods 1008 (mapcar (lambda (method) 1009 (if (or (not method) 1010 (equal method native-method)) 1011 "native" 1012 method)) gnus-agent-covered-methods))) 1013 1014(defun gnus-agent-write-servers () 1015 "Write the alist of covered servers." 1016 (gnus-make-directory (nnheader-concat gnus-agent-directory "lib")) 1017 (let ((coding-system-for-write nnheader-file-coding-system) 1018 (file-name-coding-system nnmail-pathname-coding-system)) 1019 (with-temp-file (nnheader-concat gnus-agent-directory "lib/servers") 1020 (prin1 gnus-agent-covered-methods 1021 (current-buffer))))) 1022 1023;;; 1024;;; Summary commands 1025;;; 1026 1027(defun gnus-agent-mark-article (n &optional unmark) 1028 "Mark the next N articles as downloadable. 1029If N is negative, mark backward instead. If UNMARK is non-nil, remove 1030the mark instead. The difference between N and the actual number of 1031articles marked is returned." 1032 (interactive "p") 1033 (let ((backward (< n 0)) 1034 (n (abs n))) 1035 (while (and 1036 (> n 0) 1037 (progn 1038 (gnus-summary-set-agent-mark 1039 (gnus-summary-article-number) unmark) 1040 (zerop (gnus-summary-next-subject (if backward -1 1) nil t)))) 1041 (setq n (1- n))) 1042 (when (/= 0 n) 1043 (gnus-message 7 "No more articles")) 1044 (gnus-summary-recenter) 1045 (gnus-summary-position-point) 1046 n)) 1047 1048(defun gnus-agent-unmark-article (n) 1049 "Remove the downloadable mark from the next N articles. 1050If N is negative, unmark backward instead. The difference between N and 1051the actual number of articles unmarked is returned." 1052 (interactive "p") 1053 (gnus-agent-mark-article n t)) 1054 1055(defun gnus-agent-toggle-mark (n) 1056 "Toggle the downloadable mark from the next N articles. 1057If N is negative, toggle backward instead. The difference between N and 1058the actual number of articles toggled is returned." 1059 (interactive "p") 1060 (gnus-agent-mark-article n 'toggle)) 1061 1062(defun gnus-summary-set-agent-mark (article &optional unmark) 1063 "Mark ARTICLE as downloadable. If UNMARK is nil, article is marked. 1064When UNMARK is t, the article is unmarked. For any other value, the 1065article's mark is toggled." 1066 (let ((unmark (cond ((eq nil unmark) 1067 nil) 1068 ((eq t unmark) 1069 t) 1070 (t 1071 (memq article gnus-newsgroup-downloadable))))) 1072 (when (gnus-summary-goto-subject article nil t) 1073 (gnus-summary-update-mark 1074 (if unmark 1075 (progn 1076 (setq gnus-newsgroup-downloadable 1077 (delq article gnus-newsgroup-downloadable)) 1078 (gnus-article-mark article)) 1079 (setq gnus-newsgroup-downloadable 1080 (gnus-add-to-sorted-list gnus-newsgroup-downloadable article)) 1081 gnus-downloadable-mark) 1082 'unread)))) 1083 1084;;;###autoload 1085(defun gnus-agent-get-undownloaded-list () 1086 "Construct list of articles that have not been downloaded." 1087 (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))) 1088 (when (set (make-local-variable 'gnus-newsgroup-agentized) 1089 (gnus-agent-method-p gnus-command-method)) 1090 (let* ((alist (gnus-agent-load-alist gnus-newsgroup-name)) 1091 (headers (sort (mapcar (lambda (h) 1092 (mail-header-number h)) 1093 gnus-newsgroup-headers) '<)) 1094 (cached (and gnus-use-cache gnus-newsgroup-cached)) 1095 (undownloaded (list nil)) 1096 (tail-undownloaded undownloaded) 1097 (unfetched (list nil)) 1098 (tail-unfetched unfetched)) 1099 (while (and alist headers) 1100 (let ((a (caar alist)) 1101 (h (car headers))) 1102 (cond ((< a h) 1103 ;; Ignore IDs in the alist that are not being 1104 ;; displayed in the summary. 1105 (setq alist (cdr alist))) 1106 ((> a h) 1107 ;; Headers that are not in the alist should be 1108 ;; fictious (see nnagent-retrieve-headers); they 1109 ;; imply that this article isn't in the agent. 1110 (gnus-agent-append-to-list tail-undownloaded h) 1111 (gnus-agent-append-to-list tail-unfetched h) 1112 (setq headers (cdr headers))) 1113 ((cdar alist) 1114 (setq alist (cdr alist)) 1115 (setq headers (cdr headers)) 1116 nil ; ignore already downloaded 1117 ) 1118 (t 1119 (setq alist (cdr alist)) 1120 (setq headers (cdr headers)) 1121 1122 ;; This article isn't in the agent. Check to see 1123 ;; if it is in the cache. If it is, it's been 1124 ;; downloaded. 1125 (while (and cached (< (car cached) a)) 1126 (setq cached (cdr cached))) 1127 (unless (equal a (car cached)) 1128 (gnus-agent-append-to-list tail-undownloaded a)))))) 1129 1130 (while headers 1131 (let ((num (pop headers))) 1132 (gnus-agent-append-to-list tail-undownloaded num) 1133 (gnus-agent-append-to-list tail-unfetched num))) 1134 1135 (setq gnus-newsgroup-undownloaded (cdr undownloaded) 1136 gnus-newsgroup-unfetched (cdr unfetched)))))) 1137 1138(defun gnus-agent-catchup () 1139 "Mark as read all unhandled articles. 1140An article is unhandled if it is neither cached, nor downloaded, nor 1141downloadable." 1142 (interactive) 1143 (save-excursion 1144 (let ((articles gnus-newsgroup-undownloaded)) 1145 (when (or gnus-newsgroup-downloadable 1146 gnus-newsgroup-cached) 1147 (setq articles (gnus-sorted-ndifference 1148 (gnus-sorted-ndifference 1149 (gnus-copy-sequence articles) 1150 gnus-newsgroup-downloadable) 1151 gnus-newsgroup-cached))) 1152 1153 (while articles 1154 (gnus-summary-mark-article 1155 (pop articles) gnus-catchup-mark))) 1156 (gnus-summary-position-point))) 1157 1158(defun gnus-agent-summary-fetch-series () 1159 (interactive) 1160 (when gnus-newsgroup-processable 1161 (setq gnus-newsgroup-downloadable 1162 (let* ((dl gnus-newsgroup-downloadable) 1163 (processable (sort (gnus-copy-sequence gnus-newsgroup-processable) '<)) 1164 (gnus-newsgroup-downloadable processable)) 1165 (gnus-agent-summary-fetch-group) 1166 1167 ;; For each article that I processed that is no longer 1168 ;; undownloaded, remove its processable mark. 1169 1170 (mapc #'gnus-summary-remove-process-mark 1171 (gnus-sorted-ndifference gnus-newsgroup-processable gnus-newsgroup-undownloaded)) 1172 1173 ;; The preceeding call to (gnus-agent-summary-fetch-group) 1174 ;; updated the temporary gnus-newsgroup-downloadable to 1175 ;; remove each article successfully fetched. Now, I 1176 ;; update the real gnus-newsgroup-downloadable to only 1177 ;; include undownloaded articles. 1178 (gnus-sorted-ndifference dl (gnus-sorted-ndifference processable gnus-newsgroup-undownloaded)))))) 1179 1180(defun gnus-agent-summary-fetch-group (&optional all) 1181 "Fetch the downloadable articles in the group. 1182Optional arg ALL, if non-nil, means to fetch all articles." 1183 (interactive "P") 1184 (let ((articles 1185 (if all gnus-newsgroup-articles 1186 gnus-newsgroup-downloadable)) 1187 (gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name)) 1188 fetched-articles) 1189 (gnus-agent-while-plugged 1190 (unless articles 1191 (error "No articles to download")) 1192 (gnus-agent-with-fetch 1193 (setq gnus-newsgroup-undownloaded 1194 (gnus-sorted-ndifference 1195 gnus-newsgroup-undownloaded 1196 (setq fetched-articles 1197 (gnus-agent-fetch-articles 1198 gnus-newsgroup-name articles))))) 1199 (save-excursion 1200 (dolist (article articles) 1201 (let ((was-marked-downloadable 1202 (memq article gnus-newsgroup-downloadable))) 1203 (cond (gnus-agent-mark-unread-after-downloaded 1204 (setq gnus-newsgroup-downloadable 1205 (delq article gnus-newsgroup-downloadable)) 1206 1207 (gnus-summary-mark-article article gnus-unread-mark)) 1208 (was-marked-downloadable 1209 (gnus-summary-set-agent-mark article t))) 1210 (when (gnus-summary-goto-subject article nil t) 1211 (gnus-summary-update-download-mark article)))))) 1212 fetched-articles)) 1213 1214(defun gnus-agent-fetch-selected-article () 1215 "Fetch the current article as it is selected. 1216This can be added to `gnus-select-article-hook' or 1217`gnus-mark-article-hook'." 1218 (let ((gnus-command-method gnus-current-select-method)) 1219 (when (and gnus-plugged (gnus-agent-method-p gnus-command-method)) 1220 (when (gnus-agent-fetch-articles 1221 gnus-newsgroup-name 1222 (list gnus-current-article)) 1223 (setq gnus-newsgroup-undownloaded 1224 (delq gnus-current-article gnus-newsgroup-undownloaded)) 1225 (gnus-summary-update-download-mark gnus-current-article))))) 1226 1227;;; 1228;;; Internal functions 1229;;; 1230 1231(defun gnus-agent-synchronize-group-flags (group actions server) 1232"Update a plugged group by performing the indicated actions." 1233 (let* ((gnus-command-method (gnus-server-to-method server)) 1234 (info 1235 ;; This initializer is required as gnus-request-set-mark 1236 ;; calls gnus-group-real-name to strip off the host name 1237 ;; before calling the backend. Now that the backend is 1238 ;; trying to call gnus-request-set-mark, I have to 1239 ;; reconstruct the original group name. 1240 (or (gnus-get-info group) 1241 (gnus-get-info 1242 (setq group (gnus-group-full-name 1243 group gnus-command-method)))))) 1244 (gnus-request-set-mark group actions) 1245 1246 (when info 1247 (dolist (action actions) 1248 (let ((range (nth 0 action)) 1249 (what (nth 1 action)) 1250 (marks (nth 2 action))) 1251 (dolist (mark marks) 1252 (cond ((eq mark 'read) 1253 (gnus-info-set-read 1254 info 1255 (funcall (if (eq what 'add) 1256 'gnus-range-add 1257 'gnus-remove-from-range) 1258 (gnus-info-read info) 1259 range)) 1260 (gnus-get-unread-articles-in-group 1261 info 1262 (gnus-active (gnus-info-group info)))) 1263 ((memq mark '(tick)) 1264 (let ((info-marks (assoc mark (gnus-info-marks info)))) 1265 (unless info-marks 1266 (gnus-info-set-marks info (cons (setq info-marks (list mark)) (gnus-info-marks info)))) 1267 (setcdr info-marks (funcall (if (eq what 'add) 1268 'gnus-range-add 1269 'gnus-remove-from-range) 1270 (cdr info-marks) 1271 range)))))))) 1272 1273 ;;Marks can be synchronized at any time by simply toggling from 1274 ;;unplugged to plugged. If that is what is happening right now, make 1275 ;;sure that the group buffer is up to date. 1276 (when (gnus-buffer-live-p gnus-group-buffer) 1277 (gnus-group-update-group group t))) 1278 nil)) 1279 1280(defun gnus-agent-save-active (method) 1281 (when (gnus-agent-method-p method) 1282 (let* ((gnus-command-method method) 1283 (new (gnus-make-hashtable (count-lines (point-min) (point-max)))) 1284 (file (gnus-agent-lib-file "active"))) 1285 (gnus-active-to-gnus-format nil new) 1286 (gnus-agent-write-active file new) 1287 (erase-buffer) 1288 (nnheader-insert-file-contents file)))) 1289 1290(defun gnus-agent-write-active (file new) 1291 (gnus-make-directory (file-name-directory file)) 1292 (let ((nnmail-active-file-coding-system gnus-agent-file-coding-system)) 1293 ;; The hashtable contains real names of groups. However, do NOT 1294 ;; add the foreign server prefix as gnus-active-to-gnus-format 1295 ;; will add it while reading the file. 1296 (gnus-write-active-file file new nil))) 1297 1298;;;###autoload 1299(defun gnus-agent-possibly-alter-active (group active &optional info) 1300 "Possibly expand a group's active range to include articles 1301downloaded into the agent." 1302 (let* ((gnus-command-method (or gnus-command-method 1303 (gnus-find-method-for-group group)))) 1304 (when (gnus-agent-method-p gnus-command-method) 1305 (let* ((local (gnus-agent-get-local group)) 1306 (active-min (or (car active) 0)) 1307 (active-max (or (cdr active) 0)) 1308 (agent-min (or (car local) active-min)) 1309 (agent-max (or (cdr local) active-max))) 1310 1311 (when (< agent-min active-min) 1312 (setcar active agent-min)) 1313 1314 (when (> agent-max active-max) 1315 (setcdr active agent-max)) 1316 1317 (when (and info (< agent-max (- active-min 100))) 1318 ;; I'm expanding the active range by such a large amount 1319 ;; that there is a gap of more than 100 articles between the 1320 ;; last article known to the agent and the first article 1321 ;; currently available on the server. This gap contains 1322 ;; articles that have been lost, mark them as read so that 1323 ;; gnus doesn't waste resources trying to fetch them. 1324 1325 ;; NOTE: I don't do this for smaller gaps (< 100) as I don't 1326 ;; want to modify the local file everytime someone restarts 1327 ;; gnus. The small gap will cause a tiny performance hit 1328 ;; when gnus tries, and fails, to retrieve the articles. 1329 ;; Still that should be smaller than opening a buffer, 1330 ;; printing this list to the buffer, and then writing it to a 1331 ;; file. 1332 1333 (let ((read (gnus-info-read info))) 1334 (gnus-info-set-read 1335 info 1336 (gnus-range-add 1337 read 1338 (list (cons (1+ agent-max) 1339 (1- active-min)))))) 1340 1341 ;; Lie about the agent's local range for this group to 1342 ;; disable the set read each time this server is opened. 1343 ;; NOTE: Opening this group will restore the valid local 1344 ;; range but it will also expand the local range to 1345 ;; incompass the new active range. 1346 (gnus-agent-set-local group agent-min (1- active-min))))))) 1347 1348(defun gnus-agent-save-group-info (method group active) 1349 "Update a single group's active range in the agent's copy of the server's active file." 1350 (when (gnus-agent-method-p method) 1351 (let* ((gnus-command-method (or method gnus-command-method)) 1352 (coding-system-for-write nnheader-file-coding-system) 1353 (file-name-coding-system nnmail-pathname-coding-system) 1354 (file (gnus-agent-lib-file "active")) 1355 oactive-min oactive-max) 1356 (gnus-make-directory (file-name-directory file)) 1357 (with-temp-file file 1358 ;; Emacs got problem to match non-ASCII group in multibyte buffer. 1359 (mm-disable-multibyte) 1360 (when (file-exists-p file) 1361 (nnheader-insert-file-contents file) 1362 1363 (goto-char (point-min)) 1364 (when (re-search-forward 1365 (concat "^" (regexp-quote group) " ") nil t) 1366 (save-excursion 1367 (setq oactive-max (read (current-buffer)) ;; max 1368 oactive-min (read (current-buffer)))) ;; min 1369 (gnus-delete-line))) 1370 (when active 1371 (insert (format "%S %d %d y\n" (intern group) 1372 (max (or oactive-max (cdr active)) (cdr active)) 1373 (min (or oactive-min (car active)) (car active)))) 1374 (goto-char (point-max)) 1375 (while (search-backward "\\." nil t) 1376 (delete-char 1))))))) 1377 1378(defun gnus-agent-get-group-info (method group) 1379 "Get a single group's active range in the agent's copy of the server's active file." 1380 (when (gnus-agent-method-p method) 1381 (let* ((gnus-command-method (or method gnus-command-method)) 1382 (coding-system-for-write nnheader-file-coding-system) 1383 (file-name-coding-system nnmail-pathname-coding-system) 1384 (file (gnus-agent-lib-file "active")) 1385 oactive-min oactive-max) 1386 (gnus-make-directory (file-name-directory file)) 1387 (with-temp-buffer 1388 ;; Emacs got problem to match non-ASCII group in multibyte buffer. 1389 (mm-disable-multibyte) 1390 (when (file-exists-p file) 1391 (nnheader-insert-file-contents file) 1392 1393 (goto-char (point-min)) 1394 (when (re-search-forward 1395 (concat "^" (regexp-quote group) " ") nil t) 1396 (save-excursion 1397 (setq oactive-max (read (current-buffer)) ;; max 1398 oactive-min (read (current-buffer))) ;; min 1399 (cons oactive-min oactive-max)))))))) 1400 1401(defun gnus-agent-group-path (group) 1402 "Translate GROUP into a file name." 1403 1404 ;; NOTE: This is what nnmail-group-pathname does as of Apr 2003. 1405 ;; The two methods must be kept synchronized, which is why 1406 ;; gnus-agent-group-pathname was added. 1407 1408 (setq group 1409 (nnheader-translate-file-chars 1410 (nnheader-replace-duplicate-chars-in-string 1411 (nnheader-replace-chars-in-string 1412 (gnus-group-real-name (gnus-group-decoded-name group)) 1413 ?/ ?_) 1414 ?. ?_))) 1415 (if (or nnmail-use-long-file-names 1416 (file-directory-p (expand-file-name group (gnus-agent-directory)))) 1417 group 1418 (mm-encode-coding-string 1419 (nnheader-replace-chars-in-string group ?. ?/) 1420 nnmail-pathname-coding-system))) 1421 1422(defun gnus-agent-group-pathname (group) 1423 "Translate GROUP into a file name." 1424 ;; nnagent uses nnmail-group-pathname to read articles while 1425 ;; unplugged. The agent must, therefore, use the same directory 1426 ;; while plugged. 1427 (let ((gnus-command-method (or gnus-command-method 1428 (gnus-find-method-for-group group)))) 1429 (nnmail-group-pathname (gnus-group-real-name 1430 (gnus-group-decoded-name group)) 1431 (gnus-agent-directory)))) 1432 1433(defun gnus-agent-get-function (method) 1434 (if (gnus-online method) 1435 (car method) 1436 (require 'nnagent) 1437 'nnagent)) 1438 1439(defun gnus-agent-covered-methods () 1440 "Return the subset of methods that are covered by the agent." 1441 (delq nil (mapcar #'gnus-server-to-method gnus-agent-covered-methods))) 1442 1443;;; History functions 1444 1445(defun gnus-agent-history-buffer () 1446 (cdr (assoc (gnus-agent-method) gnus-agent-history-buffers))) 1447 1448(defun gnus-agent-open-history () 1449 (save-excursion 1450 (push (cons (gnus-agent-method) 1451 (set-buffer (gnus-get-buffer-create 1452 (format " *Gnus agent %s history*" 1453 (gnus-agent-method))))) 1454 gnus-agent-history-buffers) 1455 (mm-disable-multibyte) ;; everything is binary 1456 (erase-buffer) 1457 (insert "\n") 1458 (let ((file (gnus-agent-lib-file "history"))) 1459 (when (file-exists-p file) 1460 (nnheader-insert-file-contents file)) 1461 (set (make-local-variable 'gnus-agent-file-name) file)))) 1462 1463(defun gnus-agent-close-history () 1464 (when (gnus-buffer-live-p gnus-agent-current-history) 1465 (kill-buffer gnus-agent-current-history) 1466 (setq gnus-agent-history-buffers 1467 (delq (assoc (gnus-agent-method) gnus-agent-history-buffers) 1468 gnus-agent-history-buffers)))) 1469 1470;;; 1471;;; Fetching 1472;;; 1473 1474(defun gnus-agent-fetch-articles (group articles) 1475 "Fetch ARTICLES from GROUP and put them into the Agent." 1476 (when articles 1477 (gnus-agent-load-alist group) 1478 (let* ((alist gnus-agent-article-alist) 1479 (headers (if (< (length articles) 2) nil gnus-newsgroup-headers)) 1480 (selected-sets (list nil)) 1481 (current-set-size 0) 1482 article 1483 header-number) 1484 ;; Check each article 1485 (while (setq article (pop articles)) 1486 ;; Skip alist entries preceeding this article 1487 (while (> article (or (caar alist) (1+ article))) 1488 (setq alist (cdr alist))) 1489 1490 ;; Prune off articles that we have already fetched. 1491 (unless (and (eq article (caar alist)) 1492 (cdar alist)) 1493 ;; Skip headers preceeding this article 1494 (while (> article 1495 (setq header-number 1496 (let* ((header (car headers))) 1497 (if header 1498 (mail-header-number header) 1499 (1+ article))))) 1500 (setq headers (cdr headers))) 1501 1502 ;; Add this article to the current set 1503 (setcar selected-sets (cons article (car selected-sets))) 1504 1505 ;; Update the set size, when the set is too large start a 1506 ;; new one. I do this after adding the article as I want at 1507 ;; least one article in each set. 1508 (when (< gnus-agent-max-fetch-size 1509 (setq current-set-size 1510 (+ current-set-size 1511 (if (= header-number article) 1512 (let ((char-size (mail-header-chars 1513 (car headers)))) 1514 (if (<= char-size 0) 1515 ;; The char size was missing/invalid, 1516 ;; assume a worst-case situation of 1517 ;; 65 char/line. If the line count 1518 ;; is missing, arbitrarily assume a 1519 ;; size of 1000 characters. 1520 (max (* 65 (mail-header-lines 1521 (car headers))) 1522 1000) 1523 char-size)) 1524 0)))) 1525 (setcar selected-sets (nreverse (car selected-sets))) 1526 (setq selected-sets (cons nil selected-sets) 1527 current-set-size 0)))) 1528 1529 (when (or (cdr selected-sets) (car selected-sets)) 1530 (let* ((fetched-articles (list nil)) 1531 (tail-fetched-articles fetched-articles) 1532 (dir (gnus-agent-group-pathname group)) 1533 (date (time-to-days (current-time))) 1534 (case-fold-search t) 1535 pos crosses id) 1536 1537 (setcar selected-sets (nreverse (car selected-sets))) 1538 (setq selected-sets (nreverse selected-sets)) 1539 1540 (gnus-make-directory dir) 1541 (gnus-message 7 "Fetching articles for %s..." group) 1542 1543 (unwind-protect 1544 (while (setq articles (pop selected-sets)) 1545 ;; Fetch the articles from the backend. 1546 (if (gnus-check-backend-function 'retrieve-articles group) 1547 (setq pos (gnus-retrieve-articles articles group)) 1548 (with-temp-buffer 1549 (let (article) 1550 (while (setq article (pop articles)) 1551 (gnus-message 10 "Fetching article %s for %s..." 1552 article group) 1553 (when (or 1554 (gnus-backlog-request-article group article 1555 nntp-server-buffer) 1556 (gnus-request-article article group)) 1557 (goto-char (point-max)) 1558 (push (cons article (point)) pos) 1559 (insert-buffer-substring nntp-server-buffer))) 1560 (copy-to-buffer 1561 nntp-server-buffer (point-min) (point-max)) 1562 (setq pos (nreverse pos))))) 1563 ;; Then save these articles into the Agent. 1564 (save-excursion 1565 (set-buffer nntp-server-buffer) 1566 (while pos 1567 (narrow-to-region (cdar pos) (or (cdadr pos) (point-max))) 1568 (goto-char (point-min)) 1569 (unless (eobp) ;; Don't save empty articles. 1570 (when (search-forward "\n\n" nil t) 1571 (when (search-backward "\nXrefs: " nil t) 1572 ;; Handle cross posting. 1573 (goto-char (match-end 0)) ; move to end of header name 1574 (skip-chars-forward "^ ") ; skip server name 1575 (skip-chars-forward " ") 1576 (setq crosses nil) 1577 (while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) *") 1578 (push (cons (buffer-substring (match-beginning 1) 1579 (match-end 1)) 1580 (string-to-number 1581 (buffer-substring (match-beginning 2) 1582 (match-end 2)))) 1583 crosses) 1584 (goto-char (match-end 0))) 1585 (gnus-agent-crosspost crosses (caar pos) date))) 1586 (goto-char (point-min)) 1587 (if (not (re-search-forward 1588 "^Message-ID: *<\\([^>\n]+\\)>" nil t)) 1589 (setq id "No-Message-ID-in-article") 1590 (setq id (buffer-substring 1591 (match-beginning 1) (match-end 1)))) 1592 (let ((coding-system-for-write 1593 gnus-agent-file-coding-system)) 1594 (write-region (point-min) (point-max) 1595 (concat dir (number-to-string (caar pos))) 1596 nil 'silent)) 1597 1598 (gnus-agent-append-to-list 1599 tail-fetched-articles (caar pos))) 1600 (widen) 1601 (setq pos (cdr pos))))) 1602 1603 (gnus-agent-save-alist group (cdr fetched-articles) date) 1604 (gnus-message 7 "")) 1605 (cdr fetched-articles)))))) 1606 1607(defun gnus-agent-unfetch-articles (group articles) 1608 "Delete ARTICLES that were fetched from GROUP into the agent." 1609 (when articles 1610 (gnus-agent-load-alist group) 1611 (let* ((alist (cons nil gnus-agent-article-alist)) 1612 (articles (sort articles #'<)) 1613 (next-possibility alist) 1614 (delete-this (pop articles))) 1615 (while (and (cdr next-possibility) delete-this) 1616 (let ((have-this (caar (cdr next-possibility)))) 1617 (cond ((< delete-this have-this) 1618 (setq delete-this (pop articles))) 1619 ((= delete-this have-this) 1620 (let ((timestamp (cdar (cdr next-possibility)))) 1621 (when timestamp 1622 (let* ((file-name (concat (gnus-agent-group-pathname group) 1623 (number-to-string have-this)))) 1624 (delete-file file-name)))) 1625 1626 (setcdr next-possibility (cddr next-possibility))) 1627 (t 1628 (setq next-possibility (cdr next-possibility)))))) 1629 (setq gnus-agent-article-alist (cdr alist)) 1630 (gnus-agent-save-alist group)))) 1631 1632(defun gnus-agent-crosspost (crosses article &optional date) 1633 (setq date (or date t)) 1634 1635 (let (gnus-agent-article-alist group alist beg end) 1636 (save-excursion 1637 (set-buffer gnus-agent-overview-buffer) 1638 (when (nnheader-find-nov-line article) 1639 (forward-word 1) 1640 (setq beg (point)) 1641 (setq end (progn (forward-line 1) (point))))) 1642 (while crosses 1643 (setq group (caar crosses)) 1644 (unless (setq alist (assoc group gnus-agent-group-alist)) 1645 (push (setq alist (list group (gnus-agent-load-alist (caar crosses)))) 1646 gnus-agent-group-alist)) 1647 (setcdr alist (cons (cons (cdar crosses) date) (cdr alist))) 1648 (save-excursion 1649 (set-buffer (gnus-get-buffer-create (format " *Gnus agent overview %s*" 1650 group))) 1651 (when (= (point-max) (point-min)) 1652 (push (cons group (current-buffer)) gnus-agent-buffer-alist) 1653 (ignore-errors 1654 (nnheader-insert-file-contents 1655 (gnus-agent-article-name ".overview" group)))) 1656 (nnheader-find-nov-line (string-to-number (cdar crosses))) 1657 (insert (string-to-number (cdar crosses))) 1658 (insert-buffer-substring gnus-agent-overview-buffer beg end) 1659 (gnus-agent-check-overview-buffer)) 1660 (setq crosses (cdr crosses))))) 1661 1662(defun gnus-agent-backup-overview-buffer () 1663 (when gnus-newsgroup-name 1664 (let ((root (gnus-agent-article-name ".overview" gnus-newsgroup-name)) 1665 (cnt 0) 1666 name) 1667 (while (file-exists-p 1668 (setq name (concat root "~" 1669 (int-to-string (setq cnt (1+ cnt))) "~")))) 1670 (write-region (point-min) (point-max) name nil 'no-msg) 1671 (gnus-message 1 "Created backup copy of overview in %s." name))) 1672 t) 1673 1674(defun gnus-agent-check-overview-buffer (&optional buffer) 1675 "Check the overview file given for sanity. 1676In particular, checks that the file is sorted by article number 1677and that there are no duplicates." 1678 (let ((prev-num -1) 1679 (backed-up nil)) 1680 (save-excursion 1681 (when buffer 1682 (set-buffer buffer)) 1683 (save-restriction 1684 (widen) 1685 (goto-char (point-min)) 1686 1687 (while (< (point) (point-max)) 1688 (let ((p (point)) 1689 (cur (condition-case nil 1690 (read (current-buffer)) 1691 (error nil)))) 1692 (cond 1693 ((or (not (integerp cur)) 1694 (not (eq (char-after) ?\t))) 1695 (or backed-up 1696 (setq backed-up (gnus-agent-backup-overview-buffer))) 1697 (gnus-message 1 1698 "Overview buffer contains garbage '%s'." 1699 (buffer-substring 1700 p (gnus-point-at-eol)))) 1701 ((= cur prev-num) 1702 (or backed-up 1703 (setq backed-up (gnus-agent-backup-overview-buffer))) 1704 (gnus-message 1 1705 "Duplicate overview line for %d" cur) 1706 (delete-region p (progn (forward-line 1) (point)))) 1707 ((< cur prev-num) 1708 (or backed-up 1709 (setq backed-up (gnus-agent-backup-overview-buffer))) 1710 (gnus-message 1 "Overview buffer not sorted!") 1711 (sort-numeric-fields 1 (point-min) (point-max)) 1712 (goto-char (point-min)) 1713 (setq prev-num -1)) 1714 (t 1715 (setq prev-num cur))) 1716 (forward-line 1))))))) 1717 1718(defun gnus-agent-flush-cache () 1719 (save-excursion 1720 (while gnus-agent-buffer-alist 1721 (set-buffer (cdar gnus-agent-buffer-alist)) 1722 (let ((coding-system-for-write 1723 gnus-agent-file-coding-system)) 1724 (write-region (point-min) (point-max) 1725 (gnus-agent-article-name ".overview" 1726 (caar gnus-agent-buffer-alist)) 1727 nil 'silent)) 1728 (setq gnus-agent-buffer-alist (cdr gnus-agent-buffer-alist))) 1729 (while gnus-agent-group-alist 1730 (with-temp-file (gnus-agent-article-name 1731 ".agentview" (caar gnus-agent-group-alist)) 1732 (princ (cdar gnus-agent-group-alist)) 1733 (insert "\n") 1734 (princ 1 (current-buffer)) 1735 (insert "\n")) 1736 (setq gnus-agent-group-alist (cdr gnus-agent-group-alist))))) 1737 1738;;;###autoload 1739(defun gnus-agent-find-parameter (group symbol) 1740 "Search for GROUPs SYMBOL in the group's parameters, the group's 1741topic parameters, the group's category, or the customizable 1742variables. Returns the first non-nil value found." 1743 (or (gnus-group-find-parameter group symbol t) 1744 (gnus-group-parameter-value (cdr (gnus-group-category group)) symbol t) 1745 (symbol-value 1746 (cdr 1747 (assq symbol 1748 '((agent-short-article . gnus-agent-short-article) 1749 (agent-long-article . gnus-agent-long-article) 1750 (agent-low-score . gnus-agent-low-score) 1751 (agent-high-score . gnus-agent-high-score) 1752 (agent-days-until-old . gnus-agent-expire-days) 1753 (agent-enable-expiration 1754 . gnus-agent-enable-expiration) 1755 (agent-predicate . gnus-agent-predicate))))))) 1756 1757(defun gnus-agent-fetch-headers (group &optional force) 1758 "Fetch interesting headers into the agent. The group's overview 1759file will be updated to include the headers while a list of available 1760article numbers will be returned." 1761 (let* ((fetch-all (and gnus-agent-consider-all-articles 1762 ;; Do not fetch all headers if the predicate 1763 ;; implies that we only consider unread articles. 1764 (not (gnus-predicate-implies-unread 1765 (gnus-agent-find-parameter group 1766 'agent-predicate))))) 1767 (articles (if fetch-all 1768 (gnus-uncompress-range (gnus-active group)) 1769 (gnus-list-of-unread-articles group))) 1770 (gnus-decode-encoded-word-function 'identity) 1771 (file (gnus-agent-article-name ".overview" group))) 1772 1773 (unless fetch-all 1774 ;; Add articles with marks to the list of article headers we want to 1775 ;; fetch. Don't fetch articles solely on the basis of a recent or seen 1776 ;; mark, but do fetch recent or seen articles if they have other, more 1777 ;; interesting marks. (We have to fetch articles with boring marks 1778 ;; because otherwise the agent will remove their marks.) 1779 (dolist (arts (gnus-info-marks (gnus-get-info group))) 1780 (unless (memq (car arts) '(seen recent killed cache)) 1781 (setq articles (gnus-range-add articles (cdr arts))))) 1782 (setq articles (sort (gnus-uncompress-sequence articles) '<))) 1783 1784 ;; At this point, I have the list of articles to consider for 1785 ;; fetching. This is the list that I'll return to my caller. Some 1786 ;; of these articles may have already been fetched. That's OK as 1787 ;; the fetch article code will filter those out. Internally, I'll 1788 ;; filter this list to just those articles whose headers need to 1789 ;; be fetched. 1790 (let ((articles articles)) 1791 ;; Remove known articles. 1792 (when (and (or gnus-agent-cache 1793 (not gnus-plugged)) 1794 (gnus-agent-load-alist group)) 1795 ;; Remove articles marked as downloaded. 1796 (if fetch-all 1797 ;; I want to fetch all headers in the active range. 1798 ;; Therefore, exclude only those headers that are in the 1799 ;; article alist. 1800 ;; NOTE: This is probably NOT what I want to do after 1801 ;; agent expiration in this group. 1802 (setq articles (gnus-agent-uncached-articles articles group)) 1803 1804 ;; I want to only fetch those headers that have never been 1805 ;; fetched. Therefore, exclude all headers that are, or 1806 ;; WERE, in the article alist. 1807 (let ((low (1+ (caar (last gnus-agent-article-alist)))) 1808 (high (cdr (gnus-active group)))) 1809 ;; Low can be greater than High when the same group is 1810 ;; fetched twice in the same session {The first fetch will 1811 ;; fill the article alist such that (last 1812 ;; gnus-agent-article-alist) equals (cdr (gnus-active 1813 ;; group))}. The addition of one(the 1+ above) then 1814 ;; forces Low to be greater than High. When this happens, 1815 ;; gnus-list-range-intersection returns nil which 1816 ;; indicates that no headers need to be fetched. -- Kevin 1817 (setq articles (gnus-list-range-intersection 1818 articles (list (cons low high))))))) 1819 1820 (gnus-message 1821 10 "gnus-agent-fetch-headers: undownloaded articles are '%s'" 1822 (gnus-compress-sequence articles t)) 1823 1824 (save-excursion 1825 (set-buffer nntp-server-buffer) 1826 1827 (if articles 1828 (progn 1829 (gnus-message 7 "Fetching headers for %s..." group) 1830 1831 ;; Fetch them. 1832 (gnus-make-directory (nnheader-translate-file-chars 1833 (file-name-directory file) t)) 1834 1835 (unless (eq 'nov (gnus-retrieve-headers articles group)) 1836 (nnvirtual-convert-headers)) 1837 (gnus-agent-check-overview-buffer) 1838 ;; Move these headers to the overview buffer so that 1839 ;; gnus-agent-braid-nov can merge them with the contents 1840 ;; of FILE. 1841 (copy-to-buffer 1842 gnus-agent-overview-buffer (point-min) (point-max)) 1843 ;; NOTE: Call g-a-brand-nov even when the file does not 1844 ;; exist. As a minimum, it will validate the article 1845 ;; numbers already in the buffer. 1846 (gnus-agent-braid-nov group articles file) 1847 (let ((coding-system-for-write 1848 gnus-agent-file-coding-system)) 1849 (gnus-agent-check-overview-buffer) 1850 (write-region (point-min) (point-max) file nil 'silent)) 1851 (gnus-agent-save-alist group articles nil) 1852 articles) 1853 (ignore-errors 1854 (erase-buffer) 1855 (nnheader-insert-file-contents file))))) 1856 articles)) 1857 1858(defsubst gnus-agent-read-article-number () 1859 "Reads the article number at point. Returns nil when a valid article number can not be read." 1860 1861 ;; It is unfortunate but the read function quietly overflows 1862 ;; integer. As a result, I have to use string operations to test 1863 ;; for overflow BEFORE calling read. 1864 (when (looking-at "[0-9]+\t") 1865 (let ((len (- (match-end 0) (match-beginning 0)))) 1866 (cond ((< len 9) 1867 (read (current-buffer))) 1868 ((= len 9) 1869 ;; Many 9 digit base-10 numbers can be represented in a 27-bit int 1870 ;; Back convert from int to string to ensure that this is one of them. 1871 (let* ((str1 (buffer-substring (match-beginning 0) (1- (match-end 0)))) 1872 (num (read (current-buffer))) 1873 (str2 (int-to-string num))) 1874 (when (equal str1 str2) 1875 num))))))) 1876 1877(defsubst gnus-agent-copy-nov-line (article) 1878 "Copy the indicated ARTICLE from the overview buffer to the nntp server buffer." 1879 (let (art b e) 1880 (set-buffer gnus-agent-overview-buffer) 1881 (while (and (not (eobp)) 1882 (or (not (setq art (gnus-agent-read-article-number))) 1883 (< art article))) 1884 (forward-line 1)) 1885 (beginning-of-line) 1886 (if (or (eobp) 1887 (not (eq article art))) 1888 (set-buffer nntp-server-buffer) 1889 (setq b (point)) 1890 (setq e (progn (forward-line 1) (point))) 1891 (set-buffer nntp-server-buffer) 1892 (insert-buffer-substring gnus-agent-overview-buffer b e)))) 1893 1894(defun gnus-agent-braid-nov (group articles file) 1895 "Merge agent overview data with given file. 1896Takes unvalidated headers for ARTICLES from 1897`gnus-agent-overview-buffer' and validated headers from the given 1898FILE and places the combined valid headers into 1899`nntp-server-buffer'. This function can be used, when file 1900doesn't exist, to valid the overview buffer." 1901 (let (start last) 1902 (set-buffer gnus-agent-overview-buffer) 1903 (goto-char (point-min)) 1904 (set-buffer nntp-server-buffer) 1905 (erase-buffer) 1906 (when (file-exists-p file) 1907 (nnheader-insert-file-contents file)) 1908 (goto-char (point-max)) 1909 (forward-line -1) 1910 1911 (unless (or (= (point-min) (point-max)) 1912 (< (setq last (read (current-buffer))) (car articles))) 1913 ;; Old and new overlap -- We do it the hard way. 1914 (when (nnheader-find-nov-line (car articles)) 1915 ;; Replacing existing NOV entry 1916 (delete-region (point) (progn (forward-line 1) (point)))) 1917 (gnus-agent-copy-nov-line (pop articles)) 1918 1919 (ignore-errors 1920 (while articles 1921 (while (let ((art (read (current-buffer)))) 1922 (cond ((< art (car articles)) 1923 (forward-line 1) 1924 t) 1925 ((= art (car articles)) 1926 (beginning-of-line) 1927 (delete-region 1928 (point) (progn (forward-line 1) (point))) 1929 nil) 1930 (t 1931 (beginning-of-line) 1932 nil)))) 1933 1934 (gnus-agent-copy-nov-line (pop articles))))) 1935 1936 (goto-char (point-max)) 1937 1938 ;; Append the remaining lines 1939 (when articles 1940 (when last 1941 (set-buffer gnus-agent-overview-buffer) 1942 (setq start (point)) 1943 (set-buffer nntp-server-buffer)) 1944 1945 (let ((p (point))) 1946 (insert-buffer-substring gnus-agent-overview-buffer start) 1947 (goto-char p)) 1948 1949 (setq last (or last -134217728)) 1950 (while (catch 'problems 1951 (let (sort art) 1952 (while (not (eobp)) 1953 (setq art (gnus-agent-read-article-number)) 1954 (cond ((not art) 1955 ;; Bad art num - delete this line 1956 (beginning-of-line) 1957 (delete-region (point) (progn (forward-line 1) (point)))) 1958 ((< art last) 1959 ;; Art num out of order - enable sort 1960 (setq sort t) 1961 (forward-line 1)) 1962 ((= art last) 1963 ;; Bad repeat of art number - delete this line 1964 (beginning-of-line) 1965 (delete-region (point) (progn (forward-line 1) (point)))) 1966 (t 1967 ;; Good art num 1968 (setq last art) 1969 (forward-line 1)))) 1970 (when sort 1971 ;; something is seriously wrong as we simply shouldn't see out-of-order data. 1972 ;; First, we'll fix the sort. 1973 (sort-numeric-fields 1 (point-min) (point-max)) 1974 1975 ;; but now we have to consider that we may have duplicate rows... 1976 ;; so reset to beginning of file 1977 (goto-char (point-min)) 1978 (setq last -134217728) 1979 1980 ;; and throw a code that restarts this scan 1981 (throw 'problems t)) 1982 nil)))))) 1983 1984;; Keeps the compiler from warning about the free variable in 1985;; gnus-agent-read-agentview. 1986(eval-when-compile 1987 (defvar gnus-agent-read-agentview)) 1988 1989(defun gnus-agent-load-alist (group) 1990 "Load the article-state alist for GROUP." 1991 ;; Bind free variable that's used in `gnus-agent-read-agentview'. 1992 (let ((gnus-agent-read-agentview group)) 1993 (setq gnus-agent-article-alist 1994 (gnus-cache-file-contents 1995 (gnus-agent-article-name ".agentview" group) 1996 'gnus-agent-file-loading-cache 1997 'gnus-agent-read-agentview)))) 1998 1999(defun gnus-agent-read-agentview (file) 2000 "Load FILE and do a `read' there." 2001 (with-temp-buffer 2002 (condition-case nil 2003 (progn 2004 (nnheader-insert-file-contents file) 2005 (goto-char (point-min)) 2006 (let ((alist (read (current-buffer))) 2007 (version (condition-case nil (read (current-buffer)) 2008 (end-of-file 0))) 2009 changed-version) 2010 2011 (cond 2012 ((= version 0) 2013 (let ((inhibit-quit t) 2014 entry) 2015 (gnus-agent-open-history) 2016 (set-buffer (gnus-agent-history-buffer)) 2017 (goto-char (point-min)) 2018 (while (not (eobp)) 2019 (if (and (looking-at 2020 "[^\t\n]+\t\\([0-9]+\\)\t\\([^ \n]+\\) \\([0-9]+\\)") 2021 (string= (match-string 2) 2022 gnus-agent-read-agentview) 2023 (setq entry (assoc (string-to-number (match-string 3)) alist))) 2024 (setcdr entry (string-to-number (match-string 1)))) 2025 (forward-line 1)) 2026 (gnus-agent-close-history) 2027 (setq changed-version t))) 2028 ((= version 1) 2029 (setq changed-version (not (= 1 gnus-agent-article-alist-save-format)))) 2030 ((= version 2) 2031 (let (uncomp) 2032 (mapcar 2033 (lambda (comp-list) 2034 (let ((state (car comp-list)) 2035 (sequence (inline 2036 (gnus-uncompress-range 2037 (cdr comp-list))))) 2038 (mapcar (lambda (article-id) 2039 (setq uncomp (cons (cons article-id state) uncomp))) 2040 sequence))) 2041 alist) 2042 (setq alist (sort uncomp 'car-less-than-car))) 2043 (setq changed-version (not (= 2 gnus-agent-article-alist-save-format))))) 2044 (when changed-version 2045 (let ((gnus-agent-article-alist alist)) 2046 (gnus-agent-save-alist gnus-agent-read-agentview))) 2047 alist)) 2048 (file-error nil)))) 2049 2050(defun gnus-agent-save-alist (group &optional articles state) 2051 "Save the article-state alist for GROUP." 2052 (let* ((file-name-coding-system nnmail-pathname-coding-system) 2053 (prev (cons nil gnus-agent-article-alist)) 2054 (all prev) 2055 print-level print-length item article) 2056 (while (setq article (pop articles)) 2057 (while (and (cdr prev) 2058 (< (caadr prev) article)) 2059 (setq prev (cdr prev))) 2060 (cond 2061 ((not (cdr prev)) 2062 (setcdr prev (list (cons article state)))) 2063 ((> (caadr prev) article) 2064 (setcdr prev (cons (cons article state) (cdr prev)))) 2065 ((= (caadr prev) article) 2066 (setcdr (cadr prev) state))) 2067 (setq prev (cdr prev))) 2068 (setq gnus-agent-article-alist (cdr all)) 2069 2070 (gnus-agent-set-local group 2071 (caar gnus-agent-article-alist) 2072 (caar (last gnus-agent-article-alist))) 2073 2074 (gnus-make-directory (gnus-agent-article-name "" group)) 2075 (with-temp-file (gnus-agent-article-name ".agentview" group) 2076 (cond ((eq gnus-agent-article-alist-save-format 1) 2077 (princ gnus-agent-article-alist (current-buffer))) 2078 ((eq gnus-agent-article-alist-save-format 2) 2079 (let ((compressed nil)) 2080 (mapcar (lambda (pair) 2081 (let* ((article-id (car pair)) 2082 (day-of-download (cdr pair)) 2083 (comp-list (assq day-of-download compressed))) 2084 (if comp-list 2085 (setcdr comp-list 2086 (cons article-id (cdr comp-list))) 2087 (setq compressed 2088 (cons (list day-of-download article-id) 2089 compressed))) 2090 nil)) gnus-agent-article-alist) 2091 (mapcar (lambda (comp-list) 2092 (setcdr comp-list 2093 (gnus-compress-sequence 2094 (nreverse (cdr comp-list))))) 2095 compressed) 2096 (princ compressed (current-buffer))))) 2097 (insert "\n") 2098 (princ gnus-agent-article-alist-save-format (current-buffer)) 2099 (insert "\n")))) 2100 2101(defvar gnus-agent-article-local nil) 2102(defvar gnus-agent-file-loading-local nil) 2103 2104(defun gnus-agent-load-local (&optional method) 2105 "Load the METHOD'S local file. The local file contains min/max 2106article counts for each of the method's subscribed groups." 2107 (let ((gnus-command-method (or method gnus-command-method))) 2108 (setq gnus-agent-article-local 2109 (gnus-cache-file-contents 2110 (gnus-agent-lib-file "local") 2111 'gnus-agent-file-loading-local 2112 'gnus-agent-read-and-cache-local)))) 2113 2114(defun gnus-agent-read-and-cache-local (file) 2115 "Load and read FILE then bind its contents to 2116gnus-agent-article-local. If that variable had `dirty' (also known as 2117modified) original contents, they are first saved to their own file." 2118 2119 (if (and gnus-agent-article-local 2120 (symbol-value (intern "+dirty" gnus-agent-article-local))) 2121 (gnus-agent-save-local)) 2122 (gnus-agent-read-local file)) 2123 2124(defun gnus-agent-read-local (file) 2125 "Load FILE and do a `read' there." 2126 (let ((my-obarray (gnus-make-hashtable (count-lines (point-min) 2127 (point-max)))) 2128 (line 1)) 2129 (with-temp-buffer 2130 (condition-case nil 2131 (let ((nnheader-file-coding-system gnus-agent-file-coding-system)) 2132 (nnheader-insert-file-contents file)) 2133 (file-error)) 2134 2135 (goto-char (point-min)) 2136 ;; Skip any comments at the beginning of the file (the only place where they may appear) 2137 (while (= (following-char) ?\;) 2138 (forward-line 1) 2139 (setq line (1+ line))) 2140 2141 (while (not (eobp)) 2142 (condition-case err 2143 (let (group 2144 min 2145 max 2146 (cur (current-buffer)) 2147 (obarray my-obarray)) 2148 (setq group (read cur) 2149 min (read cur) 2150 max (read cur)) 2151 2152 (when (stringp group) 2153 (setq group (intern group my-obarray))) 2154 2155 ;; NOTE: The '+ 0' ensure that min and max are both numerics. 2156 (set group (cons (+ 0 min) (+ 0 max)))) 2157 (error 2158 (gnus-message 3 "Warning - invalid agent local: %s on line %d: %s" 2159 file line (error-message-string err)))) 2160 (forward-line 1) 2161 (setq line (1+ line)))) 2162 2163 (set (intern "+dirty" my-obarray) nil) 2164 (set (intern "+method" my-obarray) gnus-command-method) 2165 my-obarray)) 2166 2167(defun gnus-agent-save-local (&optional force) 2168 "Save gnus-agent-article-local under it method's agent.lib directory." 2169 (let ((my-obarray gnus-agent-article-local)) 2170 (when (and my-obarray 2171 (or force (symbol-value (intern "+dirty" my-obarray)))) 2172 (let* ((gnus-command-method (symbol-value (intern "+method" my-obarray))) 2173 ;; NOTE: gnus-command-method is used within gnus-agent-lib-file. 2174 (dest (gnus-agent-lib-file "local"))) 2175 (gnus-make-directory (gnus-agent-lib-file "")) 2176 2177 (let ((buffer-file-coding-system gnus-agent-file-coding-system)) 2178 (with-temp-file dest 2179 (let ((gnus-command-method (symbol-value (intern "+method" my-obarray))) 2180 (file-name-coding-system nnmail-pathname-coding-system) 2181 print-level print-length item article 2182 (standard-output (current-buffer))) 2183 (mapatoms (lambda (symbol) 2184 (cond ((not (boundp symbol)) 2185 nil) 2186 ((member (symbol-name symbol) '("+dirty" "+method")) 2187 nil) 2188 (t 2189 (let ((range (symbol-value symbol))) 2190 (when range 2191 (prin1 symbol) 2192 (princ " ") 2193 (princ (car range)) 2194 (princ " ") 2195 (princ (cdr range)) 2196 (princ "\n")))))) 2197 my-obarray)))))))) 2198 2199(defun gnus-agent-get-local (group &optional gmane method) 2200 (let* ((gmane (or gmane (gnus-group-real-name group))) 2201 (gnus-command-method (or method (gnus-find-method-for-group group))) 2202 (local (gnus-agent-load-local)) 2203 (symb (intern gmane local)) 2204 (minmax (and (boundp symb) (symbol-value symb)))) 2205 (unless minmax 2206 ;; Bind these so that gnus-agent-load-alist doesn't change the 2207 ;; current alist (i.e. gnus-agent-article-alist) 2208 (let* ((gnus-agent-article-alist gnus-agent-article-alist) 2209 (gnus-agent-file-loading-cache gnus-agent-file-loading-cache) 2210 (alist (gnus-agent-load-alist group))) 2211 (when alist 2212 (setq minmax 2213 (cons (caar alist) 2214 (caar (last alist)))) 2215 (gnus-agent-set-local group (car minmax) (cdr minmax) 2216 gmane gnus-command-method local)))) 2217 minmax)) 2218 2219(defun gnus-agent-set-local (group min max &optional gmane method local) 2220 (let* ((gmane (or gmane (gnus-group-real-name group))) 2221 (gnus-command-method (or method (gnus-find-method-for-group group))) 2222 (local (or local (gnus-agent-load-local))) 2223 (symb (intern gmane local)) 2224 (minmax (and (boundp symb) (symbol-value symb)))) 2225 2226 (if (cond ((and minmax 2227 (or (not (eq min (car minmax))) 2228 (not (eq max (cdr minmax)))) 2229 min 2230 max) 2231 (setcar minmax min) 2232 (setcdr minmax max) 2233 t) 2234 (minmax 2235 nil) 2236 ((and min max) 2237 (set symb (cons min max)) 2238 t) 2239 (t 2240 (unintern symb local))) 2241 (set (intern "+dirty" local) t)))) 2242 2243(defun gnus-agent-article-name (article group) 2244 (expand-file-name article 2245 (file-name-as-directory 2246 (gnus-agent-group-pathname group)))) 2247 2248(defun gnus-agent-batch-confirmation (msg) 2249 "Show error message and return t." 2250 (gnus-message 1 msg) 2251 t) 2252 2253;;;###autoload 2254(defun gnus-agent-batch-fetch () 2255 "Start Gnus and fetch session." 2256 (interactive) 2257 (gnus) 2258 (let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation)) 2259 (gnus-agent-fetch-session)) 2260 (gnus-group-exit)) 2261 2262(defun gnus-agent-fetch-session () 2263 "Fetch all articles and headers that are eligible for fetching." 2264 (interactive) 2265 (unless gnus-agent-covered-methods 2266 (error "No servers are covered by the Gnus agent")) 2267 (unless gnus-plugged 2268 (error "Can't fetch articles while Gnus is unplugged")) 2269 (let ((methods (gnus-agent-covered-methods)) 2270 groups group gnus-command-method) 2271 (save-excursion 2272 (while methods 2273 (setq gnus-command-method (car methods)) 2274 (when (and (or (gnus-server-opened gnus-command-method) 2275 (gnus-open-server gnus-command-method)) 2276 (gnus-online gnus-command-method)) 2277 (setq groups (gnus-groups-from-server (car methods))) 2278 (gnus-agent-with-fetch 2279 (while (setq group (pop groups)) 2280 (when (<= (gnus-group-level group) 2281 gnus-agent-handle-level) 2282 (if (or debug-on-error debug-on-quit) 2283 (gnus-agent-fetch-group-1 2284 group gnus-command-method) 2285 (condition-case err 2286 (gnus-agent-fetch-group-1 2287 group gnus-command-method) 2288 (error 2289 (unless (funcall gnus-agent-confirmation-function 2290 (format "Error %s while fetching session. Should gnus continue? " 2291 (error-message-string err))) 2292 (error "Cannot fetch articles into the Gnus agent"))) 2293 (quit 2294 (gnus-agent-regenerate-group group) 2295 (unless (funcall gnus-agent-confirmation-function 2296 (format 2297 "%s while fetching session. Should gnus continue? " 2298 (error-message-string err))) 2299 (signal 'quit 2300 "Cannot fetch articles into the Gnus agent"))))))))) 2301 (setq methods (cdr methods))) 2302 (gnus-run-hooks 'gnus-agent-fetched-hook) 2303 (gnus-message 6 "Finished fetching articles into the Gnus agent")))) 2304 2305(defun gnus-agent-fetch-group-1 (group method) 2306 "Fetch GROUP." 2307 (let ((gnus-command-method method) 2308 (gnus-newsgroup-name group) 2309 (gnus-newsgroup-dependencies gnus-newsgroup-dependencies) 2310 (gnus-newsgroup-headers gnus-newsgroup-headers) 2311 (gnus-newsgroup-scored gnus-newsgroup-scored) 2312 (gnus-use-cache gnus-use-cache) 2313 (gnus-summary-expunge-below gnus-summary-expunge-below) 2314 (gnus-summary-mark-below gnus-summary-mark-below) 2315 (gnus-orphan-score gnus-orphan-score) 2316 ;; Maybe some other gnus-summary local variables should also 2317 ;; be put here. 2318 2319 gnus-headers 2320 gnus-score 2321 articles arts 2322 category predicate info marks score-param 2323 ) 2324 (unless (gnus-check-group group) 2325 (error "Can't open server for %s" group)) 2326 2327 ;; Fetch headers. 2328 (when (or gnus-newsgroup-active 2329 (gnus-active group) 2330 (gnus-activate-group group)) 2331 (let ((marked-articles gnus-newsgroup-downloadable)) 2332 ;; Identify the articles marked for download 2333 (unless gnus-newsgroup-active 2334 ;; The variable gnus-newsgroup-active was selected as I need 2335 ;; a gnus-summary local variable that is NOT bound to any 2336 ;; value (its global value should default to nil). 2337 (dolist (mark gnus-agent-download-marks) 2338 (let ((arts (cdr (assq mark (gnus-info-marks 2339 (setq info (gnus-get-info group))))))) 2340 (when arts 2341 (setq marked-articles (nconc (gnus-uncompress-range arts) 2342 marked-articles)) 2343 )))) 2344 (setq marked-articles (sort marked-articles '<)) 2345 2346 ;; Fetch any new articles from the server 2347 (setq articles (gnus-agent-fetch-headers group)) 2348 2349 ;; Merge new articles with marked 2350 (setq articles (sort (append marked-articles articles) '<)) 2351 2352 (when articles 2353 ;; Parse them and see which articles we want to fetch. 2354 (setq gnus-newsgroup-dependencies 2355 (or gnus-newsgroup-dependencies 2356 (make-vector (length articles) 0))) 2357 (setq gnus-newsgroup-headers 2358 (or gnus-newsgroup-headers 2359 (gnus-get-newsgroup-headers-xover articles nil nil 2360 group))) 2361 ;; `gnus-agent-overview-buffer' may be killed for 2362 ;; timeout reason. If so, recreate it. 2363 (gnus-agent-create-buffer) 2364 2365 ;; Figure out how to select articles in this group 2366 (setq category (gnus-group-category group)) 2367 2368 (setq predicate 2369 (gnus-get-predicate 2370 (gnus-agent-find-parameter group 'agent-predicate))) 2371 2372 ;; If the selection predicate requires scoring, score each header 2373 (unless (memq predicate '(gnus-agent-true gnus-agent-false)) 2374 (let ((score-param 2375 (gnus-agent-find-parameter group 'agent-score-file))) 2376 ;; Translate score-param into real one 2377 (cond 2378 ((not score-param)) 2379 ((eq score-param 'file) 2380 (setq score-param (gnus-all-score-files group))) 2381 ((stringp (car score-param))) 2382 (t 2383 (setq score-param (list (list score-param))))) 2384 (when score-param 2385 (gnus-score-headers score-param)))) 2386 2387 (unless (and (eq predicate 'gnus-agent-false) 2388 (not marked-articles)) 2389 (let ((arts (list nil))) 2390 (let ((arts-tail arts) 2391 (alist (gnus-agent-load-alist group)) 2392 (marked-articles marked-articles) 2393 (gnus-newsgroup-headers gnus-newsgroup-headers)) 2394 (while (setq gnus-headers (pop gnus-newsgroup-headers)) 2395 (let ((num (mail-header-number gnus-headers))) 2396 ;; Determine if this article is already in the cache 2397 (while (and alist 2398 (> num (caar alist))) 2399 (setq alist (cdr alist))) 2400 2401 (unless (and (eq num (caar alist)) 2402 (cdar alist)) 2403 2404 ;; Determine if this article was marked for download. 2405 (while (and marked-articles 2406 (> num (car marked-articles))) 2407 (setq marked-articles 2408 (cdr marked-articles))) 2409 2410 ;; When this article is marked, or selected by the 2411 ;; predicate, add it to the download list 2412 (when (or (eq num (car marked-articles)) 2413 (let ((gnus-score 2414 (or (cdr 2415 (assq num gnus-newsgroup-scored)) 2416 gnus-summary-default-score)) 2417 (gnus-agent-long-article 2418 (gnus-agent-find-parameter 2419 group 'agent-long-article)) 2420 (gnus-agent-short-article 2421 (gnus-agent-find-parameter 2422 group 'agent-short-article)) 2423 (gnus-agent-low-score 2424 (gnus-agent-find-parameter 2425 group 'agent-low-score)) 2426 (gnus-agent-high-score 2427 (gnus-agent-find-parameter 2428 group 'agent-high-score)) 2429 (gnus-agent-expire-days 2430 (gnus-agent-find-parameter 2431 group 'agent-days-until-old))) 2432 (funcall predicate))) 2433 (gnus-agent-append-to-list arts-tail num)))))) 2434 2435 (let (fetched-articles) 2436 ;; Fetch all selected articles 2437 (setq gnus-newsgroup-undownloaded 2438 (gnus-sorted-ndifference 2439 gnus-newsgroup-undownloaded 2440 (setq fetched-articles 2441 (if (cdr arts) 2442 (gnus-agent-fetch-articles group (cdr arts)) 2443 nil)))) 2444 2445 (let ((unfetched-articles 2446 (gnus-sorted-ndifference (cdr arts) fetched-articles))) 2447 (if gnus-newsgroup-active 2448 ;; Update the summary buffer 2449 (progn 2450 (dolist (article marked-articles) 2451 (gnus-summary-set-agent-mark article t)) 2452 (dolist (article fetched-articles) 2453 (when gnus-agent-mark-unread-after-downloaded 2454 (setq gnus-newsgroup-downloadable 2455 (delq article gnus-newsgroup-downloadable)) 2456 (gnus-summary-mark-article 2457 article gnus-unread-mark)) 2458 (when (gnus-summary-goto-subject article nil t) 2459 (gnus-summary-update-download-mark article))) 2460 (dolist (article unfetched-articles) 2461 (gnus-summary-mark-article 2462 article gnus-canceled-mark))) 2463 2464 ;; Update the group buffer. 2465 2466 ;; When some, or all, of the marked articles came 2467 ;; from the download mark. Remove that mark. I 2468 ;; didn't do this earlier as I only want to remove 2469 ;; the marks after the fetch is completed. 2470 2471 (dolist (mark gnus-agent-download-marks) 2472 (when (eq mark 'download) 2473 (let ((marked-arts 2474 (assq mark (gnus-info-marks 2475 (setq info (gnus-get-info group)))))) 2476 (when (cdr marked-arts) 2477 (setq marks 2478 (delq marked-arts (gnus-info-marks info))) 2479 (gnus-info-set-marks info marks))))) 2480 (let ((read (gnus-info-read 2481 (or info (setq info (gnus-get-info group)))))) 2482 (gnus-info-set-read 2483 info (gnus-add-to-range read unfetched-articles))) 2484 2485 (gnus-group-update-group group t) 2486 (sit-for 0) 2487 2488 (gnus-dribble-enter 2489 (concat "(gnus-group-set-info '" 2490 (gnus-prin1-to-string info) 2491 ")")))))))))))) 2492 2493;;; 2494;;; Agent Category Mode 2495;;; 2496 2497(defvar gnus-category-mode-hook nil 2498 "Hook run in `gnus-category-mode' buffers.") 2499 2500(defvar gnus-category-line-format " %(%20c%): %g\n" 2501 "Format of category lines. 2502 2503Valid specifiers include: 2504%c Topic name (string) 2505%g The number of groups in the topic (integer) 2506 2507General format specifiers can also be used. See Info node 2508`(gnus)Formatting Variables'.") 2509 2510(defvar gnus-category-mode-line-format "Gnus: %%b" 2511 "The format specification for the category mode line.") 2512 2513(defvar gnus-agent-predicate 'false 2514 "The selection predicate used when no other source is available.") 2515 2516(defvar gnus-agent-short-article 100 2517 "Articles that have fewer lines than this are short.") 2518 2519(defvar gnus-agent-long-article 200 2520 "Articles that have more lines than this are long.") 2521 2522(defvar gnus-agent-low-score 0 2523 "Articles that have a score lower than this have a low score.") 2524 2525(defvar gnus-agent-high-score 0 2526 "Articles that have a score higher than this have a high score.") 2527 2528 2529;;; Internal variables. 2530 2531(defvar gnus-category-buffer "*Agent Category*") 2532 2533(defvar gnus-category-line-format-alist 2534 `((?c gnus-tmp-name ?s) 2535 (?g gnus-tmp-groups ?d))) 2536 2537(defvar gnus-category-mode-line-format-alist 2538 `((?u user-defined ?s))) 2539 2540(defvar gnus-category-line-format-spec nil) 2541(defvar gnus-category-mode-line-format-spec nil) 2542 2543(defvar gnus-category-mode-map nil) 2544(put 'gnus-category-mode 'mode-class 'special) 2545 2546(unless gnus-category-mode-map 2547 (setq gnus-category-mode-map (make-sparse-keymap)) 2548 (suppress-keymap gnus-category-mode-map) 2549 2550 (gnus-define-keys gnus-category-mode-map 2551 "q" gnus-category-exit 2552 "k" gnus-category-kill 2553 "c" gnus-category-copy 2554 "a" gnus-category-add 2555 "e" gnus-agent-customize-category 2556 "p" gnus-category-edit-predicate 2557 "g" gnus-category-edit-groups 2558 "s" gnus-category-edit-score 2559 "l" gnus-category-list 2560 2561 "\C-c\C-i" gnus-info-find-node 2562 "\C-c\C-b" gnus-bug)) 2563 2564(defvar gnus-category-menu-hook nil 2565 "*Hook run after the creation of the menu.") 2566 2567(defun gnus-category-make-menu-bar () 2568 (gnus-turn-off-edit-menu 'category) 2569 (unless (boundp 'gnus-category-menu) 2570 (easy-menu-define 2571 gnus-category-menu gnus-category-mode-map "" 2572 '("Categories" 2573 ["Add" gnus-category-add t] 2574 ["Kill" gnus-category-kill t] 2575 ["Copy" gnus-category-copy t] 2576 ["Edit category" gnus-agent-customize-category t] 2577 ["Edit predicate" gnus-category-edit-predicate t] 2578 ["Edit score" gnus-category-edit-score t] 2579 ["Edit groups" gnus-category-edit-groups t] 2580 ["Exit" gnus-category-exit t])) 2581 2582 (gnus-run-hooks 'gnus-category-menu-hook))) 2583 2584(defun gnus-category-mode () 2585 "Major mode for listing and editing agent categories. 2586 2587All normal editing commands are switched off. 2588\\<gnus-category-mode-map> 2589For more in-depth information on this mode, read the manual 2590\(`\\[gnus-info-find-node]'). 2591 2592The following commands are available: 2593 2594\\{gnus-category-mode-map}" 2595 (interactive) 2596 (when (gnus-visual-p 'category-menu 'menu) 2597 (gnus-category-make-menu-bar)) 2598 (kill-all-local-variables) 2599 (gnus-simplify-mode-line) 2600 (setq major-mode 'gnus-category-mode) 2601 (setq mode-name "Category") 2602 (gnus-set-default-directory) 2603 (setq mode-line-process nil) 2604 (use-local-map gnus-category-mode-map) 2605 (buffer-disable-undo) 2606 (setq truncate-lines t) 2607 (setq buffer-read-only t) 2608 (gnus-run-mode-hooks 'gnus-category-mode-hook)) 2609 2610(defalias 'gnus-category-position-point 'gnus-goto-colon) 2611 2612(defun gnus-category-insert-line (category) 2613 (let* ((gnus-tmp-name (format "%s" (car category))) 2614 (gnus-tmp-groups (length (gnus-agent-cat-groups category)))) 2615 (beginning-of-line) 2616 (gnus-add-text-properties 2617 (point) 2618 (prog1 (1+ (point)) 2619 ;; Insert the text. 2620 (eval gnus-category-line-format-spec)) 2621 (list 'gnus-category gnus-tmp-name)))) 2622 2623(defun gnus-enter-category-buffer () 2624 "Go to the Category buffer." 2625 (interactive) 2626 (gnus-category-setup-buffer) 2627 (gnus-configure-windows 'category) 2628 (gnus-category-prepare)) 2629 2630(defun gnus-category-setup-buffer () 2631 (unless (get-buffer gnus-category-buffer) 2632 (save-excursion 2633 (set-buffer (gnus-get-buffer-create gnus-category-buffer)) 2634 (gnus-category-mode)))) 2635 2636(defun gnus-category-prepare () 2637 (gnus-set-format 'category-mode) 2638 (gnus-set-format 'category t) 2639 (let ((alist gnus-category-alist) 2640 (buffer-read-only nil)) 2641 (erase-buffer) 2642 (while alist 2643 (gnus-category-insert-line (pop alist))) 2644 (goto-char (point-min)) 2645 (gnus-category-position-point))) 2646 2647(defun gnus-category-name () 2648 (or (intern (get-text-property (gnus-point-at-bol) 'gnus-category)) 2649 (error "No category on the current line"))) 2650 2651(defun gnus-category-read () 2652 "Read the category alist." 2653 (setq gnus-category-alist 2654 (or 2655 (with-temp-buffer 2656 (ignore-errors 2657 (nnheader-insert-file-contents (nnheader-concat gnus-agent-directory "lib/categories")) 2658 (goto-char (point-min)) 2659 ;; This code isn't temp, it will be needed so long as 2660 ;; anyone may be migrating from an older version. 2661 2662 ;; Once we're certain that people will not revert to an 2663 ;; earlier version, we can take out the old-list code in 2664 ;; gnus-category-write. 2665 (let* ((old-list (read (current-buffer))) 2666 (new-list (ignore-errors (read (current-buffer))))) 2667 (if new-list 2668 new-list 2669 ;; Convert from a positional list to an alist. 2670 (mapcar 2671 (lambda (c) 2672 (setcdr c 2673 (delq nil 2674 (gnus-mapcar 2675 (lambda (valu symb) 2676 (if valu 2677 (cons symb valu))) 2678 (cdr c) 2679 '(agent-predicate agent-score-file agent-groups)))) 2680 c) 2681 old-list))))) 2682 (list (gnus-agent-cat-make 'default 'short))))) 2683 2684(defun gnus-category-write () 2685 "Write the category alist." 2686 (setq gnus-category-predicate-cache nil 2687 gnus-category-group-cache nil) 2688 (gnus-make-directory (nnheader-concat gnus-agent-directory "lib")) 2689 (with-temp-file (nnheader-concat gnus-agent-directory "lib/categories") 2690 ;; This prin1 is temporary. It exists so that people can revert 2691 ;; to an earlier version of gnus-agent. 2692 (prin1 (mapcar (lambda (c) 2693 (list (car c) 2694 (cdr (assoc 'agent-predicate c)) 2695 (cdr (assoc 'agent-score-file c)) 2696 (cdr (assoc 'agent-groups c)))) 2697 gnus-category-alist) 2698 (current-buffer)) 2699 (newline) 2700 (prin1 gnus-category-alist (current-buffer)))) 2701 2702(defun gnus-category-edit-predicate (category) 2703 "Edit the predicate for CATEGORY." 2704 (interactive (list (gnus-category-name))) 2705 (let ((info (assq category gnus-category-alist))) 2706 (gnus-edit-form 2707 (gnus-agent-cat-predicate info) 2708 (format "Editing the select predicate for category %s" category) 2709 `(lambda (predicate) 2710 ;; Avoid run-time execution of setf form 2711 ;; (setf (gnus-agent-cat-predicate (assq ',category gnus-category-alist)) 2712 ;; predicate) 2713 ;; use its expansion instead: 2714 (gnus-agent-cat-set-property (assq ',category gnus-category-alist) 2715 'agent-predicate predicate) 2716 2717 (gnus-category-write) 2718 (gnus-category-list))))) 2719 2720(defun gnus-category-edit-score (category) 2721 "Edit the score expression for CATEGORY." 2722 (interactive (list (gnus-category-name))) 2723 (let ((info (assq category gnus-category-alist))) 2724 (gnus-edit-form 2725 (gnus-agent-cat-score-file info) 2726 (format "Editing the score expression for category %s" category) 2727 `(lambda (score-file) 2728 ;; Avoid run-time execution of setf form 2729 ;; (setf (gnus-agent-cat-score-file (assq ',category gnus-category-alist)) 2730 ;; score-file) 2731 ;; use its expansion instead: 2732 (gnus-agent-cat-set-property (assq ',category gnus-category-alist) 2733 'agent-score-file score-file) 2734 2735 (gnus-category-write) 2736 (gnus-category-list))))) 2737 2738(defun gnus-category-edit-groups (category) 2739 "Edit the group list for CATEGORY." 2740 (interactive (list (gnus-category-name))) 2741 (let ((info (assq category gnus-category-alist))) 2742 (gnus-edit-form 2743 (gnus-agent-cat-groups info) 2744 (format "Editing the group list for category %s" category) 2745 `(lambda (groups) 2746 ;; Avoid run-time execution of setf form 2747 ;; (setf (gnus-agent-cat-groups (assq ',category gnus-category-alist)) 2748 ;; groups) 2749 ;; use its expansion instead: 2750 (gnus-agent-set-cat-groups (assq ',category gnus-category-alist) 2751 groups) 2752 2753 (gnus-category-write) 2754 (gnus-category-list))))) 2755 2756(defun gnus-category-kill (category) 2757 "Kill the current category." 2758 (interactive (list (gnus-category-name))) 2759 (let ((info (assq category gnus-category-alist)) 2760 (buffer-read-only nil)) 2761 (gnus-delete-line) 2762 (setq gnus-category-alist (delq info gnus-category-alist)) 2763 (gnus-category-write))) 2764 2765(defun gnus-category-copy (category to) 2766 "Copy the current category." 2767 (interactive (list (gnus-category-name) (intern (read-string "New name: ")))) 2768 (let ((info (assq category gnus-category-alist))) 2769 (push (let ((newcat (gnus-copy-sequence info))) 2770 (setf (gnus-agent-cat-name newcat) to) 2771 (setf (gnus-agent-cat-groups newcat) nil) 2772 newcat) 2773 gnus-category-alist) 2774 (gnus-category-write) 2775 (gnus-category-list))) 2776 2777(defun gnus-category-add (category) 2778 "Create a new category." 2779 (interactive "SCategory name: ") 2780 (when (assq category gnus-category-alist) 2781 (error "Category %s already exists" category)) 2782 (push (gnus-agent-cat-make category) 2783 gnus-category-alist) 2784 (gnus-category-write) 2785 (gnus-category-list)) 2786 2787(defun gnus-category-list () 2788 "List all categories." 2789 (interactive) 2790 (gnus-category-prepare)) 2791 2792(defun gnus-category-exit () 2793 "Return to the group buffer." 2794 (interactive) 2795 (kill-buffer (current-buffer)) 2796 (gnus-configure-windows 'group t)) 2797 2798;; To avoid having 8-bit characters in the source file. 2799(defvar gnus-category-not (list '! 'not (intern (format "%c" 172)))) 2800 2801(defvar gnus-category-predicate-alist 2802 '((spam . gnus-agent-spam-p) 2803 (short . gnus-agent-short-p) 2804 (long . gnus-agent-long-p) 2805 (low . gnus-agent-low-scored-p) 2806 (high . gnus-agent-high-scored-p) 2807 (read . gnus-agent-read-p) 2808 (true . gnus-agent-true) 2809 (false . gnus-agent-false)) 2810 "Mapping from short score predicate symbols to predicate functions.") 2811 2812(defun gnus-agent-spam-p () 2813 "Say whether an article is spam or not." 2814 (unless gnus-agent-spam-hashtb 2815 (setq gnus-agent-spam-hashtb (gnus-make-hashtable 1000))) 2816 (if (not (equal (mail-header-references gnus-headers) "")) 2817 nil 2818 (let ((string (gnus-simplify-subject (mail-header-subject gnus-headers)))) 2819 (prog1 2820 (gnus-gethash string gnus-agent-spam-hashtb) 2821 (gnus-sethash string t gnus-agent-spam-hashtb))))) 2822 2823(defun gnus-agent-short-p () 2824 "Say whether an article is short or not." 2825 (< (mail-header-lines gnus-headers) gnus-agent-short-article)) 2826 2827(defun gnus-agent-long-p () 2828 "Say whether an article is long or not." 2829 (> (mail-header-lines gnus-headers) gnus-agent-long-article)) 2830 2831(defun gnus-agent-low-scored-p () 2832 "Say whether an article has a low score or not." 2833 (< gnus-score gnus-agent-low-score)) 2834 2835(defun gnus-agent-high-scored-p () 2836 "Say whether an article has a high score or not." 2837 (> gnus-score gnus-agent-high-score)) 2838 2839(defun gnus-agent-read-p () 2840 "Say whether an article is read or not." 2841 (gnus-member-of-range (mail-header-number gnus-headers) 2842 (gnus-info-read (gnus-get-info gnus-newsgroup-name)))) 2843 2844(defun gnus-category-make-function (predicate) 2845 "Make a function from PREDICATE." 2846 (let ((func (gnus-category-make-function-1 predicate))) 2847 (if (and (= (length func) 1) 2848 (symbolp (car func))) 2849 (car func) 2850 (gnus-byte-compile `(lambda () ,func))))) 2851 2852(defun gnus-agent-true () 2853 "Return t." 2854 t) 2855 2856(defun gnus-agent-false () 2857 "Return nil." 2858 nil) 2859 2860(defun gnus-category-make-function-1 (predicate) 2861 "Make a function from PREDICATE." 2862 (cond 2863 ;; Functions are just returned as is. 2864 ((or (symbolp predicate) 2865 (functionp predicate)) 2866 `(,(or (cdr (assq predicate gnus-category-predicate-alist)) 2867 predicate))) 2868 ;; More complex predicate. 2869 ((consp predicate) 2870 `(,(cond 2871 ((memq (car predicate) '(& and)) 2872 'and) 2873 ((memq (car predicate) '(| or)) 2874 'or) 2875 ((memq (car predicate) gnus-category-not) 2876 'not)) 2877 ,@(mapcar 'gnus-category-make-function-1 (cdr predicate)))) 2878 (t 2879 (error "Unknown predicate type: %s" predicate)))) 2880 2881(defun gnus-get-predicate (predicate) 2882 "Return the function implementing PREDICATE." 2883 (or (cdr (assoc predicate gnus-category-predicate-cache)) 2884 (let ((func (gnus-category-make-function predicate))) 2885 (setq gnus-category-predicate-cache 2886 (nconc gnus-category-predicate-cache 2887 (list (cons predicate func)))) 2888 func))) 2889 2890(defun gnus-predicate-implies-unread (predicate) 2891 "Say whether PREDICATE implies unread articles only. 2892It is okay to miss some cases, but there must be no false positives. 2893That is, if this predicate returns true, then indeed the predicate must 2894return only unread articles." 2895 (eq t (gnus-function-implies-unread-1 2896 (gnus-category-make-function-1 predicate)))) 2897 2898(defun gnus-function-implies-unread-1 (function) 2899 "Recursively evaluate a predicate function to determine whether it can select 2900any read articles. Returns t if the function is known to never 2901return read articles, nil when it is known to always return read 2902articles, and t_nil when the function may return both read and unread 2903articles." 2904 (let ((func (car function)) 2905 (args (mapcar 'gnus-function-implies-unread-1 (cdr function)))) 2906 (cond ((eq func 'and) 2907 (cond ((memq t args) ; if any argument returns only unread articles 2908 ;; then that argument constrains the result to only unread articles. 2909 t) 2910 ((memq 't_nil args) ; if any argument is indeterminate 2911 ;; then the result is indeterminate 2912 't_nil))) 2913 ((eq func 'or) 2914 (cond ((memq nil args) ; if any argument returns read articles 2915 ;; then that argument ensures that the results includes read articles. 2916 nil) 2917 ((memq 't_nil args) ; if any argument is indeterminate 2918 ;; then that argument ensures that the results are indeterminate 2919 't_nil) 2920 (t ; if all arguments return only unread articles 2921 ;; then the result returns only unread articles 2922 t))) 2923 ((eq func 'not) 2924 (cond ((eq (car args) 't_nil) ; if the argument is indeterminate 2925 ; then the result is indeterminate 2926 (car args)) 2927 (t ; otherwise 2928 ; toggle the result to be the opposite of the argument 2929 (not (car args))))) 2930 ((eq func 'gnus-agent-read-p) 2931 nil) ; The read predicate NEVER returns unread articles 2932 ((eq func 'gnus-agent-false) 2933 t) ; The false predicate returns t as the empty set excludes all read articles 2934 ((eq func 'gnus-agent-true) 2935 nil) ; The true predicate ALWAYS returns read articles 2936 ((catch 'found-match 2937 (let ((alist gnus-category-predicate-alist)) 2938 (while alist 2939 (if (eq func (cdar alist)) 2940 (throw 'found-match t) 2941 (setq alist (cdr alist)))))) 2942 't_nil) ; All other predicates return read and unread articles 2943 (t 2944 (error "Unknown predicate function: %s" function))))) 2945 2946(defun gnus-group-category (group) 2947 "Return the category GROUP belongs to." 2948 (unless gnus-category-group-cache 2949 (setq gnus-category-group-cache (gnus-make-hashtable 1000)) 2950 (let ((cs gnus-category-alist) 2951 groups cat) 2952 (while (setq cat (pop cs)) 2953 (setq groups (gnus-agent-cat-groups cat)) 2954 (while groups 2955 (gnus-sethash (pop groups) cat gnus-category-group-cache))))) 2956 (or (gnus-gethash group gnus-category-group-cache) 2957 (assq 'default gnus-category-alist))) 2958 2959(defun gnus-agent-expire-group (group &optional articles force) 2960 "Expire all old articles in GROUP. 2961If you want to force expiring of certain articles, this function can 2962take ARTICLES, and FORCE parameters as well. 2963 2964The articles on which the expiration process runs are selected as follows: 2965 if ARTICLES is null, all read and unmarked articles. 2966 if ARTICLES is t, all articles. 2967 if ARTICLES is a list, just those articles. 2968FORCE is equivalent to setting the expiration predicates to true." 2969 (interactive 2970 (list (let ((def (or (gnus-group-group-name) 2971 gnus-newsgroup-name))) 2972 (let ((select (read-string (if def 2973 (concat "Group Name (" 2974 def "): ") 2975 "Group Name: ")))) 2976 (if (and (equal "" select) 2977 def) 2978 def 2979 select))))) 2980 2981 (if (not group) 2982 (gnus-agent-expire articles group force) 2983 (let ( ;; Bind gnus-agent-expire-stats to enable tracking of 2984 ;; expiration statistics of this single group 2985 (gnus-agent-expire-stats (list 0 0 0.0))) 2986 (if (or (not (eq articles t)) 2987 (yes-or-no-p 2988 (concat "Are you sure that you want to " 2989 "expire all articles in " group "? "))) 2990 (let ((gnus-command-method (gnus-find-method-for-group group)) 2991 (overview (gnus-get-buffer-create " *expire overview*")) 2992 orig) 2993 (unwind-protect 2994 (let ((active-file (gnus-agent-lib-file "active"))) 2995 (when (file-exists-p active-file) 2996 (with-temp-buffer 2997 (nnheader-insert-file-contents active-file) 2998 (gnus-active-to-gnus-format 2999 gnus-command-method 3000 (setq orig (gnus-make-hashtable 3001 (count-lines (point-min) (point-max)))))) 3002 (save-excursion 3003 (gnus-agent-expire-group-1 3004 group overview (gnus-gethash-safe group orig) 3005 articles force)))) 3006 (kill-buffer overview)))) 3007 (gnus-message 4 (gnus-agent-expire-done-message))))) 3008 3009(defun gnus-agent-expire-group-1 (group overview active articles force) 3010 ;; Internal function - requires caller to have set 3011 ;; gnus-command-method, initialized overview buffer, and to have 3012 ;; provided a non-nil active 3013 3014 (let ((dir (gnus-agent-group-pathname group))) 3015 (when (boundp 'gnus-agent-expire-current-dirs) 3016 (set 'gnus-agent-expire-current-dirs 3017 (cons dir 3018 (symbol-value 'gnus-agent-expire-current-dirs)))) 3019 3020 (if (and (not force) 3021 (eq 'DISABLE (gnus-agent-find-parameter group 3022 'agent-enable-expiration))) 3023 (gnus-message 5 "Expiry skipping over %s" group) 3024 (gnus-message 5 "Expiring articles in %s" group) 3025 (gnus-agent-load-alist group) 3026 (let* ((bytes-freed 0) 3027 (files-deleted 0) 3028 (nov-entries-deleted 0) 3029 (info (gnus-get-info group)) 3030 (alist gnus-agent-article-alist) 3031 (day (- (time-to-days (current-time)) 3032 (gnus-agent-find-parameter group 'agent-days-until-old))) 3033 (specials (if (and alist 3034 (not force)) 3035 ;; This could be a bit of a problem. I need to 3036 ;; keep the last article to avoid refetching 3037 ;; headers when using nntp in the backend. At 3038 ;; the same time, if someone uses a backend 3039 ;; that supports article moving then I may have 3040 ;; to remove the last article to complete the 3041 ;; move. Right now, I'm going to assume that 3042 ;; FORCE overrides specials. 3043 (list (caar (last alist))))) 3044 (unreads ;; Articles that are excluded from the 3045 ;; expiration process 3046 (cond (gnus-agent-expire-all 3047 ;; All articles are marked read by global decree 3048 nil) 3049 ((eq articles t) 3050 ;; All articles are marked read by function 3051 ;; parameter 3052 nil) 3053 ((not articles) 3054 ;; Unread articles are marked protected from 3055 ;; expiration Don't call 3056 ;; gnus-list-of-unread-articles as it returns 3057 ;; articles that have not been fetched into the 3058 ;; agent. 3059 (ignore-errors 3060 (gnus-agent-unread-articles group))) 3061 (t 3062 ;; All articles EXCEPT those named by the caller 3063 ;; are protected from expiration 3064 (gnus-sorted-difference 3065 (gnus-uncompress-range 3066 (cons (caar alist) 3067 (caar (last alist)))) 3068 (sort articles '<))))) 3069 (marked ;; More articles that are excluded from the 3070 ;; expiration process 3071 (cond (gnus-agent-expire-all 3072 ;; All articles are unmarked by global decree 3073 nil) 3074 ((eq articles t) 3075 ;; All articles are unmarked by function 3076 ;; parameter 3077 nil) 3078 (articles 3079 ;; All articles may as well be unmarked as the 3080 ;; unreads list already names the articles we are 3081 ;; going to keep 3082 nil) 3083 (t 3084 ;; Ticked and/or dormant articles are excluded 3085 ;; from expiration 3086 (nconc 3087 (gnus-uncompress-range 3088 (cdr (assq 'tick (gnus-info-marks info)))) 3089 (gnus-uncompress-range 3090 (cdr (assq 'dormant 3091 (gnus-info-marks info)))))))) 3092 (nov-file (concat dir ".overview")) 3093 (cnt 0) 3094 (completed -1) 3095 dlist 3096 type) 3097 3098 ;; The normal article alist contains elements that look like 3099 ;; (article# . fetch_date) I need to combine other 3100 ;; information with this list. For example, a flag indicating 3101 ;; that a particular article MUST BE KEPT. To do this, I'm 3102 ;; going to transform the elements to look like (article# 3103 ;; fetch_date keep_flag NOV_entry_marker) Later, I'll reverse 3104 ;; the process to generate the expired article alist. 3105 3106 ;; Convert the alist elements to (article# fetch_date nil 3107 ;; nil). 3108 (setq dlist (mapcar (lambda (e) 3109 (list (car e) (cdr e) nil nil)) alist)) 3110 3111 ;; Convert the keep lists to elements that look like (article# 3112 ;; nil keep_flag nil) then append it to the expanded dlist 3113 ;; These statements are sorted by ascending precidence of the 3114 ;; keep_flag. 3115 (setq dlist (nconc dlist 3116 (mapcar (lambda (e) 3117 (list e nil 'unread nil)) 3118 unreads))) 3119 (setq dlist (nconc dlist 3120 (mapcar (lambda (e) 3121 (list e nil 'marked nil)) 3122 marked))) 3123 (setq dlist (nconc dlist 3124 (mapcar (lambda (e) 3125 (list e nil 'special nil)) 3126 specials))) 3127 3128 (set-buffer overview) 3129 (erase-buffer) 3130 (buffer-disable-undo) 3131 (when (file-exists-p nov-file) 3132 (gnus-message 7 "gnus-agent-expire: Loading overview...") 3133 (nnheader-insert-file-contents nov-file) 3134 (goto-char (point-min)) 3135 3136 (let (p) 3137 (while (< (setq p (point)) (point-max)) 3138 (condition-case nil 3139 ;; If I successfully read an integer (the plus zero 3140 ;; ensures a numeric type), prepend a marker entry 3141 ;; to the list 3142 (push (list (+ 0 (read (current-buffer))) nil nil 3143 (set-marker (make-marker) p)) 3144 dlist) 3145 (error 3146 (gnus-message 1 "gnus-agent-expire: read error \ 3147occurred when reading expression at %s in %s. Skipping to next \ 3148line." (point) nov-file))) 3149 ;; Whether I succeeded, or failed, it doesn't matter. 3150 ;; Move to the next line then try again. 3151 (forward-line 1))) 3152 3153 (gnus-message 3154 7 "gnus-agent-expire: Loading overview... Done")) 3155 (set-buffer-modified-p nil) 3156 3157 ;; At this point, all of the information is in dlist. The 3158 ;; only problem is that much of it is spread across multiple 3159 ;; entries. Sort then MERGE!! 3160 (gnus-message 7 "gnus-agent-expire: Sorting entries... ") 3161 ;; If two entries have the same article-number then sort by 3162 ;; ascending keep_flag. 3163 (let ((special 0) 3164 (marked 1) 3165 (unread 2)) 3166 (setq dlist 3167 (sort dlist 3168 (lambda (a b) 3169 (cond ((< (nth 0 a) (nth 0 b)) 3170 t) 3171 ((> (nth 0 a) (nth 0 b)) 3172 nil) 3173 (t 3174 (let ((a (or (symbol-value (nth 2 a)) 3175 3)) 3176 (b (or (symbol-value (nth 2 b)) 3177 3))) 3178 (<= a b)))))))) 3179 (gnus-message 7 "gnus-agent-expire: Sorting entries... Done") 3180 (gnus-message 7 "gnus-agent-expire: Merging entries... ") 3181 (let ((dlist dlist)) 3182 (while (cdr dlist) ; I'm not at the end-of-list 3183 (if (eq (caar dlist) (caadr dlist)) 3184 (let ((first (cdr (car dlist))) 3185 (secnd (cdr (cadr dlist)))) 3186 (setcar first (or (car first) 3187 (car secnd))) ; fetch_date 3188 (setq first (cdr first) 3189 secnd (cdr secnd)) 3190 (setcar first (or (car first) 3191 (car secnd))) ; Keep_flag 3192 (setq first (cdr first) 3193 secnd (cdr secnd)) 3194 (setcar first (or (car first) 3195 (car secnd))) ; NOV_entry_marker 3196 3197 (setcdr dlist (cddr dlist))) 3198 (setq dlist (cdr dlist))))) 3199 (gnus-message 7 "gnus-agent-expire: Merging entries... Done") 3200 3201 (let* ((len (float (length dlist))) 3202 (alist (list nil)) 3203 (tail-alist alist)) 3204 (while dlist 3205 (let ((new-completed (truncate (* 100.0 3206 (/ (setq cnt (1+ cnt)) 3207 len)))) 3208 message-log-max) 3209 (when (> new-completed completed) 3210 (setq completed new-completed) 3211 (gnus-message 7 "%3d%% completed..." completed))) 3212 (let* ((entry (car dlist)) 3213 (article-number (nth 0 entry)) 3214 (fetch-date (nth 1 entry)) 3215 (keep (nth 2 entry)) 3216 (marker (nth 3 entry))) 3217 3218 (cond 3219 ;; Kept articles are unread, marked, or special. 3220 (keep 3221 (gnus-agent-message 10 3222 "gnus-agent-expire: %s:%d: Kept %s article%s." 3223 group article-number keep (if fetch-date " and file" "")) 3224 (when fetch-date 3225 (unless (file-exists-p 3226 (concat dir (number-to-string 3227 article-number))) 3228 (setf (nth 1 entry) nil) 3229 (gnus-agent-message 3 "gnus-agent-expire cleared \ 3230download flag on %s:%d as the cached article file is missing." 3231 group (caar dlist))) 3232 (unless marker 3233 (gnus-message 1 "gnus-agent-expire detected a \ 3234missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) 3235 (gnus-agent-append-to-list 3236 tail-alist 3237 (cons article-number fetch-date))) 3238 3239 ;; The following articles are READ, UNMARKED, and 3240 ;; ORDINARY. See if they can be EXPIRED!!! 3241 ((setq type 3242 (cond 3243 ((not (integerp fetch-date)) 3244 'read) ;; never fetched article (may expire 3245 ;; right now) 3246 ((not (file-exists-p 3247 (concat dir (number-to-string 3248 article-number)))) 3249 (setf (nth 1 entry) nil) 3250 'externally-expired) ;; Can't find the cached 3251 ;; article. Handle case 3252 ;; as though this article 3253 ;; was never fetched. 3254 3255 ;; We now have the arrival day, so we see 3256 ;; whether it's old enough to be expired. 3257 ((< fetch-date day) 3258 'expired) 3259 (force 3260 'forced))) 3261 3262 ;; I found some reason to expire this entry. 3263 3264 (let ((actions nil)) 3265 (when (memq type '(forced expired)) 3266 (ignore-errors ; Just being paranoid. 3267 (let* ((file-name (nnheader-concat dir (number-to-string 3268 article-number))) 3269 (size (float (nth 7 (file-attributes file-name))))) 3270 (incf bytes-freed size) 3271 (incf files-deleted) 3272 (delete-file file-name)) 3273 (push "expired cached article" actions)) 3274 (setf (nth 1 entry) nil) 3275 ) 3276 3277 (when marker 3278 (push "NOV entry removed" actions) 3279 (goto-char marker) 3280 3281 (incf nov-entries-deleted) 3282 3283 (let ((from (gnus-point-at-bol)) 3284 (to (progn (forward-line 1) (point)))) 3285 (incf bytes-freed (- to from)) 3286 (delete-region from to))) 3287 3288 ;; If considering all articles is set, I can only 3289 ;; expire article IDs that are no longer in the 3290 ;; active range (That is, articles that preceed the 3291 ;; first article in the new alist). 3292 (if (and gnus-agent-consider-all-articles 3293 (>= article-number (car active))) 3294 ;; I have to keep this ID in the alist 3295 (gnus-agent-append-to-list 3296 tail-alist (cons article-number fetch-date)) 3297 (push (format "Removed %s article number from \ 3298article alist" type) actions)) 3299 3300 (when actions 3301 (gnus-agent-message 8 "gnus-agent-expire: %s:%d: %s" 3302 group article-number 3303 (mapconcat 'identity actions ", "))))) 3304 (t 3305 (gnus-agent-message 3306 10 "gnus-agent-expire: %s:%d: Article kept as \ 3307expiration tests failed." group article-number) 3308 (gnus-agent-append-to-list 3309 tail-alist (cons article-number fetch-date))) 3310 ) 3311 3312 ;; Clean up markers as I want to recycle this buffer 3313 ;; over several groups. 3314 (when marker 3315 (set-marker marker nil)) 3316 3317 (setq dlist (cdr dlist)))) 3318 3319 (setq alist (cdr alist)) 3320 3321 (let ((inhibit-quit t)) 3322 (unless (equal alist gnus-agent-article-alist) 3323 (setq gnus-agent-article-alist alist) 3324 (gnus-agent-save-alist group)) 3325 3326 (when (buffer-modified-p) 3327 (let ((coding-system-for-write 3328 gnus-agent-file-coding-system)) 3329 (gnus-make-directory dir) 3330 (write-region (point-min) (point-max) nov-file nil 3331 'silent) 3332 ;; clear the modified flag as that I'm not confused by 3333 ;; its status on the next pass through this routine. 3334 (set-buffer-modified-p nil))) 3335 3336 (when (eq articles t) 3337 (gnus-summary-update-info)))) 3338 3339 (when (boundp 'gnus-agent-expire-stats) 3340 (let ((stats (symbol-value 'gnus-agent-expire-stats))) 3341 (incf (nth 2 stats) bytes-freed) 3342 (incf (nth 1 stats) files-deleted) 3343 (incf (nth 0 stats) nov-entries-deleted))) 3344 )))) 3345 3346(defun gnus-agent-expire (&optional articles group force) 3347 "Expire all old articles. 3348If you want to force expiring of certain articles, this function can 3349take ARTICLES, GROUP and FORCE parameters as well. 3350 3351The articles on which the expiration process runs are selected as follows: 3352 if ARTICLES is null, all read and unmarked articles. 3353 if ARTICLES is t, all articles. 3354 if ARTICLES is a list, just those articles. 3355Setting GROUP will limit expiration to that group. 3356FORCE is equivalent to setting the expiration predicates to true." 3357 (interactive) 3358 3359 (if group 3360 (gnus-agent-expire-group group articles force) 3361 (if (or (not (eq articles t)) 3362 (yes-or-no-p "Are you sure that you want to expire all \ 3363articles in every agentized group? ")) 3364 (let ((methods (gnus-agent-covered-methods)) 3365 ;; Bind gnus-agent-expire-current-dirs to enable tracking 3366 ;; of agent directories. 3367 (gnus-agent-expire-current-dirs nil) 3368 ;; Bind gnus-agent-expire-stats to enable tracking of 3369 ;; expiration statistics across all groups 3370 (gnus-agent-expire-stats (list 0 0 0.0)) 3371 gnus-command-method overview orig) 3372 (setq overview (gnus-get-buffer-create " *expire overview*")) 3373 (unwind-protect 3374 (while (setq gnus-command-method (pop methods)) 3375 (let ((active-file (gnus-agent-lib-file "active"))) 3376 (when (file-exists-p active-file) 3377 (with-temp-buffer 3378 (nnheader-insert-file-contents active-file) 3379 (gnus-active-to-gnus-format 3380 gnus-command-method 3381 (setq orig (gnus-make-hashtable 3382 (count-lines (point-min) (point-max)))))) 3383 (dolist (expiring-group (gnus-groups-from-server 3384 gnus-command-method)) 3385 (let* ((active 3386 (gnus-gethash-safe expiring-group orig))) 3387 3388 (when active 3389 (save-excursion 3390 (gnus-agent-expire-group-1 3391 expiring-group overview active articles force)))))))) 3392 (kill-buffer overview)) 3393 (gnus-agent-expire-unagentized-dirs) 3394 (gnus-message 4 (gnus-agent-expire-done-message)))))) 3395 3396(defun gnus-agent-expire-done-message () 3397 (if (and (> gnus-verbose 4) 3398 (boundp 'gnus-agent-expire-stats)) 3399 (let* ((stats (symbol-value 'gnus-agent-expire-stats)) 3400 (size (nth 2 stats)) 3401 (units '(B KB MB GB))) 3402 (while (and (> size 1024.0) 3403 (cdr units)) 3404 (setq size (/ size 1024.0) 3405 units (cdr units))) 3406 3407 (format "Expiry recovered %d NOV entries, deleted %d files,\ 3408 and freed %f %s." 3409 (nth 0 stats) 3410 (nth 1 stats) 3411 size (car units))) 3412 "Expiry...done")) 3413 3414(defun gnus-agent-expire-unagentized-dirs () 3415 (when (and gnus-agent-expire-unagentized-dirs 3416 (boundp 'gnus-agent-expire-current-dirs)) 3417 (let* ((keep (gnus-make-hashtable)) 3418 ;; Formally bind gnus-agent-expire-current-dirs so that the 3419 ;; compiler will not complain about free references. 3420 (gnus-agent-expire-current-dirs 3421 (symbol-value 'gnus-agent-expire-current-dirs)) 3422 dir) 3423 3424 (gnus-sethash gnus-agent-directory t keep) 3425 (while gnus-agent-expire-current-dirs 3426 (setq dir (pop gnus-agent-expire-current-dirs)) 3427 (when (and (stringp dir) 3428 (file-directory-p dir)) 3429 (while (not (gnus-gethash dir keep)) 3430 (gnus-sethash dir t keep) 3431 (setq dir (file-name-directory (directory-file-name dir)))))) 3432 3433 (let* (to-remove 3434 checker 3435 (checker 3436 (function 3437 (lambda (d) 3438 "Given a directory, check it and its subdirectories for 3439 membership in the keep hash. If it isn't found, add 3440 it to to-remove." 3441 (let ((files (directory-files d)) 3442 file) 3443 (while (setq file (pop files)) 3444 (cond ((equal file ".") ; Ignore self 3445 nil) 3446 ((equal file "..") ; Ignore parent 3447 nil) 3448 ((equal file ".overview") 3449 ;; Directory must contain .overview to be 3450 ;; agent's cache of a group. 3451 (let ((d (file-name-as-directory d)) 3452 r) 3453 ;; Search ancestor's for last directory NOT 3454 ;; found in keep hash. 3455 (while (not (gnus-gethash 3456 (setq d (file-name-directory d)) keep)) 3457 (setq r d 3458 d (directory-file-name d))) 3459 ;; if ANY ancestor was NOT in keep hash and 3460 ;; it it's already in to-remove, add it to 3461 ;; to-remove. 3462 (if (and r 3463 (not (member r to-remove))) 3464 (push r to-remove)))) 3465 ((file-directory-p (setq file (nnheader-concat d file))) 3466 (funcall checker file))))))))) 3467 (funcall checker (expand-file-name gnus-agent-directory)) 3468 3469 (when (and to-remove 3470 (or gnus-expert-user 3471 (gnus-y-or-n-p 3472 "gnus-agent-expire has identified local directories that are\ 3473 not currently required by any agentized group. Do you wish to consider\ 3474 deleting them?"))) 3475 (while to-remove 3476 (let ((dir (pop to-remove))) 3477 (if (gnus-y-or-n-p (format "Delete %s? " dir)) 3478 (let* (delete-recursive 3479 (delete-recursive 3480 (function 3481 (lambda (f-or-d) 3482 (ignore-errors 3483 (if (file-directory-p f-or-d) 3484 (condition-case nil 3485 (delete-directory f-or-d) 3486 (file-error 3487 (mapcar (lambda (f) 3488 (or (member f '("." "..")) 3489 (funcall delete-recursive 3490 (nnheader-concat 3491 f-or-d f)))) 3492 (directory-files f-or-d)) 3493 (delete-directory f-or-d))) 3494 (delete-file f-or-d))))))) 3495 (funcall delete-recursive dir)))))))))) 3496 3497;;;###autoload 3498(defun gnus-agent-batch () 3499 "Start Gnus, send queue and fetch session." 3500 (interactive) 3501 (let ((init-file-user "") 3502 (gnus-always-read-dribble-file t)) 3503 (gnus)) 3504 (let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation)) 3505 (gnus-group-send-queue) 3506 (gnus-agent-fetch-session))) 3507 3508(defun gnus-agent-unread-articles (group) 3509 (let* ((read (gnus-info-read (gnus-get-info group))) 3510 (known (gnus-agent-load-alist group)) 3511 (unread (list nil)) 3512 (tail-unread unread)) 3513 (while (and known read) 3514 (let ((candidate (car (pop known)))) 3515 (while (let* ((range (car read)) 3516 (min (if (numberp range) range (car range))) 3517 (max (if (numberp range) range (cdr range)))) 3518 (cond ((or (not min) 3519 (< candidate min)) 3520 (gnus-agent-append-to-list tail-unread candidate) 3521 nil) 3522 ((> candidate max) 3523 (setq read (cdr read)) 3524 ;; return t so that I always loop one more 3525 ;; time. If I just iterated off the end of 3526 ;; read, min will become nil and the current 3527 ;; candidate will be added to the unread list. 3528 t)))))) 3529 (while known 3530 (gnus-agent-append-to-list tail-unread (car (pop known)))) 3531 (cdr unread))) 3532 3533(defun gnus-agent-uncached-articles (articles group &optional cached-header) 3534 "Restrict ARTICLES to numbers already fetched. 3535Returns a sublist of ARTICLES that excludes those article ids in GROUP 3536that have already been fetched. 3537If CACHED-HEADER is nil, articles are only excluded if the article itself 3538has been fetched." 3539 3540 ;; Logically equivalent to: (gnus-sorted-difference articles (mapcar 3541 ;; 'car gnus-agent-article-alist)) 3542 3543 ;; Functionally, I don't need to construct a temp list using mapcar. 3544 3545 (if (and (or gnus-agent-cache (not gnus-plugged)) 3546 (gnus-agent-load-alist group)) 3547 (let* ((ref gnus-agent-article-alist) 3548 (arts articles) 3549 (uncached (list nil)) 3550 (tail-uncached uncached)) 3551 (while (and ref arts) 3552 (let ((v1 (car arts)) 3553 (v2 (caar ref))) 3554 (cond ((< v1 v2) ; v1 does not appear in the reference list 3555 (gnus-agent-append-to-list tail-uncached v1) 3556 (setq arts (cdr arts))) 3557 ((= v1 v2) 3558 (unless (or cached-header (cdar ref)) ; v1 is already cached 3559 (gnus-agent-append-to-list tail-uncached v1)) 3560 (setq arts (cdr arts)) 3561 (setq ref (cdr ref))) 3562 (t ; reference article (v2) preceeds the list being filtered 3563 (setq ref (cdr ref)))))) 3564 (while arts 3565 (gnus-agent-append-to-list tail-uncached (pop arts))) 3566 (cdr uncached)) 3567 ;; if gnus-agent-load-alist fails, no articles are cached. 3568 articles)) 3569 3570(defun gnus-agent-retrieve-headers (articles group &optional fetch-old) 3571 (save-excursion 3572 (gnus-agent-create-buffer) 3573 (let ((gnus-decode-encoded-word-function 'identity) 3574 (file (gnus-agent-article-name ".overview" group)) 3575 cached-articles uncached-articles) 3576 (gnus-make-directory (nnheader-translate-file-chars 3577 (file-name-directory file) t)) 3578 3579 ;; Populate temp buffer with known headers 3580 (when (file-exists-p file) 3581 (with-current-buffer gnus-agent-overview-buffer 3582 (erase-buffer) 3583 (let ((nnheader-file-coding-system 3584 gnus-agent-file-coding-system)) 3585 (nnheader-insert-nov-file file (car articles))))) 3586 3587 (if (setq uncached-articles (gnus-agent-uncached-articles articles group 3588 t)) 3589 (progn 3590 ;; Populate nntp-server-buffer with uncached headers 3591 (set-buffer nntp-server-buffer) 3592 (erase-buffer) 3593 (cond ((not (eq 'nov (let (gnus-agent) ; Turn off agent 3594 (gnus-retrieve-headers 3595 uncached-articles group fetch-old)))) 3596 (nnvirtual-convert-headers)) 3597 ((eq 'nntp (car gnus-current-select-method)) 3598 ;; The author of gnus-get-newsgroup-headers-xover 3599 ;; reports that the XOVER command is commonly 3600 ;; unreliable. The problem is that recently 3601 ;; posted articles may not be entered into the 3602 ;; NOV database in time to respond to my XOVER 3603 ;; query. 3604 ;; 3605 ;; I'm going to use his assumption that the NOV 3606 ;; database is updated in order of ascending 3607 ;; article ID. Therefore, a response containing 3608 ;; article ID N implies that all articles from 1 3609 ;; to N-1 are up-to-date. Therefore, missing 3610 ;; articles in that range have expired. 3611 3612 (set-buffer nntp-server-buffer) 3613 (let* ((fetched-articles (list nil)) 3614 (tail-fetched-articles fetched-articles) 3615 (min (cond ((numberp fetch-old) 3616 (max 1 (- (car articles) fetch-old))) 3617 (fetch-old 3618 1) 3619 (t 3620 (car articles)))) 3621 (max (car (last articles)))) 3622 3623 ;; Get the list of articles that were fetched 3624 (goto-char (point-min)) 3625 (let ((pm (point-max)) 3626 art) 3627 (while (< (point) pm) 3628 (when (setq art (gnus-agent-read-article-number)) 3629 (gnus-agent-append-to-list tail-fetched-articles art)) 3630 (forward-line 1))) 3631 3632 ;; Clip this list to the headers that will 3633 ;; actually be returned 3634 (setq fetched-articles (gnus-list-range-intersection 3635 (cdr fetched-articles) 3636 (cons min max))) 3637 3638 ;; Clip the uncached articles list to exclude 3639 ;; IDs after the last FETCHED header. The 3640 ;; excluded IDs may be fetchable using HEAD. 3641 (if (car tail-fetched-articles) 3642 (setq uncached-articles 3643 (gnus-list-range-intersection 3644 uncached-articles 3645 (cons (car uncached-articles) 3646 (car tail-fetched-articles))))) 3647 3648 ;; Create the list of articles that were 3649 ;; "successfully" fetched. Success, in this 3650 ;; case, means that the ID should not be 3651 ;; fetched again. In the case of an expired 3652 ;; article, the header will not be fetched. 3653 (setq uncached-articles 3654 (gnus-sorted-nunion fetched-articles 3655 uncached-articles)) 3656 ))) 3657 3658 ;; Erase the temp buffer 3659 (set-buffer gnus-agent-overview-buffer) 3660 (erase-buffer) 3661 3662 ;; Copy the nntp-server-buffer to the temp buffer 3663 (set-buffer nntp-server-buffer) 3664 (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) 3665 3666 ;; Merge the temp buffer with the known headers (found on 3667 ;; disk in FILE) into the nntp-server-buffer 3668 (when uncached-articles 3669 (gnus-agent-braid-nov group uncached-articles file)) 3670 3671 ;; Save the new set of known headers to FILE 3672 (set-buffer nntp-server-buffer) 3673 (let ((coding-system-for-write 3674 gnus-agent-file-coding-system)) 3675 (gnus-agent-check-overview-buffer) 3676 (write-region (point-min) (point-max) file nil 'silent)) 3677 3678 ;; Update the group's article alist to include the newly 3679 ;; fetched articles. 3680 (gnus-agent-load-alist group) 3681 (gnus-agent-save-alist group uncached-articles nil) 3682 ) 3683 3684 ;; Copy the temp buffer to the nntp-server-buffer 3685 (set-buffer nntp-server-buffer) 3686 (erase-buffer) 3687 (insert-buffer-substring gnus-agent-overview-buffer))) 3688 3689 (if (and fetch-old 3690 (not (numberp fetch-old))) 3691 t ; Don't remove anything. 3692 (nnheader-nov-delete-outside-range 3693 (if fetch-old (max 1 (- (car articles) fetch-old)) 3694 (car articles)) 3695 (car (last articles))) 3696 t) 3697 3698 'nov)) 3699 3700(defun gnus-agent-request-article (article group) 3701 "Retrieve ARTICLE in GROUP from the agent cache." 3702 (when (and gnus-agent 3703 (or gnus-agent-cache 3704 (not gnus-plugged)) 3705 (numberp article)) 3706 (let* ((gnus-command-method (gnus-find-method-for-group group)) 3707 (file (gnus-agent-article-name (number-to-string article) group)) 3708 (buffer-read-only nil)) 3709 (when (and (file-exists-p file) 3710 (> (nth 7 (file-attributes file)) 0)) 3711 (erase-buffer) 3712 (gnus-kill-all-overlays) 3713 (let ((coding-system-for-read gnus-cache-coding-system)) 3714 (insert-file-contents file)) 3715 t)))) 3716 3717(defun gnus-agent-regenerate-group (group &optional reread) 3718 "Regenerate GROUP. 3719If REREAD is t, all articles in the .overview are marked as unread. 3720If REREAD is a list, the specified articles will be marked as unread. 3721In addition, their NOV entries in .overview will be refreshed using 3722the articles' current headers. 3723If REREAD is not nil, downloaded articles are marked as unread." 3724 (interactive 3725 (list (let ((def (or (gnus-group-group-name) 3726 gnus-newsgroup-name))) 3727 (let ((select (read-string (if def 3728 (concat "Group Name (" 3729 def "): ") 3730 "Group Name: ")))) 3731 (if (and (equal "" select) 3732 def) 3733 def 3734 select))) 3735 (catch 'mark 3736 (while (let (c 3737 (cursor-in-echo-area t) 3738 (echo-keystrokes 0)) 3739 (message "Mark as unread: (n)one / (a)ll / all (d)ownloaded articles? (n) ") 3740 (setq c (read-char-exclusive)) 3741 3742 (cond ((or (eq c ?\r) (eq c ?n) (eq c ?N)) 3743 (throw 'mark nil)) 3744 ((or (eq c ?a) (eq c ?A)) 3745 (throw 'mark t)) 3746 ((or (eq c ?d) (eq c ?D)) 3747 (throw 'mark 'some))) 3748 (gnus-message 3 "Ignoring unexpected input") 3749 (sit-for 1) 3750 t))))) 3751 (when group 3752 (gnus-message 5 "Regenerating in %s" group) 3753 (let* ((gnus-command-method (or gnus-command-method 3754 (gnus-find-method-for-group group))) 3755 (file (gnus-agent-article-name ".overview" group)) 3756 (dir (file-name-directory file)) 3757 point 3758 (downloaded (if (file-exists-p dir) 3759 (sort (delq nil (mapcar (lambda (name) 3760 (and (not (file-directory-p (nnheader-concat dir name))) 3761 (string-to-number name))) 3762 (directory-files dir nil "^[0-9]+$" t))) 3763 '>) 3764 (progn (gnus-make-directory dir) nil))) 3765 dl nov-arts 3766 alist header 3767 regenerated) 3768 3769 (mm-with-unibyte-buffer 3770 (if (file-exists-p file) 3771 (let ((nnheader-file-coding-system 3772 gnus-agent-file-coding-system)) 3773 (nnheader-insert-file-contents file))) 3774 (set-buffer-modified-p nil) 3775 3776 ;; Load the article IDs found in the overview file. As a 3777 ;; side-effect, validate the file contents. 3778 (let ((load t)) 3779 (while load 3780 (setq load nil) 3781 (goto-char (point-min)) 3782 (while (< (point) (point-max)) 3783 (cond ((and (looking-at "[0-9]+\t") 3784 (<= (- (match-end 0) (match-beginning 0)) 9)) 3785 (push (read (current-buffer)) nov-arts) 3786 (forward-line 1) 3787 (let ((l1 (car nov-arts)) 3788 (l2 (cadr nov-arts))) 3789 (cond ((and (listp reread) (memq l1 reread)) 3790 (gnus-delete-line) 3791 (setq nov-arts (cdr nov-arts)) 3792 (gnus-message 4 "gnus-agent-regenerate-group: NOV\ 3793 entry of article %s deleted." l1)) 3794 ((not l2) 3795 nil) 3796 ((< l1 l2) 3797 (gnus-message 3 "gnus-agent-regenerate-group: NOV\ 3798 entries are NOT in ascending order.") 3799 ;; Don't sort now as I haven't verified 3800 ;; that every line begins with a number 3801 (setq load t)) 3802 ((= l1 l2) 3803 (forward-line -1) 3804 (gnus-message 4 "gnus-agent-regenerate-group: NOV\ 3805 entries contained duplicate of article %s. Duplicate deleted." l1) 3806 (gnus-delete-line) 3807 (setq nov-arts (cdr nov-arts)))))) 3808 (t 3809 (gnus-message 1 "gnus-agent-regenerate-group: NOV\ 3810 entries contained line that did not begin with an article number. Deleted\ 3811 line.") 3812 (gnus-delete-line)))) 3813 (when load 3814 (gnus-message 5 "gnus-agent-regenerate-group: Sorting NOV\ 3815 entries into ascending order.") 3816 (sort-numeric-fields 1 (point-min) (point-max)) 3817 (setq nov-arts nil)))) 3818 (gnus-agent-check-overview-buffer) 3819 3820 ;; Construct a new article alist whose nodes match every header 3821 ;; in the .overview file. As a side-effect, missing headers are 3822 ;; reconstructed from the downloaded article file. 3823 (while (or downloaded nov-arts) 3824 (cond ((and downloaded 3825 (or (not nov-arts) 3826 (> (car downloaded) (car nov-arts)))) 3827 ;; This entry is missing from the overview file 3828 (gnus-message 3 "Regenerating NOV %s %d..." group 3829 (car downloaded)) 3830 (let ((file (concat dir (number-to-string (car downloaded))))) 3831 (mm-with-unibyte-buffer 3832 (nnheader-insert-file-contents file) 3833 (nnheader-remove-body) 3834 (setq header (nnheader-parse-naked-head))) 3835 (mail-header-set-number header (car downloaded)) 3836 (if nov-arts 3837 (let ((key (concat "^" (int-to-string (car nov-arts)) 3838 "\t"))) 3839 (or (re-search-backward key nil t) 3840 (re-search-forward key)) 3841 (forward-line 1)) 3842 (goto-char (point-min))) 3843 (nnheader-insert-nov header)) 3844 (setq nov-arts (cons (car downloaded) nov-arts))) 3845 ((eq (car downloaded) (car nov-arts)) 3846 ;; This entry in the overview has been downloaded 3847 (push (cons (car downloaded) 3848 (time-to-days 3849 (nth 5 (file-attributes 3850 (concat dir (number-to-string 3851 (car downloaded))))))) alist) 3852 (setq downloaded (cdr downloaded)) 3853 (setq nov-arts (cdr nov-arts))) 3854 (t 3855 ;; This entry in the overview has not been downloaded 3856 (push (cons (car nov-arts) nil) alist) 3857 (setq nov-arts (cdr nov-arts))))) 3858 3859 ;; When gnus-agent-consider-all-articles is set, 3860 ;; gnus-agent-regenerate-group should NOT remove article IDs from 3861 ;; the alist. Those IDs serve as markers to indicate that an 3862 ;; attempt has been made to fetch that article's header. 3863 3864 ;; When gnus-agent-consider-all-articles is NOT set, 3865 ;; gnus-agent-regenerate-group can remove the article ID of every 3866 ;; article (with the exception of the last ID in the list - it's 3867 ;; special) that no longer appears in the overview. In this 3868 ;; situtation, the last article ID in the list implies that it, 3869 ;; and every article ID preceeding it, have been fetched from the 3870 ;; server. 3871 3872 (if gnus-agent-consider-all-articles 3873 ;; Restore all article IDs that were not found in the overview file. 3874 (let* ((n (cons nil alist)) 3875 (merged n) 3876 (o (gnus-agent-load-alist group))) 3877 (while o 3878 (let ((nID (caadr n)) 3879 (oID (caar o))) 3880 (cond ((not nID) 3881 (setq n (setcdr n (list (list oID)))) 3882 (setq o (cdr o))) 3883 ((< oID nID) 3884 (setcdr n (cons (list oID) (cdr n))) 3885 (setq o (cdr o))) 3886 ((= oID nID) 3887 (setq o (cdr o)) 3888 (setq n (cdr n))) 3889 (t 3890 (setq n (cdr n)))))) 3891 (setq alist (cdr merged))) 3892 ;; Restore the last article ID if it is not already in the new alist 3893 (let ((n (last alist)) 3894 (o (last (gnus-agent-load-alist group)))) 3895 (cond ((not o) 3896 nil) 3897 ((not n) 3898 (push (cons (caar o) nil) alist)) 3899 ((< (caar n) (caar o)) 3900 (setcdr n (list (car o))))))) 3901 3902 (let ((inhibit-quit t)) 3903 (if (setq regenerated (buffer-modified-p)) 3904 (let ((coding-system-for-write gnus-agent-file-coding-system)) 3905 (write-region (point-min) (point-max) file nil 'silent))) 3906 3907 (setq regenerated (or regenerated 3908 (and reread gnus-agent-article-alist) 3909 (not (equal alist gnus-agent-article-alist)))) 3910 3911 (setq gnus-agent-article-alist alist) 3912 3913 (when regenerated 3914 (gnus-agent-save-alist group) 3915 3916 ;; I have to alter the group's active range NOW as 3917 ;; gnus-make-ascending-articles-unread will use it to 3918 ;; recalculate the number of unread articles in the group 3919 3920 (let ((group (gnus-group-real-name group)) 3921 (group-active (or (gnus-active group) 3922 (gnus-activate-group group)))) 3923 (gnus-agent-possibly-alter-active group group-active))))) 3924 3925 (when (and reread gnus-agent-article-alist) 3926 (gnus-agent-synchronize-group-flags 3927 group 3928 (list (list 3929 (if (listp reread) 3930 reread 3931 (delq nil (mapcar (function (lambda (c) 3932 (cond ((eq reread t) 3933 (car c)) 3934 ((cdr c) 3935 (car c))))) 3936 gnus-agent-article-alist))) 3937 'del '(read))) 3938 gnus-command-method) 3939 3940 (when (gnus-buffer-live-p gnus-group-buffer) 3941 (gnus-group-update-group group t))) 3942 3943 (gnus-message 5 "") 3944 regenerated))) 3945 3946;;;###autoload 3947(defun gnus-agent-regenerate (&optional clean reread) 3948 "Regenerate all agent covered files. 3949If CLEAN, obsolete (ignore)." 3950 (interactive "P") 3951 (let (regenerated) 3952 (gnus-message 4 "Regenerating Gnus agent files...") 3953 (dolist (gnus-command-method (gnus-agent-covered-methods)) 3954 (dolist (group (gnus-groups-from-server gnus-command-method)) 3955 (setq regenerated (or (gnus-agent-regenerate-group group reread) 3956 regenerated)))) 3957 (gnus-message 4 "Regenerating Gnus agent files...done") 3958 3959 regenerated)) 3960 3961(defun gnus-agent-go-online (&optional force) 3962 "Switch servers into online status." 3963 (interactive (list t)) 3964 (dolist (server gnus-opened-servers) 3965 (when (eq (nth 1 server) 'offline) 3966 (if (if (eq force 'ask) 3967 (gnus-y-or-n-p 3968 (format "Switch %s:%s into online status? " 3969 (caar server) (cadar server))) 3970 force) 3971 (setcar (nthcdr 1 server) 'close))))) 3972 3973(defun gnus-agent-toggle-group-plugged (group) 3974 "Toggle the status of the server of the current group." 3975 (interactive (list (gnus-group-group-name))) 3976 (let* ((method (gnus-find-method-for-group group)) 3977 (status (cadr (assoc method gnus-opened-servers)))) 3978 (if (eq status 'offline) 3979 (gnus-server-set-status method 'closed) 3980 (gnus-close-server method) 3981 (gnus-server-set-status method 'offline)) 3982 (message "Turn %s:%s from %s to %s." (car method) (cadr method) 3983 (if (eq status 'offline) 'offline 'online) 3984 (if (eq status 'offline) 'online 'offline)))) 3985 3986(defun gnus-agent-group-covered-p (group) 3987 (gnus-agent-method-p (gnus-group-method group))) 3988 3989(provide 'gnus-agent) 3990 3991;;; arch-tag: b0ba4afc-5229-4cee-ad25-9956daa4e91e 3992;;; gnus-agent.el ends here 3993