X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-agent.el;h=64ed8cbc5453be36c5e18e9fe9fae123eeab2e42;hb=f265c046596ac33e408153188c37f985cb06095b;hp=266a5e0a3e68a53e0d6d76d8be20461b2b5679f3;hpb=57dc1fd99ae2bec6c4cf8ee2a85121f1a82a64b6;p=gnus diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index 266a5e0a3..64ed8cbc5 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -1,5 +1,5 @@ ;;; gnus-agent.el --- unplugged support for Gnus -;; Copyright (C) 1997, 1998, 1999, 2000, 2001 +;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen @@ -29,6 +29,7 @@ (require 'nnvirtual) (require 'gnus-sum) (require 'gnus-score) +(require 'gnus-srvr) (eval-when-compile (if (featurep 'xemacs) (require 'itimer) @@ -36,7 +37,8 @@ (require 'cl)) (eval-and-compile - (autoload 'gnus-server-update-server "gnus-srvr")) + (autoload 'gnus-server-update-server "gnus-srvr") + (autoload 'number-at-point "thingatpt")) (defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/") "Where the Gnus agent will store its files." @@ -59,7 +61,9 @@ :type 'integer) (defcustom gnus-agent-expire-days 7 - "Read articles older than this will be expired." + "Read articles older than this will be expired. +This can also be a list of regexp/day pairs. The regexps will +be matched against group names." :group 'gnus-agent :type 'integer) @@ -111,13 +115,51 @@ If this is `ask' the hook will query the user." (const :tag "Ask" ask)) :group 'gnus-agent) +(defcustom gnus-agent-go-online 'ask + "Indicate if offline servers go online when you plug in. +If this is `ask' the hook will query the user." + :version "21.1" + :type '(choice (const :tag "Always" t) + (const :tag "Never" nil) + (const :tag "Ask" ask)) + :group 'gnus-agent) + +(defcustom gnus-agent-mark-unread-after-downloaded t + "Indicate whether to mark articles unread after downloaded." + :version "21.1" + :type 'boolean + :group 'gnus-agent) + +(defcustom gnus-agent-download-marks '(download) + "Marks for downloading." + :version "21.1" + :type '(repeat (symbol :tag "Mark")) + :group 'gnus-agent) + +(defcustom gnus-agent-consider-all-articles nil + "If non-nil, consider also the read articles for downloading." + :version "21.4" + :type 'boolean + :group 'gnus-agent) + ;;; Internal variables (defvar gnus-agent-history-buffers nil) (defvar gnus-agent-buffer-alist nil) -(defvar gnus-agent-article-alist nil) +(defvar gnus-agent-article-alist nil +"An assoc list identifying the articles whose headers have been fetched. + If successfully fetched, these headers will be stored in the group's overview file. + The key of each assoc pair is the article ID. + The value of each assoc pair is a flag indicating + whether the identified article has been downloaded (gnus-agent-fetch-articles + sets the value to the day of the download). + NOTES: + 1) The last element of this list can not be expired as some + routines (for example, get-agent-fetch-headers) use the last + value to track which articles have had their headers retrieved. + 2) The gnus-agent-regenerate may destructively modify the value. +") (defvar gnus-agent-group-alist nil) -(defvar gnus-agent-covered-methods nil) (defvar gnus-category-alist nil) (defvar gnus-agent-current-history nil) (defvar gnus-agent-overview-buffer nil) @@ -127,6 +169,13 @@ If this is `ask' the hook will query the user." (defvar gnus-agent-file-name nil) (defvar gnus-agent-send-mail-function nil) (defvar gnus-agent-file-coding-system 'raw-text) +(defvar gnus-agent-file-loading-cache nil) +(defvar gnus-agent-file-header-cache nil) + +(defvar gnus-agent-auto-agentize-methods '(nntp nnimap) + "Initially, all servers from these methods are agentized. +The user may remove or add servers using the Server buffer. See Info +node `(gnus)Server Buffer'.") ;; Dynamic variables (defvar gnus-headers) @@ -196,14 +245,10 @@ If this is `ask' the hook will query the user." (defun gnus-agent-start-fetch () "Initialize data structures for efficient fetching." - (gnus-agent-open-history) - (setq gnus-agent-current-history (gnus-agent-history-buffer)) (gnus-agent-create-buffer)) (defun gnus-agent-stop-fetch () "Save all data structures and clean up." - (gnus-agent-save-history) - (gnus-agent-close-history) (setq gnus-agent-spam-hashtb nil) (save-excursion (set-buffer nntp-server-buffer) @@ -220,6 +265,9 @@ If this is `ask' the hook will query the user." (put 'gnus-agent-with-fetch 'lisp-indent-function 0) (put 'gnus-agent-with-fetch 'edebug-form-spec '(body)) +(defmacro gnus-agent-append-to-list (tail value) + `(setq ,tail (setcdr ,tail (cons ,value nil)))) + ;;; ;;; Mode infestation ;;; @@ -260,9 +308,10 @@ If this is `ask' the hook will query the user." "Jj" gnus-agent-toggle-plugged "Js" gnus-agent-fetch-session "JY" gnus-agent-synchronize-flags - "JS" gnus-group-send-drafts + "JS" gnus-group-send-queue "Ja" gnus-agent-add-group - "Jr" gnus-agent-remove-group) + "Jr" gnus-agent-remove-group + "Jo" gnus-agent-toggle-group-plugged) (defun gnus-agent-group-make-menu-bar () (unless (boundp 'gnus-agent-group-menu) @@ -270,8 +319,9 @@ If this is `ask' the hook will query the user." gnus-agent-group-menu gnus-agent-group-mode-map "" '("Agent" ["Toggle plugged" gnus-agent-toggle-plugged t] + ["Toggle group plugged" gnus-agent-toggle-group-plugged t] ["List categories" gnus-enter-category-buffer t] - ["Send drafts" gnus-group-send-drafts gnus-plugged] + ["Send queue" gnus-group-send-queue gnus-plugged] ("Fetch" ["All" gnus-agent-fetch-session gnus-plugged] ["Group" gnus-agent-fetch-group gnus-plugged]))))) @@ -280,6 +330,7 @@ If this is `ask' the hook will query the user." (gnus-define-keys gnus-agent-summary-mode-map "Jj" gnus-agent-toggle-plugged "Ju" gnus-agent-summary-fetch-group + "Js" gnus-agent-summary-fetch-series "J#" gnus-agent-mark-article "J\M-#" gnus-agent-unmark-article "@" gnus-agent-toggle-mark @@ -294,7 +345,7 @@ If this is `ask' the hook will query the user." ["Mark as downloadable" gnus-agent-mark-article t] ["Unmark as downloadable" gnus-agent-unmark-article t] ["Toggle mark" gnus-agent-toggle-mark t] - ["Fetch downloadable" gnus-aget-summary-fetch-group t] + ["Fetch downloadable" gnus-agent-summary-fetch-group t] ["Catchup undownloaded" gnus-agent-catchup t])))) (defvar gnus-agent-server-mode-map (make-sparse-keymap)) @@ -325,16 +376,17 @@ If this is `ask' the hook will query the user." (if plugged (progn (setq gnus-plugged plugged) - (gnus-agent-possibly-synchronize-flags) (gnus-run-hooks 'gnus-agent-plugged-hook) - (setcar (cdr gnus-agent-mode-status) + (setcar (cdr gnus-agent-mode-status) (gnus-agent-make-mode-line-string " Plugged" 'mouse-2 - 'gnus-agent-toggle-plugged))) + 'gnus-agent-toggle-plugged)) + (gnus-agent-go-online gnus-agent-go-online) + (gnus-agent-possibly-synchronize-flags)) (gnus-agent-close-connections) (setq gnus-plugged plugged) (gnus-run-hooks 'gnus-agent-unplugged-hook) - (setcar (cdr gnus-agent-mode-status) + (setcar (cdr gnus-agent-mode-status) (gnus-agent-make-mode-line-string " Unplugged" 'mouse-2 'gnus-agent-toggle-plugged))) @@ -360,6 +412,13 @@ If this is `ask' the hook will query the user." (setq gnus-plugged t) (gnus)) +;;;###autoload +(defun gnus-slave-unplugged (&optional arg) + "Read news as a slave unplugged." + (interactive "P") + (setq gnus-plugged nil) + (gnus arg nil 'slave)) + ;;;###autoload (defun gnus-agentize () "Allow Gnus to be an offline newsreader. @@ -380,7 +439,14 @@ minor mode in all Gnus buffers." message-send-mail-function) message-send-mail-real-function 'gnus-agent-send-mail)) (unless gnus-agent-covered-methods - (setq gnus-agent-covered-methods (list gnus-select-method)))) + (mapcar + (lambda (server) + (if (memq (car (gnus-server-to-method server)) + gnus-agent-auto-agentize-methods) + (setq gnus-agent-covered-methods + (cons (gnus-server-to-method server) + gnus-agent-covered-methods )))) + (append (list gnus-select-method) gnus-secondary-select-methods)))) (defun gnus-agent-queue-setup () "Make sure the queue group exists." @@ -437,6 +503,7 @@ be a select method." methods (cdr methods))) covered))) +;;;###autoload (defun gnus-agent-possibly-save-gcc () "Save GCC if Gnus is unplugged." (when (and (not gnus-plugged) (gnus-agent-any-covered-gcc)) @@ -535,7 +602,7 @@ be a select method." (erase-buffer) (nnheader-insert-file-contents (gnus-agent-lib-file "flags")) (if (null (gnus-check-server gnus-command-method)) - (message "Couldn't open server %s" (nth 1 gnus-command-method)) + (gnus-message 1 "Couldn't open server %s" (nth 1 gnus-command-method)) (while (not (eobp)) (if (null (eval (read (current-buffer)))) (progn (forward-line) @@ -570,7 +637,7 @@ be a select method." (push method gnus-agent-covered-methods) (gnus-server-update-server server) (gnus-agent-write-servers) - (message "Entered %s into the Agent" server))) + (gnus-message 1 "Entered %s into the Agent" server))) (defun gnus-agent-remove-server (server) "Remove SERVER from the agent program." @@ -584,13 +651,21 @@ be a select method." (delete method gnus-agent-covered-methods)) (gnus-server-update-server server) (gnus-agent-write-servers) - (message "Removed %s from the agent" server))) + (gnus-message 1 "Removed %s from the agent" server))) (defun gnus-agent-read-servers () "Read the alist of covered servers." - (setq gnus-agent-covered-methods - (gnus-agent-read-file - (nnheader-concat gnus-agent-directory "lib/servers")))) + (mapcar (lambda (m) + (let ((method (gnus-server-get-method + nil + (or m "native")))) + (if method + (unless (member method gnus-agent-covered-methods) + (push method gnus-agent-covered-methods)) + (gnus-message 1 "Ignoring disappeared server `%s'" m) + (sit-for 1)))) + (gnus-agent-read-file + (nnheader-concat gnus-agent-directory "lib/servers")))) (defun gnus-agent-write-servers () "Write the alist of covered servers." @@ -598,7 +673,8 @@ be a select method." (let ((coding-system-for-write nnheader-file-coding-system) (file-name-coding-system nnmail-pathname-coding-system)) (with-temp-file (nnheader-concat gnus-agent-directory "lib/servers") - (prin1 gnus-agent-covered-methods (current-buffer))))) + (prin1 (mapcar 'gnus-method-simplify gnus-agent-covered-methods) + (current-buffer))))) ;;; ;;; Summary commands @@ -640,41 +716,53 @@ the actual number of articles toggled is returned." (gnus-agent-mark-article n 'toggle)) (defun gnus-summary-set-agent-mark (article &optional unmark) - "Mark ARTICLE as downloadable." - (let ((unmark (if (and (not (null unmark)) (not (eq t unmark))) - (memq article gnus-newsgroup-downloadable) - unmark))) + "Mark ARTICLE as downloadable. If UNMARK is nil, article is marked. +When UNMARK is t, the article is unmarked. For any other value, the +article's mark is toggled." + (let ((unmark (cond ((eq nil unmark) + nil) + ((eq t unmark) + t) + (t + (memq article gnus-newsgroup-downloadable))))) + (gnus-summary-update-mark (if unmark - (progn + (progn (setq gnus-newsgroup-downloadable (delq article gnus-newsgroup-downloadable)) - (push article gnus-newsgroup-undownloaded)) - (setq gnus-newsgroup-undownloaded - (delq article gnus-newsgroup-undownloaded)) - (push article gnus-newsgroup-downloadable)) - (gnus-summary-update-mark - (if unmark gnus-undownloaded-mark gnus-downloadable-mark) + (gnus-article-mark article)) + (progn + (setq gnus-newsgroup-downloadable + (gnus-add-to-sorted-list gnus-newsgroup-downloadable article)) + gnus-downloadable-mark) + ) 'unread))) (defun gnus-agent-get-undownloaded-list () - "Mark all unfetched articles as read." + "Construct list of articles that have not been downloaded." (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))) - (when (and (not gnus-plugged) - (gnus-agent-method-p gnus-command-method)) - (gnus-agent-load-alist gnus-newsgroup-name) - ;; First mark all undownloaded articles as undownloaded. - (dolist (article (mapcar (lambda (header) (mail-header-number header)) - gnus-newsgroup-headers)) - (unless (or (cdr (assq article gnus-agent-article-alist)) - (memq article gnus-newsgroup-downloadable) - (memq article gnus-newsgroup-cached)) - (push article gnus-newsgroup-undownloaded))) - ;; Then mark downloaded downloadable as not-downloadable, - ;; if you get my drift. - (dolist (article gnus-newsgroup-downloadable) - (when (cdr (assq article gnus-agent-article-alist)) - (setq gnus-newsgroup-downloadable - (delq article gnus-newsgroup-downloadable))))))) + (when (set (make-local-variable 'gnus-newsgroup-agentized) (gnus-agent-method-p gnus-command-method)) + (let* ((alist (gnus-agent-load-alist gnus-newsgroup-name)) + (headers gnus-newsgroup-headers) + (undownloaded (list nil)) + (tail undownloaded)) + (while (and alist headers) + (let ((a (caar alist)) + (h (mail-header-number (car headers)))) + (cond ((< a h) + (pop alist)) ; ignore IDs in the alist that are not being displayed in the summary + ((> a h) + (pop headers)) ; ignore headers that are not in the alist as these should be fictious (see nnagent-retrieve-headers). + ((cdar alist) + (pop alist) + (pop headers) + nil; ignore already downloaded + ) + (t + (pop alist) + (pop headers) + (gnus-agent-append-to-list tail a))))) + (setq gnus-newsgroup-undownloaded (cdr undownloaded)))))) (defun gnus-agent-catchup () "Mark all undownloaded articles as read." @@ -685,10 +773,27 @@ the actual number of articles toggled is returned." (pop gnus-newsgroup-undownloaded) gnus-catchup-mark))) (gnus-summary-position-point)) -(defun gnus-agent-summary-fetch-group () - "Fetch the downloadable articles in the group." +(defun gnus-agent-summary-fetch-series () (interactive) - (let ((articles gnus-newsgroup-downloadable) + (let ((dl gnus-newsgroup-downloadable)) + (while gnus-newsgroup-processable + (let* ((art (car (last gnus-newsgroup-processable))) + (gnus-newsgroup-downloadable (list art))) + (gnus-summary-goto-subject art) + (sit-for 0) + (gnus-agent-summary-fetch-group) + (setq dl (delq art dl)) + (gnus-summary-remove-process-mark art) + (sit-for 0))) + (setq gnus-newsgroup-downloadable dl))) + +(defun gnus-agent-summary-fetch-group (&optional all) + "Fetch the downloadable articles in the group. +Optional arg ALL, if non-nil, means to fetch all articles." + (interactive "P") + (let ((articles + (if all gnus-newsgroup-articles + gnus-newsgroup-downloadable)) (gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name)) (state gnus-plugged)) (unwind-protect @@ -698,16 +803,32 @@ the actual number of articles toggled is returned." (unless articles (error "No articles to download")) (gnus-agent-with-fetch - (gnus-agent-fetch-articles gnus-newsgroup-name articles)) + (setq gnus-newsgroup-undownloaded + (gnus-sorted-ndifference gnus-newsgroup-undownloaded + (gnus-agent-fetch-articles gnus-newsgroup-name articles)))) (save-excursion (dolist (article articles) (setq gnus-newsgroup-downloadable (delq article gnus-newsgroup-downloadable)) - (gnus-summary-mark-article article gnus-unread-mark)))) + (if gnus-agent-mark-unread-after-downloaded + (gnus-summary-mark-article article gnus-unread-mark)) + (gnus-summary-update-download-mark article)))) (when (and (not state) gnus-plugged) (gnus-agent-toggle-plugged nil))))) +(defun gnus-agent-fetch-selected-article () + "Fetch the current article as it is selected. +This can be added to `gnus-select-article-hook' or +`gnus-mark-article-hook'." + (let ((gnus-command-method gnus-current-select-method)) + (when (and gnus-plugged (gnus-agent-method-p gnus-command-method)) + (when (gnus-agent-fetch-articles + gnus-newsgroup-name + (list gnus-current-article)) + (setq gnus-newsgroup-undownloaded (delq gnus-current-article gnus-newsgroup-undownloaded)) + (gnus-summary-update-download-mark gnus-current-article))))) + ;;; ;;; Internal functions ;;; @@ -747,7 +868,7 @@ the actual number of articles toggled is returned." (set (intern (symbol-name sym) orig) (symbol-value sym))))) new)) (gnus-make-directory (file-name-directory file)) - (let ((coding-system-for-write gnus-agent-file-coding-system)) + (let ((nnmail-active-file-coding-system gnus-agent-file-coding-system)) ;; The hashtable contains real names of groups, no more prefix ;; removing, so set `full' to `t'. (gnus-write-active-file file orig t)))) @@ -771,7 +892,7 @@ the actual number of articles toggled is returned." (goto-char (point-min)) (when (re-search-forward (concat "^" (regexp-quote group) " ") nil t) - (save-excursion + (save-excursion (read (current-buffer)) ;; max (setq oactive-min (read (current-buffer)))) ;; min (gnus-delete-line)) @@ -795,19 +916,11 @@ the actual number of articles toggled is returned." ?. ?_) ?. ?/)))) - - -(defun gnus-agent-method-p (method) - "Say whether METHOD is covered by the agent." - (member method gnus-agent-covered-methods)) - (defun gnus-agent-get-function (method) - (if (and (not gnus-plugged) - (gnus-agent-method-p method)) - (progn - (require 'nnagent) - 'nnagent) - (car method))) + (if (gnus-online method) + (car method) + (require 'nnagent) + 'nnagent)) ;;; History functions @@ -829,14 +942,6 @@ the actual number of articles toggled is returned." (nnheader-insert-file-contents file)) (set (make-local-variable 'gnus-agent-file-name) file)))) -(defun gnus-agent-save-history () - (save-excursion - (set-buffer gnus-agent-current-history) - (gnus-make-directory (file-name-directory gnus-agent-file-name)) - (let ((coding-system-for-write gnus-agent-file-coding-system)) - (write-region (1+ (point-min)) (point-max) - gnus-agent-file-name nil 'silent)))) - (defun gnus-agent-close-history () (when (gnus-buffer-live-p gnus-agent-current-history) (kill-buffer gnus-agent-current-history) @@ -844,43 +949,13 @@ the actual number of articles toggled is returned." (delq (assoc (gnus-agent-method) gnus-agent-history-buffers) gnus-agent-history-buffers)))) -(defun gnus-agent-enter-history (id group-arts date) - (save-excursion - (set-buffer gnus-agent-current-history) - (goto-char (point-max)) - (let ((p (point))) - (insert id "\t" (number-to-string date) "\t") - (while group-arts - (insert (format "%S" (intern (caar group-arts))) - " " (number-to-string (cdr (pop group-arts))) - " ")) - (insert "\n") - (while (search-backward "\\." p t) - (delete-char 1))))) - -(defun gnus-agent-article-in-history-p (id) - (save-excursion - (set-buffer (gnus-agent-history-buffer)) - (goto-char (point-min)) - (search-forward (concat "\n" id "\t") nil t))) - -(defun gnus-agent-history-path (id) - (save-excursion - (set-buffer (gnus-agent-history-buffer)) - (goto-char (point-min)) - (when (search-forward (concat "\n" id "\t") nil t) - (let ((method (gnus-agent-method))) - (let (paths group) - (while (not (numberp (setq group (read (current-buffer))))) - (push (concat method "/" group) paths)) - (nreverse paths)))))) - ;;; ;;; Fetching ;;; (defun gnus-agent-fetch-articles (group articles) "Fetch ARTICLES from GROUP and put them into the Agent." + (gnus-agent-load-alist group) (when articles ;; Prune off articles that we have already fetched. (while (and articles @@ -892,12 +967,14 @@ the actual number of articles toggled is returned." (setcdr arts (cddr arts)) (setq arts (cdr arts))))) (when articles - (let ((dir (concat + (let* ((fetched-articles (list nil)) + (tail-fetched-articles fetched-articles) + (dir (concat (gnus-agent-directory) (gnus-agent-group-path group) "/")) (date (time-to-days (current-time))) (case-fold-search t) - pos crosses id elem) + pos crosses id) (gnus-make-directory dir) (gnus-message 7 "Fetching articles for %s..." group) ;; Fetch the articles from the backend. @@ -906,6 +983,8 @@ the actual number of articles toggled is returned." (with-temp-buffer (let (article) (while (setq article (pop articles)) + (gnus-message 10 "Fetching article %s for %s..." + article group) (when (or (gnus-backlog-request-article group article nntp-server-buffer) @@ -921,38 +1000,43 @@ the actual number of articles toggled is returned." (while pos (narrow-to-region (cdar pos) (or (cdadr pos) (point-max))) (goto-char (point-min)) - (when (search-forward "\n\n" nil t) - (when (search-backward "\nXrefs: " nil t) - ;; Handle crossposting. - (skip-chars-forward "^ ") - (skip-chars-forward " ") - (setq crosses nil) - (while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) +") - (push (cons (buffer-substring (match-beginning 1) - (match-end 1)) - (buffer-substring (match-beginning 2) - (match-end 2))) - crosses) - (goto-char (match-end 0))) - (gnus-agent-crosspost crosses (caar pos)))) - (goto-char (point-min)) - (if (not (re-search-forward "^Message-ID: *<\\([^>\n]+\\)>" nil t)) - (setq id "No-Message-ID-in-article") - (setq id (buffer-substring (match-beginning 1) (match-end 1)))) - (let ((coding-system-for-write - gnus-agent-file-coding-system)) - (write-region (point-min) (point-max) - (concat dir (number-to-string (caar pos))) - nil 'silent)) - (when (setq elem (assq (caar pos) gnus-agent-article-alist)) - (setcdr elem t)) - (gnus-agent-enter-history - id (or crosses (list (cons group (caar pos)))) date) + (unless (eobp) ;; Don't save empty articles. + (when (search-forward "\n\n" nil t) + (when (search-backward "\nXrefs: " nil t) + ;; Handle cross posting. + (goto-char (match-end 0)) ; move to end of header name + (skip-chars-forward "^ ") ; skip server name + (skip-chars-forward " ") + (setq crosses nil) + (while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) *") + (push (cons (buffer-substring (match-beginning 1) + (match-end 1)) + (string-to-int (buffer-substring (match-beginning 2) + (match-end 2)))) + crosses) + (goto-char (match-end 0))) + (gnus-agent-crosspost crosses (caar pos) date))) + (goto-char (point-min)) + (if (not (re-search-forward + "^Message-ID: *<\\([^>\n]+\\)>" nil t)) + (setq id "No-Message-ID-in-article") + (setq id (buffer-substring (match-beginning 1) (match-end 1)))) + (let ((coding-system-for-write + gnus-agent-file-coding-system)) + (write-region (point-min) (point-max) + (concat dir (number-to-string (caar pos))) + nil 'silent)) + + (gnus-agent-append-to-list tail-fetched-articles (caar pos))) (widen) (pop pos))) - (gnus-agent-save-alist group))))) -(defun gnus-agent-crosspost (crosses article) + (gnus-agent-save-alist group (cdr fetched-articles) date) + (cdr fetched-articles))))) + +(defun gnus-agent-crosspost (crosses article &optional date) + (setq date (or date t)) + (let (gnus-agent-article-alist group alist beg end) (save-excursion (set-buffer gnus-agent-overview-buffer) @@ -965,7 +1049,7 @@ the actual number of articles toggled is returned." (unless (setq alist (assoc group gnus-agent-group-alist)) (push (setq alist (list group (gnus-agent-load-alist (caar crosses)))) gnus-agent-group-alist)) - (setcdr alist (cons (cons (cdar crosses) t) (cdr alist))) + (setcdr alist (cons (cons (cdar crosses) date) (cdr alist))) (save-excursion (set-buffer (gnus-get-buffer-create (format " *Gnus agent overview %s*" group))) @@ -976,9 +1060,47 @@ the actual number of articles toggled is returned." (gnus-agent-article-name ".overview" group)))) (nnheader-find-nov-line (string-to-number (cdar crosses))) (insert (string-to-number (cdar crosses))) - (insert-buffer-substring gnus-agent-overview-buffer beg end)) + (insert-buffer-substring gnus-agent-overview-buffer beg end) + (gnus-agent-check-overview-buffer)) (pop crosses)))) +(defun gnus-agent-check-overview-buffer (&optional buffer) + "Check the overview file given for sanity. +In particular, checks that the file is sorted by article number +and that there are no duplicates." + (let ((prev-num -1)) + (save-excursion + (when buffer (set-buffer buffer)) + (save-excursion + (save-restriction + (let ((deactivate-mark (if (boundp 'deactivate-mark) + (symbol-value 'deactivate-mark) + nil))) + (widen) + (goto-char (point-min)) + + (while (< (point) (point-max)) + (let ((p (point)) + (cur (condition-case nil + (read (current-buffer)) + (error nil)))) + (cond ((or (not (integerp cur)) + (not (eq (char-after) ?\t))) + (gnus-message 1 + "Overview buffer contains garbage '%s'." (buffer-substring p (progn (end-of-line) (point)))) + (debug nil "Overview buffer contains line that does not begin with a tab-delimited integer.")) + ((= cur prev-num) + (gnus-message 1 + "Duplicate overview line for %d" cur) + (debug nil (format "Duplicate overview line for %d" cur)) + (delete-region (point) (progn (forward-line 1) (point)))) + ((< cur prev-num) + (gnus-message 1 "Overview buffer not sorted!") + (debug nil "Overview buffer not sorted!")) + (t + (setq prev-num cur))) + (forward-line 1))))))))) + (defun gnus-agent-flush-cache () (save-excursion (while gnus-agent-buffer-alist @@ -991,119 +1113,264 @@ the actual number of articles toggled is returned." nil 'silent)) (pop gnus-agent-buffer-alist)) (while gnus-agent-group-alist - (with-temp-file (caar gnus-agent-group-alist) + (with-temp-file (gnus-agent-article-name ".agentview" (caar gnus-agent-group-alist)) (princ (cdar gnus-agent-group-alist)) + (insert "\n") + (princ 1 (current-buffer)) (insert "\n")) (pop gnus-agent-group-alist)))) (defun gnus-agent-fetch-headers (group &optional force) - (let ((articles (gnus-list-of-unread-articles group)) - (gnus-decode-encoded-word-function 'identity) - (file (gnus-agent-article-name ".overview" group))) - ;; Add article with marks to list of article headers we want to fetch. - (dolist (arts (gnus-info-marks (gnus-get-info group))) - (setq articles (gnus-range-add articles (cdr arts)))) - (setq articles (sort (gnus-uncompress-sequence articles) '<)) - ;; Remove known articles. - (when (gnus-agent-load-alist group) - (setq articles (gnus-sorted-intersection - articles - (gnus-uncompress-range - (cons (1+ (caar (last gnus-agent-article-alist))) - (cdr (gnus-active group))))))) - ;; Fetch them. - (gnus-make-directory (nnheader-translate-file-chars - (file-name-directory file) t)) - (when articles - (gnus-message 7 "Fetching headers for %s..." group) - (save-excursion - (set-buffer nntp-server-buffer) - (unless (eq 'nov (gnus-retrieve-headers articles group)) - (nnvirtual-convert-headers)) - ;; Save these headers for later processing. - (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) - (when (file-exists-p file) - (gnus-agent-braid-nov group articles file)) - (let ((coding-system-for-write - gnus-agent-file-coding-system)) - (write-region (point-min) (point-max) file nil 'silent)) - (gnus-agent-save-alist group articles nil) - (gnus-agent-enter-history - "last-header-fetched-for-session" - (list (cons group (nth (- (length articles) 1) articles))) - (time-to-days (current-time))) - articles)))) + (let* ((fetch-all (and gnus-agent-consider-all-articles + ;; Do not fetch all headers if the predicate + ;; implies that we only consider unread articles. + (not (gnus-predicate-implies-unread + (or (gnus-group-find-parameter + group 'agent-predicate t) + (cadr (gnus-group-category group))))))) + (articles (if fetch-all + (gnus-uncompress-range (gnus-active group)) + (gnus-list-of-unread-articles group))) + (gnus-decode-encoded-word-function 'identity) + (file (gnus-agent-article-name ".overview" group)) + gnus-agent-cache) + + (unless fetch-all + ;; Add articles with marks to the list of article headers we want to + ;; fetch. Don't fetch articles solely on the basis of a recent or seen + ;; mark, but do fetch recent or seen articles if they have other, more + ;; interesting marks. (We have to fetch articles with boring marks + ;; because otherwise the agent will remove their marks.) + (dolist (arts (gnus-info-marks (gnus-get-info group))) + (unless (memq (car arts) '(seen recent)) + (setq articles (gnus-range-add articles (cdr arts))))) + (setq articles (sort (gnus-uncompress-sequence articles) '<))) + + ;; At this point, I have the list of articles to consider for fetching. + ;; This is the list that I'll return to my caller. Some of these articles may have already + ;; been fetched. That's OK as the fetch article code will filter those out. + ;; Internally, I'll filter this list to just those articles whose headers need to be fetched. + (let ((articles articles)) + ;; Remove known articles. + (when (gnus-agent-load-alist group) + ;; Remove articles marked as downloaded. + (if fetch-all + ;; I want to fetch all headers in the active range. + ;; Therefore, exclude only those headers that are in the article alist. + ;; NOTE: This is probably NOT what I want to do after agent expiration in this group. + (setq articles (gnus-agent-uncached-articles articles group)) + + ;; I want to only fetch those headers that have never been fetched. + ;; Therefore, exclude all headers that are, or WERE, in the article alist. + (let ((low (1+ (caar (last gnus-agent-article-alist)))) + (high (cdr (gnus-active group)))) + ;; Low can be greater than High when the same group is fetched twice + ;; in the same session {The first fetch will fill the article alist + ;; such that (last gnus-agent-article-alist) equals (cdr (gnus-active group))}. + ;; The addition of one(the 1+ above) then forces Low to be greater than High. + ;; When this happens, gnus-list-range-intersection returns nil which indicates + ;; that no headers need to be fetched. -- Kevin + (setq articles (gnus-list-range-intersection + articles (list (cons low high))))))) + (when articles + (gnus-message 7 "Fetching headers for %s..." group) + + ;; Fetch them. + (gnus-make-directory (nnheader-translate-file-chars + (file-name-directory file) t)) + + (save-excursion + (set-buffer nntp-server-buffer) + (unless (eq 'nov (gnus-retrieve-headers articles group)) + (nnvirtual-convert-headers)) + (gnus-agent-check-overview-buffer) + ;; Move these headers to the overview buffer so that gnus-agent-braid-nov can merge them + ;; with the contents of FILE. + (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) + (when (file-exists-p file) + (gnus-agent-braid-nov group articles file)) + (let ((coding-system-for-write + gnus-agent-file-coding-system)) + (gnus-agent-check-overview-buffer) + (write-region (point-min) (point-max) file nil 'silent)) + (gnus-agent-save-alist group articles nil) + articles))) + articles)) (defsubst gnus-agent-copy-nov-line (article) - (let (b e) + (let (art b e) (set-buffer gnus-agent-overview-buffer) - (setq b (point)) - (if (eq article (read (current-buffer))) - (setq e (progn (forward-line 1) (point))) - (progn - (beginning-of-line) - (setq e b))) - (set-buffer nntp-server-buffer) - (insert-buffer-substring gnus-agent-overview-buffer b e))) + (while (and (not (eobp)) + (< (setq art (read (current-buffer))) article)) + (forward-line 1)) + (beginning-of-line) + (if (or (eobp) + (not (eq article art))) + (set-buffer nntp-server-buffer) + (setq b (point)) + (setq e (progn (forward-line 1) (point))) + (set-buffer nntp-server-buffer) + (insert-buffer-substring gnus-agent-overview-buffer b e)))) (defun gnus-agent-braid-nov (group articles file) - (set-buffer gnus-agent-overview-buffer) - (goto-char (point-min)) - (set-buffer nntp-server-buffer) - (erase-buffer) - (nnheader-insert-file-contents file) - (goto-char (point-max)) - (if (or (= (point-min) (point-max)) - (progn - (forward-line -1) - (< (read (current-buffer)) (car articles)))) - ;; We have only headers that are after the older headers, - ;; so we just append them. - (progn - (goto-char (point-max)) - (insert-buffer-substring gnus-agent-overview-buffer)) - ;; We do it the hard way. - (nnheader-find-nov-line (car articles)) - (gnus-agent-copy-nov-line (car articles)) - (pop articles) - (while (and articles - (not (eobp))) - (while (and (not (eobp)) - (< (read (current-buffer)) (car articles))) - (forward-line 1)) - (beginning-of-line) - (unless (eobp) - (gnus-agent-copy-nov-line (car articles)) - (setq articles (cdr articles)))) + "Merges the article headers identified by ARTICLES from gnus-agent-overview-buffer with the contents +of FILE placing the combined headers in nntp-server-buffer." + (let (start last) + (set-buffer gnus-agent-overview-buffer) + (goto-char (point-min)) + (set-buffer nntp-server-buffer) + (erase-buffer) + (nnheader-insert-file-contents file) + (goto-char (point-max)) + (forward-line -1) + (unless (looking-at "[0-9]+\t") + ;; Remove corrupted lines + (gnus-message 1 "Overview %s is corrupted. Removing corrupted lines..." file) + (goto-char (point-min)) + (while (not (eobp)) + (if (looking-at "[0-9]+\t") + (forward-line 1) + (delete-region (point) (progn (forward-line 1) (point))))) + (forward-line -1)) + (unless (or (= (point-min) (point-max)) + (< (setq last (read (current-buffer))) (car articles))) + ;; We do it the hard way. + (when (nnheader-find-nov-line (car articles)) + ;; Replacing existing NOV entry + (delete-region (point) (progn (forward-line 1) (point)))) + (gnus-agent-copy-nov-line (pop articles)) + + (ignore-errors + (while articles + (while (let ((art (read (current-buffer)))) + (cond ((< art (car articles)) + (forward-line 1) + t) + ((= art (car articles)) + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point))) + nil) + (t + (beginning-of-line) + nil)))) + + (gnus-agent-copy-nov-line (pop articles))))) + + ;; Copy the rest lines + (set-buffer nntp-server-buffer) + (goto-char (point-max)) (when articles - (let (b e) + (when last (set-buffer gnus-agent-overview-buffer) - (setq b (point) - e (point-max)) - (set-buffer nntp-server-buffer) - (insert-buffer-substring gnus-agent-overview-buffer b e))))) - -(defun gnus-agent-load-alist (group &optional dir) - "Load the article-state alist for GROUP." - (setq gnus-agent-article-alist - (gnus-agent-read-file - (if dir - (expand-file-name ".agentview" dir) - (gnus-agent-article-name ".agentview" group))))) + (ignore-errors + (while (<= (read (current-buffer)) last) + (forward-line 1))) + (beginning-of-line) + (setq start (point)) + (set-buffer nntp-server-buffer)) + (insert-buffer-substring gnus-agent-overview-buffer start)))) + +(eval-when-compile ; Keeps the compiler from warning about the free variable in gnus-agent-read-agentview + (defvar gnus-agent-read-agentview)) + +(defun gnus-agent-load-alist (group) + (let ((gnus-agent-read-agentview group)) ; Binds free variable that's used in gnus-agent-read-agentview + "Load the article-state alist for GROUP." + (setq gnus-agent-article-alist + (gnus-cache-file-contents + (gnus-agent-article-name ".agentview" group) + 'gnus-agent-file-loading-cache + 'gnus-agent-read-agentview)))) + +;; Save format may be either 1 or 2. Two is the new, compressed format that is still being tested. Format 1 is uncompressed but known to be reliable. +(defconst gnus-agent-article-alist-save-format 2) + +(defun gnus-agent-read-agentview (file) + "Load FILE and do a `read' there." + (with-temp-buffer + (ignore-errors + (nnheader-insert-file-contents file) + (goto-char (point-min)) + (let ((alist (read (current-buffer))) + (version (condition-case nil (read (current-buffer)) + (end-of-file 0))) + changed-version) + + (cond ((= version 0) + (let ((inhibit-quit t) + entry) + (gnus-agent-open-history) + (set-buffer (gnus-agent-history-buffer)) + (goto-char (point-min)) + (while (not (eobp)) + (if (and (looking-at + "[^\t\n]+\t\\([0-9]+\\)\t\\([^ \n]+\\) \\([0-9]+\\)") + (string= (match-string 2) + gnus-agent-read-agentview) + (setq entry (assoc (string-to-number (match-string 3)) alist))) + (setcdr entry (string-to-number (match-string 1)))) + (forward-line 1)) + (gnus-agent-close-history) + (setq changed-version t))) + ((= version 1) + (setq changed-version (not (= 1 gnus-agent-article-alist-save-format)))) + ((= version 2) + (let (uncomp) + (mapcar (lambda (comp-list) + (let ((state (car comp-list)) + (sequence (gnus-uncompress-sequence (cdr comp-list)))) + (mapcar (lambda (article-id) + (setq uncomp (cons (cons article-id state) uncomp))) sequence))) alist) + (setq alist (sort uncomp (lambda (first second) (< (car first) (car second))))) + ) + )) + (when changed-version + (let ((gnus-agent-article-alist alist)) + (gnus-agent-save-alist gnus-agent-read-agentview))) + alist)))) (defun gnus-agent-save-alist (group &optional articles state dir) "Save the article-state alist for GROUP." - (let ((file-name-coding-system nnmail-pathname-coding-system) - print-level print-length) - (with-temp-file (if dir - (expand-file-name ".agentview" dir) - (gnus-agent-article-name ".agentview" group)) - (princ (setq gnus-agent-article-alist - (nconc gnus-agent-article-alist - (mapcar (lambda (article) (cons article state)) - articles))) - (current-buffer)) - (insert "\n")))) + (let* ((file-name-coding-system nnmail-pathname-coding-system) + (prev (cons nil gnus-agent-article-alist)) + (all prev) + print-level print-length item article) + (while (setq article (pop articles)) + (while (and (cdr prev) + (< (caadr prev) article)) + (setq prev (cdr prev))) + (cond + ((not (cdr prev)) + (setcdr prev (list (cons article state)))) + ((> (caadr prev) article) + (setcdr prev (cons (cons article state) (cdr prev)))) + ((= (caadr prev) article) + (setcdr (cadr prev) state))) + (setq prev (cdr prev))) + (setq gnus-agent-article-alist (cdr all)) + (with-temp-file (if dir + (expand-file-name ".agentview" dir) + (gnus-agent-article-name ".agentview" group)) + (cond ((eq gnus-agent-article-alist-save-format 1) + (princ gnus-agent-article-alist (current-buffer))) + ((eq gnus-agent-article-alist-save-format 2) + (let ((compressed nil)) + (mapcar (lambda (pair) + (let* ((article-id (car pair)) + (day-of-download (cdr pair)) + (comp-list (assq day-of-download compressed))) + (if comp-list + (setcdr comp-list (cons article-id (cdr comp-list))) + (setq compressed (cons (list day-of-download article-id) compressed))) + nil)) gnus-agent-article-alist) + (mapcar (lambda (comp-list) (setcdr comp-list (gnus-compress-sequence (nreverse (cdr comp-list))))) compressed) + (princ compressed (current-buffer)) + ) + ) + ) + (insert "\n") + (princ gnus-agent-article-alist-save-format (current-buffer)) + (insert "\n")))) (defun gnus-agent-article-name (article group) (expand-file-name (if (stringp article) article (string-to-number article)) @@ -1139,23 +1406,25 @@ the actual number of articles toggled is returned." (condition-case err (progn (setq gnus-command-method (car methods)) - (when (or (gnus-server-opened gnus-command-method) - (gnus-open-server gnus-command-method)) + (when (and (or (gnus-server-opened gnus-command-method) + (gnus-open-server gnus-command-method)) + (gnus-online gnus-command-method)) (setq groups (gnus-groups-from-server (car methods))) (gnus-agent-with-fetch (while (setq group (pop groups)) (when (<= (gnus-group-level group) gnus-agent-handle-level) (gnus-agent-fetch-group-1 group gnus-command-method)))))) (error - (unless (funcall gnus-agent-confirmation-function - (format "Error (%s). Continue? " err)) - (error "Cannot fetch articles into the Gnus agent"))) + (unless (funcall gnus-agent-confirmation-function + (format "Error %s. Continue? " (cdr err))) + (error "Cannot fetch articles into the Gnus agent"))) (quit (unless (funcall gnus-agent-confirmation-function - (format "Quit fetching session (%s). Continue? " - err)) + (format "Quit fetching session %s. Continue? " + (cdr err))) (signal 'quit "Cannot fetch articles into the Gnus agent")))) (pop methods)) + (run-hooks 'gnus-agent-fetch-hook) (gnus-message 6 "Finished fetching articles into the Gnus agent")))) (defun gnus-agent-fetch-group-1 (group method) @@ -1185,6 +1454,11 @@ the actual number of articles toggled is returned." (setq gnus-newsgroup-headers (gnus-get-newsgroup-headers-xover articles nil nil group)) + ;; Some articles may not exist, so update `articles' + ;; from what was actually found. -- kai + (setq articles + (mapcar (lambda (x) (mail-header-number x)) + gnus-newsgroup-headers)) ;; `gnus-agent-overview-buffer' may be killed for ;; timeout reason. If so, recreate it. (gnus-agent-create-buffer))) @@ -1210,30 +1484,37 @@ the actual number of articles toggled is returned." (setq score-param (list (list score-param))))) (when score-param (gnus-score-headers score-param)) - (while (setq gnus-headers (pop gnus-newsgroup-headers)) - (setq gnus-score - (or (cdr (assq (mail-header-number gnus-headers) - gnus-newsgroup-scored)) - gnus-summary-default-score)) - (when (funcall predicate) - (push (mail-header-number gnus-headers) - arts)))) + + ;; Construct arts list with same order as gnus-newsgroup-headers + (let* ((a (list nil)) + (b a)) + (while (setq gnus-headers (pop gnus-newsgroup-headers)) + (setq gnus-score + (or (cdr (assq (mail-header-number gnus-headers) + gnus-newsgroup-scored)) + gnus-summary-default-score)) + (when (funcall predicate) + (setq a (setcdr a (list (mail-header-number gnus-headers)))))) + (setq arts (cdr b)))) + ;; Fetch the articles. (when arts (gnus-agent-fetch-articles group arts))) ;; Perhaps we have some additional articles to fetch. - (setq arts (assq 'download (gnus-info-marks - (setq info (gnus-get-info group))))) - (when (cdr arts) - (gnus-message 8 "Agent is downloading marked articles...") - (gnus-agent-fetch-articles - group (gnus-uncompress-range (cdr arts))) - (setq marks (delq arts (gnus-info-marks info))) - (gnus-info-set-marks info marks) - (gnus-dribble-enter - (concat "(gnus-group-set-info '" - (gnus-prin1-to-string info) - ")"))))) + (dolist (mark gnus-agent-download-marks) + (setq arts (assq mark (gnus-info-marks + (setq info (gnus-get-info group))))) + (when (cdr arts) + (gnus-message 8 "Agent is downloading marked articles...") + (gnus-agent-fetch-articles + group (gnus-uncompress-range (cdr arts))) + (when (eq mark 'download) + (setq marks (delq arts (gnus-info-marks info))) + (gnus-info-set-marks info marks) + (gnus-dribble-enter + (concat "(gnus-group-set-info '" + (gnus-prin1-to-string info) + ")"))))))) ;;; ;;; Agent Category Mode @@ -1243,7 +1524,14 @@ the actual number of articles toggled is returned." "Hook run in `gnus-category-mode' buffers.") (defvar gnus-category-line-format " %(%20c%): %g\n" - "Format of category lines.") + "Format of category lines. + +Valid specifiers include: +%c Topic name (string) +%g The number of groups in the topic (integer) + +General format specifiers can also be used. See Info node +`(gnus)Formatting Variables'.") (defvar gnus-category-mode-line-format "Gnus: %%b" "The format specification for the category mode line.") @@ -1320,7 +1608,7 @@ the actual number of articles toggled is returned." All normal editing commands are switched off. \\ For more in-depth information on this mode, read the manual -(`\\[gnus-info-find-node]'). +\(`\\[gnus-info-find-node]'). The following commands are available: @@ -1378,7 +1666,7 @@ The following commands are available: (gnus-category-position-point))) (defun gnus-category-name () - (or (get-text-property (gnus-point-at-bol) 'gnus-category) + (or (intern (get-text-property (gnus-point-at-bol) 'gnus-category)) (error "No category on the current line"))) (defun gnus-category-read () @@ -1479,6 +1767,7 @@ The following commands are available: (long . gnus-agent-long-p) (low . gnus-agent-low-scored-p) (high . gnus-agent-high-scored-p) + (read . gnus-agent-read-p) (true . gnus-agent-true) (false . gnus-agent-false)) "Mapping from short score predicate symbols to predicate functions.") @@ -1510,6 +1799,11 @@ The following commands are available: "Say whether an article has a high score or not." (> gnus-score gnus-agent-high-score)) +(defun gnus-agent-read-p () + "Say whether an article is read or not." + (gnus-member-of-range (mail-header-number gnus-headers) + (gnus-info-read (gnus-get-info gnus-newsgroup-name)))) + (defun gnus-category-make-function (cat) "Make a function from category CAT." (let ((func (gnus-category-make-function-1 cat))) @@ -1550,9 +1844,19 @@ The following commands are available: (defun gnus-get-predicate (predicate) "Return the predicate for CATEGORY." (or (cdr (assoc predicate gnus-category-predicate-cache)) - (cdar (push (cons predicate - (gnus-category-make-function predicate)) - gnus-category-predicate-cache)))) + (let ((func (gnus-category-make-function predicate))) + (setq gnus-category-predicate-cache + (nconc gnus-category-predicate-cache + (list (cons predicate func)))) + func))) + +(defun gnus-predicate-implies-unread (predicate) + "Say whether PREDICATE implies unread articles only. +It is okay to miss some cases, but there must be no false positives. +That is, if this function returns true, then indeed the predicate must +return only unread articles." + ;; Todo: make this work in more cases. + (equal predicate '(not read))) (defun gnus-group-category (group) "Return the category GROUP belongs to." @@ -1567,192 +1871,699 @@ The following commands are available: (or (gnus-gethash group gnus-category-group-cache) (assq 'default gnus-category-alist))) -(defun gnus-agent-expire () - "Expire all old articles." +(defun gnus-agent-expire (&optional articles group force) + "Expire all old articles. +If you want to force expiring of certain articles, this function can +take ARTICLES, GROUP and FORCE parameters as well. + +The articles on which the expiration process runs are selected as follows: + if ARTICLES is null, all read and unmarked articles. + if ARTICLES is t, all articles. + if ARTICLES is a list, just those articles. +Setting GROUP will limit expiration to that group. +FORCE is equivalent to setting gnus-agent-expire-days to zero(0)." (interactive) - (let ((methods gnus-agent-covered-methods) - (day (- (time-to-days (current-time)) gnus-agent-expire-days)) - gnus-command-method sym group articles - history overview file histories elem art nov-file low info - unreads marked article orig lowest highest) - (save-excursion - (setq overview (gnus-get-buffer-create " *expire overview*")) - (while (setq gnus-command-method (pop methods)) - (when (file-exists-p (gnus-agent-lib-file "active")) - (with-temp-buffer - (nnheader-insert-file-contents (gnus-agent-lib-file "active")) - (gnus-active-to-gnus-format - gnus-command-method - (setq orig (gnus-make-hashtable - (count-lines (point-min) (point-max)))))) - (let ((expiry-hashtb (gnus-make-hashtable 1023))) - (gnus-agent-open-history) - (set-buffer - (setq gnus-agent-current-history - (setq history (gnus-agent-history-buffer)))) - (goto-char (point-min)) - (when (> (buffer-size) 1) - (goto-char (point-min)) - (while (not (eobp)) - (skip-chars-forward "^\t") - (if (let ((fetch-date (read (current-buffer)))) - (if (numberp fetch-date) - (> fetch-date day) - ;; History file is corrupted. - (gnus-message - 5 - (format "File %s is corrupted!" - (gnus-agent-lib-file "history"))) - (sit-for 1) - ;; Ignore it - t)) - ;; New article; we don't expire it. - (forward-line 1) - ;; Old article. Schedule it for possible nuking. - (while (not (eolp)) - (setq sym (let ((obarray expiry-hashtb) s) - (setq s (read (current-buffer))) - (if (stringp s) (intern s) s))) - (if (boundp sym) - (set sym (cons (cons (read (current-buffer)) (point)) - (symbol-value sym))) - (set sym (list (cons (read (current-buffer)) (point))))) - (skip-chars-forward " ")) - (forward-line 1))) - ;; We now have all articles that can possibly be expired. - (mapatoms - (lambda (sym) - (setq group (symbol-name sym) - articles (sort (symbol-value sym) 'car-less-than-car) - low (car (gnus-active group)) - info (gnus-get-info group) - unreads (ignore-errors - (gnus-list-of-unread-articles group)) - marked (nconc - (gnus-uncompress-range - (cdr (assq 'tick (gnus-info-marks info)))) - (gnus-uncompress-range - (cdr (assq 'dormant - (gnus-info-marks info))))) - nov-file (gnus-agent-article-name ".overview" group) - lowest nil - highest nil) - (gnus-agent-load-alist group) - (gnus-message 5 "Expiring articles in %s" group) - (set-buffer overview) - (erase-buffer) - (when (file-exists-p nov-file) - (nnheader-insert-file-contents nov-file)) - (goto-char (point-min)) - (setq article 0) - (while (setq elem (pop articles)) - (setq article (car elem)) - (when (or (null low) - (< article low) - gnus-agent-expire-all - (and (not (memq article unreads)) - (not (memq article marked)))) - ;; Find and nuke the NOV line. - (while (and (not (eobp)) - (or (not (numberp - (setq art (read (current-buffer))))) - (< art article))) - (if (and (numberp art) - (file-exists-p - (gnus-agent-article-name - (number-to-string art) group))) - (progn - (unless lowest - (setq lowest art)) - (setq highest art) - (forward-line 1)) - ;; Remove old NOV lines that have no articles. - (gnus-delete-line))) - (if (or (eobp) - (/= art article)) - (beginning-of-line) - (gnus-delete-line)) - ;; Nuke the article. - (when (file-exists-p - (setq file (gnus-agent-article-name - (number-to-string article) - group))) - (delete-file file)) - ;; Schedule the history line for nuking. - (push (cdr elem) histories))) - (gnus-make-directory (file-name-directory nov-file)) - (let ((coding-system-for-write - gnus-agent-file-coding-system)) - (write-region (point-min) (point-max) nov-file nil 'silent)) - ;; Delete the unwanted entries in the alist. - (setq gnus-agent-article-alist - (sort gnus-agent-article-alist 'car-less-than-car)) - (let* ((alist gnus-agent-article-alist) - (prev (cons nil alist)) - (first prev) - expired) - (while (and alist - (<= (caar alist) article)) - (if (or (not (cdar alist)) - (not (file-exists-p - (gnus-agent-article-name - (number-to-string - (caar alist)) - group)))) - (progn - (push (caar alist) expired) - (setcdr prev (setq alist (cdr alist)))) - (setq prev alist - alist (cdr alist)))) - (setq gnus-agent-article-alist (cdr first)) - (gnus-agent-save-alist group) - ;; Mark all articles up to the first article - ;; in `gnus-article-alist' as read. - (when (and info (caar gnus-agent-article-alist)) - (setcar (nthcdr 2 info) - (gnus-range-add - (nth 2 info) - (cons 1 (- (caar gnus-agent-article-alist) 1))))) - ;; Maybe everything has been expired from `gnus-article-alist' - ;; and so the above marking as read could not be conducted, - ;; or there are expired article within the range of the alist. - (when (and info - expired - (or (not (caar gnus-agent-article-alist)) - (> (car expired) - (caar gnus-agent-article-alist)))) - (setcar (nthcdr 2 info) - (gnus-add-to-range - (nth 2 info) - (nreverse expired)))) - (gnus-dribble-enter - (concat "(gnus-group-set-info '" - (gnus-prin1-to-string info) - ")"))) - (when lowest - (if (gnus-gethash group orig) - (setcar (gnus-gethash group orig) lowest) - (gnus-sethash group (cons lowest highest) orig)))) - expiry-hashtb) - (set-buffer history) - (setq histories (nreverse (sort histories '<))) - (while histories - (goto-char (pop histories)) - (gnus-delete-line)) - (gnus-agent-save-history) - (gnus-agent-close-history) - (gnus-write-active-file - (gnus-agent-lib-file "active") orig)) - (gnus-message 4 "Expiry...done"))))))) + + (if (or (not (eq articles t)) + (yes-or-no-p (concat "Are you sure that you want to expire all articles in " (if group group "every agentized group") "."))) + (let ((methods (if group + (list (gnus-find-method-for-group group)) + gnus-agent-covered-methods)) + (day (if (numberp gnus-agent-expire-days) + (- (time-to-days (current-time)) gnus-agent-expire-days) + nil)) + gnus-command-method sym arts pos + history overview file histories elem art nov-file low info + unreads marked article orig lowest highest found days) + (save-excursion + (setq overview (gnus-get-buffer-create " *expire overview*")) + (unwind-protect + (while (setq gnus-command-method (pop methods)) + (when (file-exists-p (gnus-agent-lib-file "active")) + (with-temp-buffer + (nnheader-insert-file-contents (gnus-agent-lib-file "active")) + (gnus-active-to-gnus-format + gnus-command-method + (setq orig (gnus-make-hashtable + (count-lines (point-min) (point-max)))))) + (dolist (expiring-group (gnus-groups-from-server gnus-command-method)) + (if (or (not group) + (equal group expiring-group)) + (let* ((dir (concat + (gnus-agent-directory) + (gnus-agent-group-path expiring-group) "/")) + (active + (gnus-gethash-safe expiring-group orig))) + (when active + (gnus-agent-load-alist expiring-group) + (gnus-message 5 "Expiring articles in %s" expiring-group) + (let* ((info (gnus-get-info expiring-group)) + (alist gnus-agent-article-alist) + (specials (if alist + (list (caar (last alist))))) + (unreads ;; Articles that are excluded from the expiration process + (cond (gnus-agent-expire-all + ;; All articles are marked read by global decree + nil) + ((eq articles t) + ;; All articles are marked read by function parameter + nil) + ((not articles) + ;; Unread articles are marked protected from expiration + ;; Don't call gnus-list-of-unread-articles as it returns articles that have not been fetched into the agent. + (ignore-errors (gnus-agent-unread-articles expiring-group))) + (t + ;; All articles EXCEPT those named by the caller are protected from expiration + (gnus-sorted-difference (gnus-uncompress-range (cons (caar alist) (caar (last alist)))) (sort articles '<))))) + (marked ;; More articles that are exluded from the expiration process + (cond (gnus-agent-expire-all + ;; All articles are unmarked by global decree + nil) + ((eq articles t) + ;; All articles are unmarked by function parameter + nil) + (articles + ;; All articles may as well be unmarked as the unreads list already names the articles we are going to keep + nil) + (t + ;; Ticked and/or dormant articles are excluded from expiration + (nconc + (gnus-uncompress-range + (cdr (assq 'tick (gnus-info-marks info)))) + (gnus-uncompress-range + (cdr (assq 'dormant + (gnus-info-marks info)))))) + )) + (nov-file (concat dir ".overview")) + (cnt 0) + (completed -1) + dlist + type) + + ;; The normal article alist contains elements that look like (article# . fetch_date) + ;; I need to combine other information with this list. For example, a flag indicating that a particular article MUST BE KEPT. + ;; To do this, I'm going to transform the elements to look like (article# fetch_date keep_flag NOV_entry_marker) + ;; Later, I'll reverse the process to generate the expired article alist. + + ;; Convert the alist elements to (article# fetch_date nil nil). + (setq dlist (mapcar (lambda (e) (list (car e) (cdr e) nil nil)) alist)) + + ;; Convert the keep lists to elements that look like (article# nil keep_flag nil) then append it to the expanded dlist + ;; These statements are sorted by ascending precidence of the keep_flag. + (setq dlist (nconc dlist + (mapcar (lambda (e) (list e nil 'unread nil)) unreads))) + (setq dlist (nconc dlist + (mapcar (lambda (e) (list e nil 'marked nil)) marked))) + (setq dlist (nconc dlist + (mapcar (lambda (e) (list e nil 'special nil)) specials))) + + (set-buffer overview) + (erase-buffer) + (when (file-exists-p nov-file) + (gnus-message 7 "gnus-agent-expire: Loading overview...") + (nnheader-insert-file-contents nov-file) + (goto-char (point-min)) + + (let (p) + (while (< (setq p (point)) (point-max)) + (condition-case nil + ;; If I successfully read an integer (the plus zero ensures a numeric type), prepend a marker entry to the list + (push (list (+ 0 (read (current-buffer))) nil nil (set-marker (make-marker) p)) dlist) + (error + (gnus-message 1 "gnus-agent-expire: read error occurred when reading expression at %s in %s. Skipping to next line." (point) nov-file))) + ;; Whether I succeeded, or failed, it doesn't matter. Move to the next line then try again. + (forward-line 1))) + (gnus-message 7 "gnus-agent-expire: Loading overview... Done")) + (set-buffer-modified-p nil) + + ;; At this point, all of the information is in dlist. The only problem is that much of it is spread across multiple entries. Sort then MERGE!! + (gnus-message 7 "gnus-agent-expire: Sorting entries... ") + (setq dlist + (let ((special 0) ; If two entries have the same article-number then sort by ascending keep_flag. + (marked 1) + (unread 2) + ;(nil 3) + ) + (sort dlist (function (lambda (a b) + (cond ((< (nth 0 a) (nth 0 b)) + t) + ((> (nth 0 a) (nth 0 b)) + nil) + (t + (let ((a (or (symbol-value (nth 2 a)) 3)) + (b (or (symbol-value (nth 2 b)) 3))) + (<= a b))))))))) + (gnus-message 7 "gnus-agent-expire: Sorting entries... Done") + (gnus-message 7 "gnus-agent-expire: Merging entries... ") + (let ((dlist dlist)) + (while (cdr dlist) ; I'm not at the end-of-list + (if (eq (caar dlist) (caadr dlist)) + (let ((first (cdr (car dlist))) + (secnd (cdr (cadr dlist)))) + (setcar first (or (car first) (car secnd))) ; fetch_date + (setq first (cdr first) + secnd (cdr secnd)) + (setcar first (or (car first) (car secnd))) ; Keep_flag + (setq first (cdr first) + secnd (cdr secnd)) + (setcar first (or (car first) (car secnd))) ; NOV_entry_marker + + (setcdr dlist (cddr dlist))) + (setq dlist (cdr dlist))))) + (gnus-message 7 "gnus-agent-expire: Merging entries... Done") + + (let* ((len (float (length dlist))) + (alist (list nil)) + (tail-alist alist)) + (while dlist + (let ((new-completed (* 100.0 (/ (setq cnt (1+ cnt)) len)))) + (when (> new-completed completed) + (setq completed new-completed) + (gnus-message 9 "%3d%% completed..." completed))) + (let* ((entry (car dlist)) + (article-number (nth 0 entry)) + (fetch-date (nth 1 entry)) + (keep (nth 2 entry)) + (marker (nth 3 entry))) + + (cond + ;; Kept articles are unread, marked, or special. + (keep + (when fetch-date + (unless (file-exists-p (concat dir (number-to-string article-number))) + (setf (nth 1 entry) nil) + (gnus-message 3 "gnus-agent-expire cleared download flag on article %d as the cached article file is missing." (caar dlist))) + (unless marker + (gnus-message 1 "gnus-agent-expire detected a missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) + (gnus-agent-append-to-list tail-alist (cons article-number fetch-date))) + + ;; The following articles are READ, UNMARKED, and ORDINARY. + ;; See if they can be EXPIRED!!! + ((setq type + (cond + ((not (integerp fetch-date)) + 'read) ;; never fetched article (may expire right now) + ((not (file-exists-p (concat dir (number-to-string article-number)))) + (setf (nth 1 entry) nil) + 'externally-expired) ;; Can't find the cached article. Handle case as though this article was never fetched. + + ;; We now have the arrival day, so we see + ;; whether it's old enough to be expired. + ((< fetch-date + (if (numberp day) + day + (let (found + (days gnus-agent-expire-days)) + (while (and (not found) + days) + (when (eq 0 (string-match (caar days) expiring-group)) + (setq found (cadar days))) + (pop days)) + found))) + 'expired) + (force + 'forced))) + + ;; I found some reason to expire this entry. + + (let ((actions nil)) + (when (memq type '(forced expired)) + (ignore-errors ; Just being paranoid. + (delete-file (concat dir (number-to-string article-number))) + (push "expired cached article" actions)) + (setf (nth 1 entry) nil) + ) + + (when marker + (push "NOV entry removed" article) + (goto-char marker) + (gnus-delete-line)) + + ;; If considering all articles is set, I can only expire article IDs that are no longer in the active range. + (if (and gnus-agent-consider-all-articles + (>= article-number (car active))) + ;; I have to keep this ID in the alist + (gnus-agent-append-to-list tail-alist (cons article-number fetch-date)) + (push (format "Removed %s article number from article alist" type) actions)) + + (gnus-message 7 "gnus-agent-expire: Article %d: %s" article-number (mapconcat 'identity actions ", ")))) + ) + + ;; Clean up markers as I want to recycle this buffer over several groups. + (when marker + (set-marker marker nil)) + + (setq dlist (cdr dlist)))) + + (setq alist (cdr alist)) + + (let ((inhibit-quit t)) + (unless (equal alist gnus-agent-article-alist) + (setq gnus-agent-article-alist alist) + (gnus-agent-save-alist expiring-group)) + + (when (buffer-modified-p) + (let ((coding-system-for-write + gnus-agent-file-coding-system)) + (gnus-make-directory dir) + (write-region (point-min) (point-max) nov-file nil 'silent) + ;; clear the modified flag as that I'm not confused by its status on the next pass through this routine. + (set-buffer-modified-p nil)) + ) + + (when (eq articles t) + (gnus-summary-update-info)) + ))))))))) + (kill-buffer overview))))) + (gnus-message 4 "Expiry...done")) ;;;###autoload (defun gnus-agent-batch () + "Start Gnus, send queue and fetch session." (interactive) (let ((init-file-user "") (gnus-always-read-dribble-file t)) (gnus)) - (gnus-group-send-drafts) - (gnus-agent-fetch-session)) + (let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation)) + (gnus-group-send-queue) + (gnus-agent-fetch-session))) + +(defun gnus-agent-unread-articles (group) + (let* ((read (gnus-info-read (gnus-get-info group))) + (known (gnus-agent-load-alist group)) + (unread (list nil)) + (tail-unread unread)) + (while (and known read) + (let ((candidate (car (pop known)))) + (while (let* ((range (car read)) + (min (if (numberp range) range (car range))) + (max (if (numberp range) range (cdr range)))) + (cond ((or (not min) + (< candidate min)) + (gnus-agent-append-to-list tail-unread candidate) + nil) + ((> candidate max) + (pop read))))))) + (while known + (gnus-agent-append-to-list tail-unread (car (pop known)))) + (cdr unread))) + +(defun gnus-agent-uncached-articles (articles group &optional cached-header) + "Constructs sublist of ARTICLES that excludes those articles ids in GROUP that have already been fetched. + If CACHED-HEADER is nil, articles are only excluded if the article itself has been fetched." + +;; Logically equivalent to: (gnus-sorted-difference articles (mapcar 'car gnus-agent-article-alist)) +;; Functionally, I don't need to construct a temp list using mapcar. + + (if (gnus-agent-load-alist group) + (let* ((ref gnus-agent-article-alist) + (arts articles) + (uncached (list nil)) + (tail-uncached uncached)) + (while (and ref arts) + (let ((v1 (car arts)) + (v2 (caar ref))) + (cond ((< v1 v2) ; the article (v1) does not appear in the reference list + (gnus-agent-append-to-list tail-uncached v1) + (pop arts)) + ((= v1 v2) + (unless (or cached-header (cdar ref)) ; the article (v1) is already cached + (gnus-agent-append-to-list tail-uncached v1)) + (pop arts) + (pop ref)) + (t ; the reference article (v2) preceeds the list being filtered + (pop ref))))) + (while arts + (gnus-agent-append-to-list tail-uncached (pop arts))) + (cdr uncached)) + ;; if gnus-agent-load-alist fails, no articles are cached. + articles)) + +(defun gnus-agent-retrieve-headers (articles group &optional fetch-old) + (save-excursion + (gnus-agent-create-buffer) + (let ((gnus-decode-encoded-word-function 'identity) + (file (gnus-agent-article-name ".overview" group)) + cached-articles uncached-articles) + (gnus-make-directory (nnheader-translate-file-chars + (file-name-directory file) t)) + + ;; Populate temp buffer with known headers + (when (file-exists-p file) + (with-current-buffer gnus-agent-overview-buffer + (erase-buffer) + (let ((nnheader-file-coding-system + gnus-agent-file-coding-system)) + (nnheader-insert-nov-file file (car articles))))) + + (if (setq uncached-articles (gnus-agent-uncached-articles articles group t)) + (progn + ;; Populate nntp-server-buffer with uncached headers + (set-buffer nntp-server-buffer) + (erase-buffer) + (let (gnus-agent-cache) ; Turn off agent cache + (cond ((not (eq 'nov (gnus-retrieve-headers + uncached-articles group fetch-old))) + (nnvirtual-convert-headers)) + ((eq 'nntp (car gnus-current-select-method)) + ;; The author of gnus-get-newsgroup-headers-xover reports that the XOVER command + ;; is commonly unreliable. The problem is that recently posted articles may not + ;; be entered into the NOV database in time to respond to my XOVER query. + ;; + ;; I'm going to use his assumption that the NOV database is updated in order + ;; of ascending article ID. Therefore, a response containing article ID N + ;; implies that all articles from 1 to N-1 are up-to-date. Therefore, + ;; missing articles in that range have expired. + + (set-buffer nntp-server-buffer) + (let* ((fetched-articles (list nil)) + (tail-fetched-articles fetched-articles) + (min (cond ((numberp fetch-old) + (max 1 (- (car articles) fetch-old))) + (fetch-old + 1) + (t + (car articles)))) + (max (car (last articles)))) + + ;; Get the list of articles that were fetched + (goto-char (point-min)) + (ignore-errors + (while t + (gnus-agent-append-to-list tail-fetched-articles (read (current-buffer))) + (forward-line 1))) + + ;; Clip this list to the headers that will actually be returned + (setq fetched-articles (gnus-list-range-intersection + (cdr fetched-articles) + (cons min max))) + + ;; Clip the uncached articles list to exclude IDs after the last FETCHED header. + ;; The excluded IDs may be fetchable using HEAD. + (if (car tail-fetched-articles) + (setq uncached-articles (gnus-list-range-intersection + uncached-articles + (cons (car uncached-articles) (car tail-fetched-articles))))) + + ;; Create the list of articles that were "successfully" fetched. Success, in + ;; this case, means that the ID should not be fetched again. In the case of + ;; an expired article, the header will not be fetched. + (setq uncached-articles (gnus-sorted-nunion fetched-articles uncached-articles)) + )))) + + ;; Erase the temp buffer + (set-buffer gnus-agent-overview-buffer) + (erase-buffer) + + ;; Copy the nntp-server-buffer to the temp buffer + (set-buffer nntp-server-buffer) + (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) + + ;; Merge the temp buffer with the known headers (found on disk in FILE) into the nntp-server-buffer + (when (and uncached-articles (file-exists-p file)) + (gnus-agent-braid-nov group uncached-articles file)) + + ;; Save the new set of known headers to FILE + (set-buffer nntp-server-buffer) + (let ((coding-system-for-write + gnus-agent-file-coding-system)) + (gnus-agent-check-overview-buffer) + (write-region (point-min) (point-max) file nil 'silent)) + + ;; Update the group's article alist to include the newly fetched articles. + (gnus-agent-load-alist group) + (gnus-agent-save-alist group uncached-articles nil) + ) + + ;; Copy the temp buffer to the nntp-server-buffer + (set-buffer nntp-server-buffer) + (erase-buffer) + (insert-buffer-substring gnus-agent-overview-buffer))) + + (if (and fetch-old + (not (numberp fetch-old))) + t ; Don't remove anything. + (nnheader-nov-delete-outside-range + (if fetch-old (max 1 (- (car articles) fetch-old)) + (car articles)) + (car (last articles))) + t) + + 'nov)) + +(defun gnus-agent-request-article (article group) + "Retrieve ARTICLE in GROUP from the agent cache." + (let* ((gnus-command-method (gnus-find-method-for-group group)) + (file (concat + (gnus-agent-directory) + (gnus-agent-group-path group) "/" + (number-to-string article))) + (buffer-read-only nil)) + (when (and (file-exists-p file) + (> (nth 7 (file-attributes file)) 0)) + (erase-buffer) + (gnus-kill-all-overlays) + (let ((coding-system-for-read gnus-cache-coding-system)) + (insert-file-contents file)) + t))) + +(defun gnus-agent-regenerate-group (group &optional reread) + "Regenerate GROUP. If REREAD is t, all articles in the .overview are marked as unread. If REREAD is not nil, downloaded articles are marked as unread." + (gnus-message 5 "Regenerating in %s" group) + (let* ((gnus-command-method (or gnus-command-method + (gnus-find-method-for-group group))) + (file (gnus-agent-article-name ".overview" group)) + (dir (file-name-directory file)) + point + (downloaded (if (file-exists-p dir) + (sort (mapcar (lambda (name) (string-to-int name)) + (directory-files dir nil "^[0-9]+$" t)) + '>) + (progn (gnus-make-directory dir) nil))) + dl nov-arts + alist header + regenerated) + + (mm-with-unibyte-buffer + (if (file-exists-p file) + (let ((nnheader-file-coding-system + gnus-agent-file-coding-system)) + (nnheader-insert-file-contents file))) + (set-buffer-modified-p nil) + + ;; Load the article IDs found in the overview file. As a side-effect, validate the file contents. + (let ((load t)) + (while load + (setq load nil) + (goto-char (point-min)) + (while (< (point) (point-max)) + (cond ((looking-at "[0-9]+\t") + (push (read (current-buffer)) nov-arts) + (forward-line 1) + (let ((l1 (car nov-arts)) + (l2 (cadr nov-arts))) + (cond ((not l2) + nil) + ((< l1 l2) + (gnus-message 3 "gnus-agent-regenerate-group: NOV entries are NOT in ascending order.") + ;; Don't sort now as I haven't verified that every line begins with a number + (setq load t)) + ((= l1 l2) + (forward-line -1) + (gnus-message 4 "gnus-agent-regenerate-group: NOV entries contained duplicate of article %s. Duplicate deleted." l1) + (gnus-delete-line) + (pop nov-arts))))) + (t + (gnus-message 1 "gnus-agent-regenerate-group: NOV entries contained line that did not begin with an article number. Deleted line.") + (gnus-delete-line)))) + (if load + (progn + (gnus-message 5 "gnus-agent-regenerate-group: Sorting NOV entries into ascending order.") + (sort-numeric-fields 1 (point-min) (point-max)) + (setq nov-arts nil))))) + (gnus-agent-check-overview-buffer) + + ;; Construct a new article alist whose nodes match every header in the .overview file. + ;; As a side-effect, missing headers are reconstructed from the downloaded article file. + (while (or downloaded nov-arts) + (cond ((and downloaded + (or (not nov-arts) + (> (car downloaded) (car nov-arts)))) + ;; This entry is missing from the overview file + (gnus-message 3 "Regenerating NOV %s %d..." group (car downloaded)) + (let ((file (concat dir (number-to-string (car downloaded))))) + (mm-with-unibyte-buffer + (nnheader-insert-file-contents file) + (nnheader-remove-body) + (setq header (nnheader-parse-naked-head))) + (mail-header-set-number header (car downloaded)) + (if nov-arts + (let ((key (concat "^" (int-to-string (car nov-arts)) "\t"))) + (or (re-search-backward key nil t) + (re-search-forward key)) + (forward-line 1)) + (goto-char (point-min))) + (nnheader-insert-nov header)) + (setq nov-arts (cons (car downloaded) nov-arts))) + ((eq (car downloaded) (car nov-arts)) + ;; This entry in the overview has been downloaded + (push (cons (car downloaded) (time-to-days (nth 5 (file-attributes (concat dir (number-to-string (car downloaded))))))) alist) + (pop downloaded) + (pop nov-arts)) + (t + ;; This entry in the overview has not been downloaded + (push (cons (car nov-arts) nil) alist) + (pop nov-arts)))) + + ;; When gnus-agent-consider-all-articles is set, gnus-agent-regenerate-group should NOT remove article IDs + ;; from the alist. Those IDs serve as markers to indicate that an attempt has been made to fetch that + ;; article's header. + + ;; When gnus-agent-consider-all-articles is NOT set, gnus-agent-regenerate-group can remove the article + ;; ID of every article (with the exception of the last ID in the list - it's special) that no longer appears in the overview. + ;; In this situtation, the last article ID in the list implies that it, and every article ID preceeding it, + ;; have been fetched from the server. + (if gnus-agent-consider-all-articles + ;; Restore all article IDs that were not found in the overview file. + (let* ((n (cons nil alist)) + (merged n) + (o (gnus-agent-load-alist group))) + (while o + (let ((nID (caadr n)) + (oID (caar o))) + (cond ((not nID) + (setq n (setcdr n (list (list oID)))) + (pop o)) + ((< oID nID) + (setcdr n (cons (list oID) (cdr n))) + (pop o)) + ((= oID nID) + (pop o) + (pop n)) + (t + (pop n))))) + (setq alist (cdr merged))) + ;; Restore the last article ID if it is not already in the new alist + (let ((n (last alist)) + (o (last (gnus-agent-load-alist group)))) + (cond ((not n) + (when o + (push (cons (caar o) nil) alist))) + ((< (caar n) (caar o)) + (setcdr n (list (car o))))))) + + (let ((inhibit-quit t)) + (if (setq regenerated (buffer-modified-p)) + (let ((coding-system-for-write gnus-agent-file-coding-system)) + (write-region (point-min) (point-max) file nil 'silent))) + + (setq regenerated (or regenerated + (and reread gnus-agent-article-alist) + (not (equal alist gnus-agent-article-alist))) + ) + + (setq gnus-agent-article-alist alist) + + (when regenerated + (gnus-agent-save-alist group))) + ) + + (when (and reread gnus-agent-article-alist) + (gnus-make-ascending-articles-unread + group + (delq nil (mapcar (function (lambda (c) + (cond ((eq reread t) + (car c)) + ((cdr c) + (car c))))) + gnus-agent-article-alist))) + + (when (gnus-buffer-live-p gnus-group-buffer) + (gnus-group-update-group group t) + (sit-for 0)) + ) + + regenerated)) + +;;;###autoload +(defun gnus-agent-regenerate (&optional clean reread) + "Regenerate all agent covered files. +If CLEAN, don't read existing active files." + (interactive "P") + (let (regenerated) + (gnus-message 4 "Regenerating Gnus agent files...") + (dolist (gnus-command-method gnus-agent-covered-methods) + (let ((active-file (gnus-agent-lib-file "active")) + active-hashtb active-changed + point) + (gnus-make-directory (file-name-directory active-file)) + (if clean + (setq active-hashtb (gnus-make-hashtable 1000)) + (mm-with-unibyte-buffer + (if (file-exists-p active-file) + (let ((nnheader-file-coding-system + gnus-agent-file-coding-system)) + (nnheader-insert-file-contents active-file)) + (setq active-changed t)) + (gnus-active-to-gnus-format + nil (setq active-hashtb + (gnus-make-hashtable + (count-lines (point-min) (point-max))))))) + (dolist (group (gnus-groups-from-server gnus-command-method)) + (setq regenerated (or (gnus-agent-regenerate-group group reread) + regenerated)) + (let ((min (or (caar gnus-agent-article-alist) 1)) + (max (or (caar (last gnus-agent-article-alist)) 0)) + (active (gnus-gethash-safe (gnus-group-real-name group) + active-hashtb)) + (read (gnus-info-read (gnus-get-info group)))) + (if (not active) + (progn + (setq active (cons min max) + active-changed t) + (gnus-sethash group active active-hashtb)) + (when (> (car active) min) + (setcar active min) + (setq active-changed t)) + (when (< (cdr active) max) + (setcdr active max) + (setq active-changed t))))) + (when active-changed + (setq regenerated t) + (gnus-message 4 "Regenerate %s" active-file) + (let ((nnmail-active-file-coding-system gnus-agent-file-coding-system)) + (gnus-write-active-file active-file active-hashtb))))) + (gnus-message 4 "Regenerating Gnus agent files...done") + regenerated)) + +(defun gnus-agent-go-online (&optional force) + "Switch servers into online status." + (interactive (list t)) + (dolist (server gnus-opened-servers) + (when (eq (nth 1 server) 'offline) + (if (if (eq force 'ask) + (gnus-y-or-n-p + (format "Switch %s:%s into online status? " + (caar server) (cadar server))) + force) + (setcar (nthcdr 1 server) 'close))))) + +(defun gnus-agent-toggle-group-plugged (group) + "Toggle the status of the server of the current group." + (interactive (list (gnus-group-group-name))) + (let* ((method (gnus-find-method-for-group group)) + (status (cadr (assoc method gnus-opened-servers)))) + (if (eq status 'offline) + (gnus-server-set-status method 'closed) + (gnus-close-server method) + (gnus-server-set-status method 'offline)) + (message "Turn %s:%s from %s to %s." (car method) (cadr method) + (if (eq status 'offline) 'offline 'online) + (if (eq status 'offline) 'online 'offline)))) + +(defun gnus-agent-group-covered-p (group) + (member (gnus-group-method group) + gnus-agent-covered-methods)) (provide 'gnus-agent)