;;; gnus-agent.el --- unplugged support for Gnus
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003
+;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
(defcustom gnus-agent-fetched-hook nil
"Hook run when finished fetching articles."
+ :version "22.1"
:group 'gnus-agent
:type 'hook)
(defcustom gnus-agent-expire-days 7
"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."
+If you wish to disable Agent expiring, see `gnus-agent-enable-expiration'."
:group 'gnus-agent
- :type '(choice (number :tag "days")
- (sexp :tag "List" nil)))
+ :type '(number :tag "days"))
(defcustom gnus-agent-expire-all nil
"If non-nil, also expire unread, ticked and dormant articles.
:group 'gnus-agent
:type 'function)
-(defcustom gnus-agent-synchronize-flags 'ask
+(defcustom gnus-agent-synchronize-flags nil
"Indicate if flags are synchronized when you plug in.
If this is `ask' the hook will query the user."
:version "21.1"
(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"
+ :version "21.3"
:type '(choice (const :tag "Always" t)
(const :tag "Never" nil)
(const :tag "Ask" ask))
:group 'gnus-agent)
(defcustom gnus-agent-consider-all-articles nil
- "If non-nil, consider also the read articles for downloading."
- :version "21.4"
+ "When non-nil, the agent will let the agent predicate decide
+whether articles need to be downloaded or not, for all articles. When
+nil, the default, the agent will only let the predicate decide
+whether unread articles are downloaded or not. If you enable this,
+groups with large active ranges may open slower and you may also want
+to look into the agent expiry settings to block the expiration of
+read articles as they would just be downloaded again."
+ :version "22.1"
:type 'boolean
:group 'gnus-agent)
"Chunk size for `gnus-agent-fetch-session'.
The function will split its article fetches into chunks smaller than
this limit."
+ :version "22.1"
:group 'gnus-agent
:type 'integer)
to disable expiration in specific categories, topics, and groups. Of
course, you could change gnus-agent-enable-expiration to DISABLE then
enable expiration per categories, topics, and groups."
+ :version "22.1"
:group 'gnus-agent
:type '(radio (const :format "Enable " ENABLE)
(const :format "Disable " DISABLE)))
(defcustom gnus-agent-expire-unagentized-dirs t
-"Have gnus-agent-expire scan the directories under
-\(gnus-agent-directory) for groups that are no longer agentized. When
-found, offer to remove them.")
+ "*Whether expiration should expire in unagentized directories.
+Have gnus-agent-expire scan the directories under
+\(gnus-agent-directory) for groups that are no longer agentized.
+When found, offer to remove them."
+ :version "22.1"
+ :type 'boolean
+ :group 'gnus-agent)
+
+(defcustom 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'."
+ :version "22.1"
+ :type '(repeat symbol)
+ :group 'gnus-agent)
+
+(defcustom gnus-agent-queue-mail t
+ "Whether and when outgoing mail should be queued by the agent.
+When `always', always queue outgoing mail. When nil, never
+queue. Otherwise, queue if and only if unplugged."
+ :version "22.1"
+ :group 'gnus-agent
+ :type '(radio (const :format "Always" always)
+ (const :format "Never" nil)
+ (const :format "When plugged" t)))
+
+(defcustom gnus-agent-prompt-send-queue nil
+ "If non-nil, `gnus-group-send-queue' will prompt if called when
+unplugged."
+ :version "22.1"
+ :group 'gnus-agent
+ :type 'boolean)
;;; Internal variables
(defvar gnus-agent-history-buffers nil)
(defvar gnus-agent-buffer-alist nil)
(defvar gnus-agent-article-alist nil
- "An assoc list identifying the articles whose headers have been fetched.
+ "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
+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 function `gnus-agent-regenerate' may destructively modify the value.")
(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'.")
+(defvar gnus-agent-total-fetched-hashtb nil)
+(defvar gnus-agent-inhibit-update-total-fetched-for nil)
+(defvar gnus-agent-need-update-total-fetched-for nil)
;; Dynamic variables
(defvar gnus-headers)
;;; Utility functions
;;;
+(defmacro gnus-agent-with-refreshed-group (group &rest body)
+ "Performs the body then updates the group's line in the group
+buffer. Automatically blocks multiple updates due to recursion."
+`(prog1 (let ((gnus-agent-inhibit-update-total-fetched-for t)) ,@body)
+ (when (and gnus-agent-need-update-total-fetched-for
+ (not gnus-agent-inhibit-update-total-fetched-for))
+ (save-excursion
+ (set-buffer gnus-group-buffer)
+ (setq gnus-agent-need-update-total-fetched-for nil)
+ (gnus-group-update-group ,group t)))))
+
(defun gnus-agent-read-file (file)
"Load FILE and do a `read' there."
(with-temp-buffer
(setq category (cdr category)))))))
category)
-;; Fixme: These two can probably be in eval-when-compile.
-
-(defmacro gnus-agent-cat-defaccessor (name prop-name)
- "Define accessor and setter methods for manipulating a list of the form
+(eval-when-compile
+ (defmacro gnus-agent-cat-defaccessor (name prop-name)
+ "Define accessor and setter methods for manipulating a list of the form
\(NAME (PROPERTY1 VALUE1) ... (PROPERTY_N VALUE_N)).
Given the call (gnus-agent-cat-defaccessor func PROPERTY1), the list may be
manipulated as follows:
(func LIST): Returns VALUE1
(setf (func LIST) NEW_VALUE1): Replaces VALUE1 with NEW_VALUE1."
- `(progn (defmacro ,name (category)
- (list (quote cdr) (list (quote assq)
- (quote (quote ,prop-name)) category)))
-
- (define-setf-method ,name (category)
- (let* ((--category--temp-- (make-symbol "--category--"))
- (--value--temp-- (make-symbol "--value--")))
- (list (list --category--temp--) ; temporary-variables
- (list category) ; value-forms
- (list --value--temp--) ; store-variables
- (let* ((category --category--temp--) ; store-form
- (value --value--temp--))
- (list (quote gnus-agent-cat-set-property)
- category
- (quote (quote ,prop-name))
- value))
- (list (quote ,name) --category--temp--) ; access-form
- )))))
+ `(progn (defmacro ,name (category)
+ (list (quote cdr) (list (quote assq)
+ (quote (quote ,prop-name)) category)))
+
+ (define-setf-method ,name (category)
+ (let* ((--category--temp-- (make-symbol "--category--"))
+ (--value--temp-- (make-symbol "--value--")))
+ (list (list --category--temp--) ; temporary-variables
+ (list category) ; value-forms
+ (list --value--temp--) ; store-variables
+ (let* ((category --category--temp--) ; store-form
+ (value --value--temp--))
+ (list (quote gnus-agent-cat-set-property)
+ category
+ (quote (quote ,prop-name))
+ value))
+ (list (quote ,name) --category--temp--) ; access-form
+ )))))
+ )
(defmacro gnus-agent-cat-name (category)
`(car ,category))
(gnus-agent-cat-defaccessor
- gnus-agent-cat-days-until-old agent-days-until-old)
+ gnus-agent-cat-days-until-old agent-days-until-old)
+(gnus-agent-cat-defaccessor
+ gnus-agent-cat-enable-expiration agent-enable-expiration)
(gnus-agent-cat-defaccessor
- gnus-agent-cat-enable-expiration agent-enable-expiration)
+ gnus-agent-cat-groups agent-groups)
(gnus-agent-cat-defaccessor
- gnus-agent-cat-groups agent-groups)
+ gnus-agent-cat-high-score agent-high-score)
(gnus-agent-cat-defaccessor
- gnus-agent-cat-high-score agent-high-score)
+ gnus-agent-cat-length-when-long agent-long-article)
(gnus-agent-cat-defaccessor
- gnus-agent-cat-length-when-long agent-length-when-long)
+ gnus-agent-cat-length-when-short agent-short-article)
(gnus-agent-cat-defaccessor
- gnus-agent-cat-length-when-short agent-length-when-short)
+ gnus-agent-cat-low-score agent-low-score)
(gnus-agent-cat-defaccessor
- gnus-agent-cat-low-score agent-low-score)
+ gnus-agent-cat-predicate agent-predicate)
(gnus-agent-cat-defaccessor
- gnus-agent-cat-predicate agent-predicate)
+ gnus-agent-cat-score-file agent-score)
(gnus-agent-cat-defaccessor
- gnus-agent-cat-score-file agent-score-file)
+ gnus-agent-cat-enable-undownloaded-faces agent-enable-undownloaded-faces)
-(eval-when-compile
- (defsetf gnus-agent-cat-groups (category) (groups)
- (list 'gnus-agent-set-cat-groups category groups)))
+
+;; This form is equivalent to defsetf except that it calls make-symbol
+;; whereas defsetf calls gensym (Using gensym creates a run-time
+;; dependency on the CL library).
+
+(eval-and-compile
+ (define-setf-method gnus-agent-cat-groups (category)
+ (let* ((--category--temp-- (make-symbol "--category--"))
+ (--groups--temp-- (make-symbol "--groups--")))
+ (list (list --category--temp--)
+ (list category)
+ (list --groups--temp--)
+ (let* ((category --category--temp--)
+ (groups --groups--temp--))
+ (list (quote gnus-agent-set-cat-groups) category groups))
+ (list (quote gnus-agent-cat-groups) --category--temp--))))
+ )
(defun gnus-agent-set-cat-groups (category groups)
(unless (eq groups 'ignore)
buffer))))
minor-mode-map-alist))
(when (eq major-mode 'gnus-group-mode)
- (let ((init-plugged gnus-plugged))
+ (let ((init-plugged gnus-plugged)
+ (gnus-agent-go-online nil))
;; g-a-t-p does nothing when gnus-plugged isn't changed.
;; Therefore, make certain that the current value does not
;; match the desired initial value.
(if (and (fboundp 'propertize)
(fboundp 'make-mode-line-mouse-map))
(propertize string 'local-map
- (make-mode-line-mouse-map mouse-button mouse-func))
+ (make-mode-line-mouse-map mouse-button mouse-func)
+ 'mouse-face 'mode-line-highlight)
string))
(defun gnus-agent-toggle-plugged (set-to)
(defun gnus-agent-close-connections ()
"Close all methods covered by the Gnus agent."
- (let ((methods gnus-agent-covered-methods))
+ (let ((methods (gnus-agent-covered-methods)))
(while methods
(gnus-close-server (pop methods)))))
;;;###autoload
(defun gnus-agentize ()
"Allow Gnus to be an offline newsreader.
-The normal usage of this command is to put the following as the
-last form in your `.gnus.el' file:
-\(gnus-agentize)
+The gnus-agentize function is now called internally by gnus when
+gnus-agent is set. If you wish to avoid calling gnus-agentize,
+customize gnus-agent to nil.
This will modify the `gnus-setup-news-hook', and
`message-send-mail-real-function' variables, and install the Gnus agent
(unless gnus-agent-send-mail-function
(setq gnus-agent-send-mail-function
(or message-send-mail-real-function
- message-send-mail-function)
+ (function (lambda () (funcall message-send-mail-function))))
message-send-mail-real-function 'gnus-agent-send-mail))
- (unless gnus-agent-covered-methods
- (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."
- (unless (gnus-gethash "nndraft:queue" gnus-newsrc-hashtb)
- (gnus-request-create-group "queue" '(nndraft ""))
+ ;; If the servers file doesn't exist, auto-agentize some servers and
+ ;; save the servers file so this auto-agentizing isn't invoked
+ ;; again.
+ (unless (file-exists-p (nnheader-concat gnus-agent-directory "lib/servers"))
+ (gnus-message 3 "First time agent user, agentizing remote groups...")
+ (mapc
+ (lambda (server-or-method)
+ (let ((method (gnus-server-to-method server-or-method)))
+ (when (memq (car method)
+ gnus-agent-auto-agentize-methods)
+ (push (gnus-method-to-server method)
+ gnus-agent-covered-methods)
+ (setq gnus-agent-method-p-cache nil))))
+ (cons gnus-select-method gnus-secondary-select-methods))
+ (gnus-agent-write-servers)))
+
+(defun gnus-agent-queue-setup (&optional group-name)
+ "Make sure the queue group exists.
+Optional arg GROUP-NAME allows to specify another group."
+ (unless (gnus-gethash (format "nndraft:%s" (or group-name "queue"))
+ gnus-newsrc-hashtb)
+ (gnus-request-create-group (or group-name "queue") '(nndraft ""))
(let ((gnus-level-default-subscribed 1))
- (gnus-subscribe-group "nndraft:queue" nil '(nndraft "")))
+ (gnus-subscribe-group (format "nndraft:%s" (or group-name "queue"))
+ nil '(nndraft "")))
(gnus-group-set-parameter
- "nndraft:queue" 'gnus-dummy '((gnus-draft-mode)))))
+ (format "nndraft:%s" (or group-name "queue"))
+ 'gnus-dummy '((gnus-draft-mode)))))
(defun gnus-agent-send-mail ()
- (if gnus-plugged
+ (if (or (not gnus-agent-queue-mail)
+ (and gnus-plugged (not (eq gnus-agent-queue-mail 'always))))
(funcall gnus-agent-send-mail-function)
(goto-char (point-min))
(re-search-forward
"Restore GCC field from saved header."
(save-excursion
(goto-char (point-min))
- (while (re-search-forward (concat gnus-agent-gcc-header ":") nil t)
+ (while (re-search-forward
+ (concat "^" (regexp-quote gnus-agent-gcc-header) ":") nil t)
(replace-match "Gcc:" 'fixedcase))))
(defun gnus-agent-any-covered-gcc ()
"Synchronize unplugged flags with servers."
(interactive)
(save-excursion
- (dolist (gnus-command-method gnus-agent-covered-methods)
+ (dolist (gnus-command-method (gnus-agent-covered-methods))
(when (file-exists-p (gnus-agent-lib-file "flags"))
(gnus-agent-synchronize-flags-server gnus-command-method)))))
"Synchronize flags according to `gnus-agent-synchronize-flags'."
(interactive)
(save-excursion
- (dolist (gnus-command-method gnus-agent-covered-methods)
- (when (file-exists-p (gnus-agent-lib-file "flags"))
+ (dolist (gnus-command-method (gnus-agent-covered-methods))
+ (when (and (file-exists-p (gnus-agent-lib-file "flags"))
+ (not (eq (gnus-server-status gnus-command-method) 'offline)))
(gnus-agent-possibly-synchronize-flags-server gnus-command-method)))))
(defun gnus-agent-synchronize-flags-server (method)
"Synchronize flags set when unplugged for server."
- (let ((gnus-command-method method))
+ (let ((gnus-command-method method)
+ (gnus-agent nil))
(when (file-exists-p (gnus-agent-lib-file "flags"))
(set-buffer (get-buffer-create " *Gnus Agent flag synchronize*"))
(erase-buffer)
(nnheader-insert-file-contents (gnus-agent-lib-file "flags"))
- (if (null (gnus-check-server 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))))
- (gnus-delete-line)
- (write-file (gnus-agent-lib-file "flags"))
- (error "Couldn't set flags from file %s"
- (gnus-agent-lib-file "flags"))))
- (delete-file (gnus-agent-lib-file "flags")))
+ (cond ((null gnus-plugged)
+ (gnus-message
+ 1 "You must be plugged to synchronize flags with server %s"
+ (nth 1 gnus-command-method)))
+ ((null (gnus-check-server gnus-command-method))
+ (gnus-message
+ 1 "Couldn't open server %s" (nth 1 gnus-command-method)))
+ (t
+ (condition-case err
+ (while t
+ (let ((bgn (point)))
+ (eval (read (current-buffer)))
+ (delete-region bgn (point))))
+ (end-of-file
+ (delete-file (gnus-agent-lib-file "flags")))
+ (error
+ (let ((file (gnus-agent-lib-file "flags")))
+ (write-region (point-min) (point-max)
+ (gnus-agent-lib-file "flags") nil 'silent)
+ (error "Couldn't set flags from file %s due to %s"
+ file (error-message-string err)))))))
(kill-buffer nil))))
(defun gnus-agent-possibly-synchronize-flags-server (method)
(cadr method)))))
(gnus-agent-synchronize-flags-server method)))
+;;;###autoload
+(defun gnus-agent-rename-group (old-group new-group)
+ "Rename fully-qualified OLD-GROUP as NEW-GROUP. Always updates the agent, even when
+disabled, as the old agent files would corrupt gnus when the agent was
+next enabled. Depends upon the caller to determine whether group renaming is supported."
+ (let* ((old-command-method (gnus-find-method-for-group old-group))
+ (old-path (directory-file-name
+ (let (gnus-command-method old-command-method)
+ (gnus-agent-group-pathname old-group))))
+ (new-command-method (gnus-find-method-for-group new-group))
+ (new-path (directory-file-name
+ (let (gnus-command-method new-command-method)
+ (gnus-agent-group-pathname new-group)))))
+ (gnus-rename-file old-path new-path t)
+
+ (let* ((old-real-group (gnus-group-real-name old-group))
+ (new-real-group (gnus-group-real-name new-group))
+ (old-active (gnus-agent-get-group-info old-command-method old-real-group)))
+ (gnus-agent-save-group-info old-command-method old-real-group nil)
+ (gnus-agent-save-group-info new-command-method new-real-group old-active)
+
+ (let ((old-local (gnus-agent-get-local old-group
+ old-real-group old-command-method)))
+ (gnus-agent-set-local old-group
+ nil nil
+ old-real-group old-command-method)
+ (gnus-agent-set-local new-group
+ (car old-local) (cdr old-local)
+ new-real-group new-command-method)))))
+
+;;;###autoload
+(defun gnus-agent-delete-group (group)
+ "Delete fully-qualified GROUP. Always updates the agent, even when
+disabled, as the old agent files would corrupt gnus when the agent was
+next enabled. Depends upon the caller to determine whether group deletion is supported."
+ (let* ((command-method (gnus-find-method-for-group group))
+ (path (directory-file-name
+ (let (gnus-command-method command-method)
+ (gnus-agent-group-pathname group)))))
+ (gnus-delete-directory path)
+
+ (let* ((real-group (gnus-group-real-name group)))
+ (gnus-agent-save-group-info command-method real-group nil)
+
+ (let ((local (gnus-agent-get-local group
+ real-group command-method)))
+ (gnus-agent-set-local group
+ nil nil
+ real-group command-method)))))
+
;;;
;;; Server mode commands
;;;
-(defun gnus-agent-add-server (server)
+(defun gnus-agent-add-server ()
"Enroll SERVER in the agent program."
- (interactive (list (gnus-server-server-name)))
- (unless server
- (error "No server on the current line"))
- (let ((method (gnus-server-get-method nil (gnus-server-server-name))))
+ (interactive)
+ (let* ((server (gnus-server-server-name))
+ (named-server (gnus-server-named-server))
+ (method (and server
+ (gnus-server-get-method nil server))))
+ (unless server
+ (error "No server on the current line"))
+
(when (gnus-agent-method-p method)
(error "Server already in the agent program"))
- (push method gnus-agent-covered-methods)
+
+ (push named-server gnus-agent-covered-methods)
+
+ (setq gnus-agent-method-p-cache nil)
(gnus-server-update-server server)
(gnus-agent-write-servers)
(gnus-message 1 "Entered %s into the Agent" server)))
-(defun gnus-agent-remove-server (server)
+(defun gnus-agent-remove-server ()
"Remove SERVER from the agent program."
- (interactive (list (gnus-server-server-name)))
- (unless server
- (error "No server on the current line"))
- (let ((method (gnus-server-get-method nil (gnus-server-server-name))))
- (unless (gnus-agent-method-p method)
+ (interactive)
+ (let* ((server (gnus-server-server-name))
+ (named-server (gnus-server-named-server)))
+ (unless server
+ (error "No server on the current line"))
+
+ (unless (member named-server gnus-agent-covered-methods)
(error "Server not in the agent program"))
+
(setq gnus-agent-covered-methods
- (delete method gnus-agent-covered-methods))
+ (delete named-server gnus-agent-covered-methods)
+ gnus-agent-method-p-cache nil)
+
(gnus-server-update-server server)
(gnus-agent-write-servers)
(gnus-message 1 "Removed %s from the agent" server)))
(defun gnus-agent-read-servers ()
"Read the alist of covered 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"))))
+ (setq gnus-agent-covered-methods
+ (gnus-agent-read-file
+ (nnheader-concat gnus-agent-directory "lib/servers"))
+ gnus-agent-method-p-cache nil)
+
+ ;; I am called so early in start-up that I can not validate server
+ ;; names. When that is the case, I skip the validation. That is
+ ;; alright as the gnus startup code calls the validate methods
+ ;; directly.
+ (if gnus-server-alist
+ (gnus-agent-read-servers-validate)))
+
+(defun gnus-agent-read-servers-validate ()
+ (mapcar (lambda (server-or-method)
+ (let* ((server (if (stringp server-or-method)
+ server-or-method
+ (gnus-method-to-server server-or-method)))
+ (method (gnus-server-to-method server)))
+ (if method
+ (unless (member server gnus-agent-covered-methods)
+ (push server gnus-agent-covered-methods)
+ (setq gnus-agent-method-p-cache nil))
+ (gnus-message 1 "Ignoring disappeared server `%s'" server))))
+ (prog1 gnus-agent-covered-methods
+ (setq gnus-agent-covered-methods nil))))
+
+(defun gnus-agent-read-servers-validate-native (native-method)
+ (setq gnus-agent-covered-methods
+ (mapcar (lambda (method)
+ (if (or (not method)
+ (equal method native-method))
+ "native"
+ method)) gnus-agent-covered-methods)))
(defun gnus-agent-write-servers ()
"Write the alist of covered servers."
(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 (mapcar 'gnus-method-simplify gnus-agent-covered-methods)
+ (prin1 gnus-agent-covered-methods
(current-buffer)))))
;;;
(setq gnus-newsgroup-downloadable
(delq article gnus-newsgroup-downloadable))
(gnus-article-mark article))
- (progn
- (setq gnus-newsgroup-downloadable
- (gnus-add-to-sorted-list gnus-newsgroup-downloadable article))
- gnus-downloadable-mark)
- )
+ (setq gnus-newsgroup-downloadable
+ (gnus-add-to-sorted-list gnus-newsgroup-downloadable article))
+ gnus-downloadable-mark)
'unread))))
+;;;###autoload
(defun gnus-agent-get-undownloaded-list ()
"Construct list of articles that have not been downloaded."
(let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name)))
(cond ((< a h)
;; Ignore IDs in the alist that are not being
;; displayed in the summary.
- (pop alist))
+ (setq alist (cdr alist)))
((> a h)
;; Headers that are not in the alist should be
;; fictious (see nnagent-retrieve-headers); they
;; imply that this article isn't in the agent.
(gnus-agent-append-to-list tail-undownloaded h)
(gnus-agent-append-to-list tail-unfetched h)
- (pop headers))
+ (setq headers (cdr headers)))
((cdar alist)
- (pop alist)
- (pop headers)
+ (setq alist (cdr alist))
+ (setq headers (cdr headers))
nil ; ignore already downloaded
)
(t
- (pop alist)
- (pop headers)
-
+ (setq alist (cdr alist))
+ (setq headers (cdr headers))
+
;; This article isn't in the agent. Check to see
;; if it is in the cache. If it is, it's been
;; downloaded.
(while (and cached (< (car cached) a))
- (pop cached))
+ (setq cached (cdr cached)))
(unless (equal a (car cached))
(gnus-agent-append-to-list tail-undownloaded a))))))
(when gnus-newsgroup-processable
(setq gnus-newsgroup-downloadable
(let* ((dl gnus-newsgroup-downloadable)
- (gnus-newsgroup-downloadable
- (sort (gnus-copy-sequence gnus-newsgroup-processable) '<))
- (fetched-articles (gnus-agent-summary-fetch-group)))
- ;; The preceeding call to (gnus-agent-summary-fetch-group)
- ;; updated gnus-newsgroup-downloadable to remove each
- ;; article successfully fetched.
+ (processable (sort (gnus-copy-sequence gnus-newsgroup-processable) '<))
+ (gnus-newsgroup-downloadable processable))
+ (gnus-agent-summary-fetch-group)
- ;; For each article that I processed, remove its
- ;; processable mark IF the article is no longer
- ;; downloadable (i.e. it's already downloaded)
- (dolist (article gnus-newsgroup-processable)
- (unless (memq article gnus-newsgroup-downloadable)
- (gnus-summary-remove-process-mark article)))
- (gnus-sorted-ndifference dl fetched-articles)))))
+ ;; For each article that I processed that is no longer
+ ;; undownloaded, remove its processable mark.
+
+ (mapc #'gnus-summary-remove-process-mark
+ (gnus-sorted-ndifference gnus-newsgroup-processable gnus-newsgroup-undownloaded))
+
+ ;; The preceeding call to (gnus-agent-summary-fetch-group)
+ ;; updated the temporary gnus-newsgroup-downloadable to
+ ;; remove each article successfully fetched. Now, I
+ ;; update the real gnus-newsgroup-downloadable to only
+ ;; include undownloaded articles.
+ (gnus-sorted-ndifference dl (gnus-sorted-ndifference processable gnus-newsgroup-undownloaded))))))
(defun gnus-agent-summary-fetch-group (&optional all)
"Fetch the downloadable articles in the group.
gnus-newsgroup-name articles)))))
(save-excursion
(dolist (article articles)
- (let ((was-marked-downloadable
+ (let ((was-marked-downloadable
(memq article gnus-newsgroup-downloadable)))
(cond (gnus-agent-mark-unread-after-downloaded
(setq gnus-newsgroup-downloadable
(delq article gnus-newsgroup-downloadable))
- ;; The downloadable mark is implemented as a
- ;; type of read mark. Therefore, marking the
- ;; article as unread is sufficient to clear
- ;; its downloadable flag.
(gnus-summary-mark-article article gnus-unread-mark))
(was-marked-downloadable
(gnus-summary-set-agent-mark article t)))
;;; Internal functions
;;;
-;;; NOTES:
-;;; The agent's active range is defined as follows:
-;;; If the agent has no record of the group, use the actual active
-;;; range.
-;;; If the agent has a record, set the agent's active range to
-;;; include the max limit of the actual active range.
-;;; When expiring, update the min limit to match the smallest of the
-;;; min article not expired or the min actual active range.
+(defun gnus-agent-synchronize-group-flags (group actions server)
+"Update a plugged group by performing the indicated actions."
+ (let* ((gnus-command-method (gnus-server-to-method server))
+ (info
+ ;; This initializer is required as gnus-request-set-mark
+ ;; calls gnus-group-real-name to strip off the host name
+ ;; before calling the backend. Now that the backend is
+ ;; trying to call gnus-request-set-mark, I have to
+ ;; reconstruct the original group name.
+ (or (gnus-get-info group)
+ (gnus-get-info
+ (setq group (gnus-group-full-name
+ group gnus-command-method))))))
+ (gnus-request-set-mark group actions)
+
+ (when info
+ (dolist (action actions)
+ (let ((range (nth 0 action))
+ (what (nth 1 action))
+ (marks (nth 2 action)))
+ (dolist (mark marks)
+ (cond ((eq mark 'read)
+ (gnus-info-set-read
+ info
+ (funcall (if (eq what 'add)
+ 'gnus-range-add
+ 'gnus-remove-from-range)
+ (gnus-info-read info)
+ range))
+ (gnus-get-unread-articles-in-group
+ info
+ (gnus-active (gnus-info-group info))))
+ ((memq mark '(tick))
+ (let ((info-marks (assoc mark (gnus-info-marks info))))
+ (unless info-marks
+ (gnus-info-set-marks info (cons (setq info-marks (list mark)) (gnus-info-marks info))))
+ (setcdr info-marks (funcall (if (eq what 'add)
+ 'gnus-range-add
+ 'gnus-remove-from-range)
+ (cdr info-marks)
+ range))))))))
+
+ ;;Marks can be synchronized at any time by simply toggling from
+ ;;unplugged to plugged. If that is what is happening right now, make
+ ;;sure that the group buffer is up to date.
+ (when (gnus-buffer-live-p gnus-group-buffer)
+ (gnus-group-update-group group t)))
+ nil))
(defun gnus-agent-save-active (method)
- (gnus-agent-save-active-1 method 'gnus-active-to-gnus-format))
-
-(defun gnus-agent-save-active-1 (method function)
(when (gnus-agent-method-p method)
(let* ((gnus-command-method method)
(new (gnus-make-hashtable (count-lines (point-min) (point-max))))
(file (gnus-agent-lib-file "active")))
- (funcall function nil new)
+ (gnus-active-to-gnus-format nil new)
(gnus-agent-write-active file new)
(erase-buffer)
(nnheader-insert-file-contents file))))
-(defun gnus-agent-write-active (file new &optional literal-replacement)
- (let ((old new))
- (when (and (not literal-replacement)
- (file-exists-p file))
- (setq old (gnus-make-hashtable (count-lines (point-min) (point-max))))
- (with-temp-buffer
- (nnheader-insert-file-contents file)
- (gnus-active-to-gnus-format nil old))
- ;; Iterate over the current active groups, the current active
- ;; range may expand, but NOT CONTRACT, the agent's active range.
- (mapatoms
- (lambda (nsym)
- (let ((new-active (and nsym (boundp nsym) (symbol-value nsym))))
- (when new-active
- (let* ((osym (intern (symbol-name nsym) old))
- (old-active (and (boundp osym) (symbol-value osym))))
- (if old-active
- (let ((new-min (car new-active))
- (old-min (car old-active))
- (new-max (cdr new-active))
- (old-max (cdr old-active)))
- (if (and (integerp new-min)
- (< new-min old-min))
- (setcar old-active new-min))
- (if (and (integerp new-max)
- (> new-max old-max))
- (setcdr old-active new-max)))
- (set osym new-active))))))
- new))
+(defun gnus-agent-write-active (file new)
(gnus-make-directory (file-name-directory file))
(let ((nnmail-active-file-coding-system gnus-agent-file-coding-system))
;; The hashtable contains real names of groups. However, do NOT
;; add the foreign server prefix as gnus-active-to-gnus-format
;; will add it while reading the file.
- (gnus-write-active-file file old nil))))
+ (gnus-write-active-file file new nil)))
-(defun gnus-agent-save-groups (method)
- (gnus-agent-save-active-1 method 'gnus-groups-to-gnus-format))
+;;;###autoload
+(defun gnus-agent-possibly-alter-active (group active &optional info)
+ "Possibly expand a group's active range to include articles
+downloaded into the agent."
+ (let* ((gnus-command-method (or gnus-command-method
+ (gnus-find-method-for-group group))))
+ (when (gnus-agent-method-p gnus-command-method)
+ (let* ((local (gnus-agent-get-local group))
+ (active-min (or (car active) 0))
+ (active-max (or (cdr active) 0))
+ (agent-min (or (car local) active-min))
+ (agent-max (or (cdr local) active-max)))
+
+ (when (< agent-min active-min)
+ (setcar active agent-min))
+
+ (when (> agent-max active-max)
+ (setcdr active agent-max))
+
+ (when (and info (< agent-max (- active-min 100)))
+ ;; I'm expanding the active range by such a large amount
+ ;; that there is a gap of more than 100 articles between the
+ ;; last article known to the agent and the first article
+ ;; currently available on the server. This gap contains
+ ;; articles that have been lost, mark them as read so that
+ ;; gnus doesn't waste resources trying to fetch them.
+
+ ;; NOTE: I don't do this for smaller gaps (< 100) as I don't
+ ;; want to modify the local file everytime someone restarts
+ ;; gnus. The small gap will cause a tiny performance hit
+ ;; when gnus tries, and fails, to retrieve the articles.
+ ;; Still that should be smaller than opening a buffer,
+ ;; printing this list to the buffer, and then writing it to a
+ ;; file.
+
+ (let ((read (gnus-info-read info)))
+ (gnus-info-set-read
+ info
+ (gnus-range-add
+ read
+ (list (cons (1+ agent-max)
+ (1- active-min))))))
+
+ ;; Lie about the agent's local range for this group to
+ ;; disable the set read each time this server is opened.
+ ;; NOTE: Opening this group will restore the valid local
+ ;; range but it will also expand the local range to
+ ;; incompass the new active range.
+ (gnus-agent-set-local group agent-min (1- active-min)))))))
(defun gnus-agent-save-group-info (method group active)
+ "Update a single group's active range in the agent's copy of the server's active file."
(when (gnus-agent-method-p method)
- (let* ((gnus-command-method method)
+ (let* ((gnus-command-method (or method gnus-command-method))
(coding-system-for-write nnheader-file-coding-system)
(file-name-coding-system nnmail-pathname-coding-system)
(file (gnus-agent-lib-file "active"))
(when (re-search-forward
(concat "^" (regexp-quote group) " ") nil t)
(save-excursion
- (setq oactive-max (read (current-buffer)) ;; max
+ (setq oactive-max (read (current-buffer)) ;; max
oactive-min (read (current-buffer)))) ;; min
(gnus-delete-line)))
- (insert (format "%S %d %d y\n" (intern group)
- (max (or oactive-max (cdr active)) (cdr active))
- (min (or oactive-min (car active)) (car active))))
- (goto-char (point-max))
- (while (search-backward "\\." nil t)
- (delete-char 1))))))
+ (when active
+ (insert (format "%S %d %d y\n" (intern group)
+ (max (or oactive-max (cdr active)) (cdr active))
+ (min (or oactive-min (car active)) (car active))))
+ (goto-char (point-max))
+ (while (search-backward "\\." nil t)
+ (delete-char 1)))))))
+
+(defun gnus-agent-get-group-info (method group)
+ "Get a single group's active range in the agent's copy of the server's active file."
+ (when (gnus-agent-method-p method)
+ (let* ((gnus-command-method (or method gnus-command-method))
+ (coding-system-for-write nnheader-file-coding-system)
+ (file-name-coding-system nnmail-pathname-coding-system)
+ (file (gnus-agent-lib-file "active"))
+ oactive-min oactive-max)
+ (gnus-make-directory (file-name-directory file))
+ (with-temp-buffer
+ ;; Emacs got problem to match non-ASCII group in multibyte buffer.
+ (mm-disable-multibyte)
+ (when (file-exists-p file)
+ (nnheader-insert-file-contents file)
+
+ (goto-char (point-min))
+ (when (re-search-forward
+ (concat "^" (regexp-quote group) " ") nil t)
+ (save-excursion
+ (setq oactive-max (read (current-buffer)) ;; max
+ oactive-min (read (current-buffer))) ;; min
+ (cons oactive-min oactive-max))))))))
(defun gnus-agent-group-path (group)
"Translate GROUP into a file name."
(setq group
(nnheader-translate-file-chars
(nnheader-replace-duplicate-chars-in-string
- (nnheader-replace-chars-in-string
- (gnus-group-real-name group)
+ (nnheader-replace-chars-in-string
+ (gnus-group-real-name (gnus-group-decoded-name group))
?/ ?_)
?. ?_)))
(if (or nnmail-use-long-file-names
;; while plugged.
(let ((gnus-command-method (or gnus-command-method
(gnus-find-method-for-group group))))
- (nnmail-group-pathname (gnus-group-real-name group) (gnus-agent-directory))))
+ (nnmail-group-pathname (gnus-group-real-name
+ (gnus-group-decoded-name group))
+ (gnus-agent-directory))))
(defun gnus-agent-get-function (method)
(if (gnus-online method)
(require 'nnagent)
'nnagent))
+(defun gnus-agent-covered-methods ()
+ "Return the subset of methods that are covered by the agent."
+ (delq nil (mapcar #'gnus-server-to-method gnus-agent-covered-methods)))
+
;;; History functions
(defun gnus-agent-history-buffer ()
(unless (and (eq article (caar alist))
(cdar alist))
;; Skip headers preceeding this article
- (while (> article
+ (while (> article
(setq header-number
(let* ((header (car headers)))
(if header
(while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) *")
(push (cons (buffer-substring (match-beginning 1)
(match-end 1))
- (string-to-int
+ (string-to-number
(buffer-substring (match-beginning 2)
(match-end 2))))
crosses)
(gnus-agent-append-to-list
tail-fetched-articles (caar pos)))
(widen)
- (pop pos))))
+ (setq pos (cdr pos)))))
(gnus-agent-save-alist group (cdr fetched-articles) date)
+ (gnus-agent-update-files-total-fetched-for group (cdr fetched-articles))
+
(gnus-message 7 ""))
(cdr fetched-articles))))))
+(defun gnus-agent-unfetch-articles (group articles)
+ "Delete ARTICLES that were fetched from GROUP into the agent."
+ (when articles
+ (gnus-agent-with-refreshed-group
+ group
+ (gnus-agent-load-alist group)
+ (let* ((alist (cons nil gnus-agent-article-alist))
+ (articles (sort articles #'<))
+ (next-possibility alist)
+ (delete-this (pop articles)))
+ (while (and (cdr next-possibility) delete-this)
+ (let ((have-this (caar (cdr next-possibility))))
+ (cond ((< delete-this have-this)
+ (setq delete-this (pop articles)))
+ ((= delete-this have-this)
+ (let ((timestamp (cdar (cdr next-possibility))))
+ (when timestamp
+ (let* ((file-name (concat (gnus-agent-group-pathname group)
+ (number-to-string have-this)))
+ (size-file (float (or (and gnus-agent-total-fetched-hashtb
+ (nth 7 (file-attributes file-name)))
+ 0))))
+ (delete-file file-name)
+ (gnus-agent-update-files-total-fetched-for group (- size-file)))))
+
+ (setcdr next-possibility (cddr next-possibility)))
+ (t
+ (setq next-possibility (cdr next-possibility))))))
+ (setq gnus-agent-article-alist (cdr alist))
+ (gnus-agent-save-alist group)))))
+
(defun gnus-agent-crosspost (crosses article &optional date)
(setq date (or date t))
(insert (string-to-number (cdar crosses)))
(insert-buffer-substring gnus-agent-overview-buffer beg end)
(gnus-agent-check-overview-buffer))
- (pop crosses))))
+ (setq crosses (cdr crosses)))))
(defun gnus-agent-backup-overview-buffer ()
(when gnus-newsgroup-name
(gnus-message 1
"Overview buffer contains garbage '%s'."
(buffer-substring
- p (gnus-point-at-eol))))
+ p (point-at-eol))))
((= cur prev-num)
(or backed-up
(setq backed-up (gnus-agent-backup-overview-buffer)))
(gnus-message 1
"Duplicate overview line for %d" cur)
- (delete-region (point) (progn (forward-line 1) (point))))
+ (delete-region p (progn (forward-line 1) (point))))
((< cur prev-num)
(or backed-up
(setq backed-up (gnus-agent-backup-overview-buffer)))
(gnus-agent-article-name ".overview"
(caar gnus-agent-buffer-alist))
nil 'silent))
- (pop gnus-agent-buffer-alist))
+ (setq gnus-agent-buffer-alist (cdr gnus-agent-buffer-alist)))
(while gnus-agent-group-alist
(with-temp-file (gnus-agent-article-name
".agentview" (caar gnus-agent-group-alist))
(insert "\n")
(princ 1 (current-buffer))
(insert "\n"))
- (pop gnus-agent-group-alist))))
+ (setq gnus-agent-group-alist (cdr gnus-agent-group-alist)))))
+;;;###autoload
(defun gnus-agent-find-parameter (group symbol)
"Search for GROUPs SYMBOL in the group's parameters, the group's
topic parameters, the group's category, or the customizable
(symbol-value
(cdr
(assq symbol
- '((agent-short-article . gnus-agent-short-article)
- (agent-long-article . gnus-agent-long-article)
- (agent-low-score . gnus-agent-low-score)
- (agent-high-score . gnus-agent-high-score)
- (agent-days-until-old . gnus-agent-expire-days)
- (agent-enable-expiration
- . gnus-agent-enable-expiration)
- (agent-predicate . gnus-agent-predicate)))))))
+ '((agent-short-article . gnus-agent-short-article)
+ (agent-long-article . gnus-agent-long-article)
+ (agent-low-score . gnus-agent-low-score)
+ (agent-high-score . gnus-agent-high-score)
+ (agent-days-until-old . gnus-agent-expire-days)
+ (agent-enable-expiration
+ . gnus-agent-enable-expiration)
+ (agent-predicate . gnus-agent-predicate)))))))
(defun gnus-agent-fetch-headers (group &optional force)
"Fetch interesting headers into the agent. The group's overview
;; 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))
+ ;; NOTE: Call g-a-brand-nov even when the file does not
+ ;; exist. As a minimum, it will validate the article
+ ;; numbers already in the buffer.
+ (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-update-view-total-fetched-for group t)
(gnus-agent-save-alist group articles nil)
articles)
(ignore-errors
(nnheader-insert-file-contents file)))))
articles))
+(defsubst gnus-agent-read-article-number ()
+ "Reads the article number at point. Returns nil when a valid article number can not be read."
+
+ ;; It is unfortunite but the read function quietly overflows
+ ;; integer. As a result, I have to use string operations to test
+ ;; for overflow BEFORE calling read.
+ (when (looking-at "[0-9]+\t")
+ (let ((len (- (match-end 0) (match-beginning 0))))
+ (cond ((< len 9)
+ (read (current-buffer)))
+ ((= len 9)
+ ;; Many 9 digit base-10 numbers can be represented in a 27-bit int
+ ;; Back convert from int to string to ensure that this is one of them.
+ (let* ((str1 (buffer-substring (match-beginning 0) (1- (match-end 0))))
+ (num (read (current-buffer)))
+ (str2 (int-to-string num)))
+ (when (equal str1 str2)
+ num)))))))
+
(defsubst gnus-agent-copy-nov-line (article)
+ "Copy the indicated ARTICLE from the overview buffer to the nntp server buffer."
(let (art b e)
(set-buffer gnus-agent-overview-buffer)
(while (and (not (eobp))
- (< (setq art (read (current-buffer))) article))
+ (or (not (setq art (gnus-agent-read-article-number)))
+ (< art article)))
(forward-line 1))
(beginning-of-line)
(if (or (eobp)
(defun gnus-agent-braid-nov (group articles file)
"Merge agent overview data with given file.
-Takes headers for ARTICLES from `gnus-agent-overview-buffer' and the given
-FILE and places the combined headers into `nntp-server-buffer'."
+Takes unvalidated headers for ARTICLES from
+`gnus-agent-overview-buffer' and validated headers from the given
+FILE and places the combined valid headers into
+`nntp-server-buffer'. This function can be used, when file
+doesn't exist, to valid the overview 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)
+ (when (file-exists-p file)
+ (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.
+ ;; Old and new overlap -- 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)
+ (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)))))
+
(goto-char (point-max))
+
+ ;; Append the remaining lines
(when articles
(when last
(set-buffer gnus-agent-overview-buffer)
- (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))))
+
+ (let ((p (point)))
+ (insert-buffer-substring gnus-agent-overview-buffer start)
+ (goto-char p))
+
+ (setq last (or last -134217728))
+ (let (sort art)
+ (while (not (eobp))
+ (setq art (gnus-agent-read-article-number))
+ (cond ((not art)
+ ;; Bad art num - delete this line
+ (beginning-of-line)
+ (delete-region (point) (progn (forward-line 1) (point))))
+ ((< art last)
+ ;; Art num out of order - enable sort
+ (setq sort t)
+ (forward-line 1))
+ (t
+ ;; Good art num
+ (setq last art)
+ (forward-line 1))))
+ (when sort
+ (sort-numeric-fields 1 (point-min) (point-max)))))))
;; Keeps the compiler from warning about the free variable in
;; gnus-agent-read-agentview.
(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)
+ (condition-case nil
+ (progn
+ (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 2)
+ (error "gnus-agent-read-agentview no longer supports version %d. Stop gnus, manually evaluate gnus-agent-convert-to-compressed-agentview, then restart gnus." version))
+ ((= 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 (inline
+ (gnus-uncompress-range
+ (cdr comp-list)))))
+ (mapcar (lambda (article-id)
+ (setq uncomp (cons (cons article-id state) uncomp)))
+ sequence)))
+ alist)
+ (setq alist (sort uncomp 'car-less-than-car)))))
+ (when changed-version
+ (let ((gnus-agent-article-alist alist))
+ (gnus-agent-save-alist gnus-agent-read-agentview)))
+ alist))
+ (file-error nil))))
+
+(defun gnus-agent-save-alist (group &optional articles state)
"Save the article-state alist for GROUP."
(let* ((file-name-coding-system nnmail-pathname-coding-system)
(prev (cons nil gnus-agent-article-alist))
(setcdr (cadr prev) state)))
(setq prev (cdr prev)))
(setq gnus-agent-article-alist (cdr all))
- (if dir
- (gnus-make-directory dir)
- (gnus-make-directory (gnus-agent-article-name "" group)))
- (with-temp-file (if dir
- (expand-file-name ".agentview" dir)
- (gnus-agent-article-name ".agentview" group))
+
+ (gnus-agent-set-local group
+ (caar gnus-agent-article-alist)
+ (caar (last gnus-agent-article-alist)))
+
+ (gnus-make-directory (gnus-agent-article-name "" group))
+ (with-temp-file (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)
(princ compressed (current-buffer)))))
(insert "\n")
(princ gnus-agent-article-alist-save-format (current-buffer))
- (insert "\n"))))
+ (insert "\n"))
+
+ (gnus-agent-update-view-total-fetched-for group nil)))
+
+(defvar gnus-agent-article-local nil)
+(defvar gnus-agent-file-loading-local nil)
+
+(defun gnus-agent-load-local (&optional method)
+ "Load the METHOD'S local file. The local file contains min/max
+article counts for each of the method's subscribed groups."
+ (let ((gnus-command-method (or method gnus-command-method)))
+ (setq gnus-agent-article-local
+ (gnus-cache-file-contents
+ (gnus-agent-lib-file "local")
+ 'gnus-agent-file-loading-local
+ 'gnus-agent-read-and-cache-local))))
+
+(defun gnus-agent-read-and-cache-local (file)
+ "Load and read FILE then bind its contents to
+gnus-agent-article-local. If that variable had `dirty' (also known as
+modified) original contents, they are first saved to their own file."
+
+ (if (and gnus-agent-article-local
+ (symbol-value (intern "+dirty" gnus-agent-article-local)))
+ (gnus-agent-save-local))
+ (gnus-agent-read-local file))
+
+(defun gnus-agent-read-local (file)
+ "Load FILE and do a `read' there."
+ (let ((my-obarray (gnus-make-hashtable (count-lines (point-min)
+ (point-max))))
+ (line 1))
+ (with-temp-buffer
+ (condition-case nil
+ (let ((nnheader-file-coding-system gnus-agent-file-coding-system))
+ (nnheader-insert-file-contents file))
+ (file-error))
+
+ (goto-char (point-min))
+ ;; Skip any comments at the beginning of the file (the only place where they may appear)
+ (while (= (following-char) ?\;)
+ (forward-line 1)
+ (setq line (1+ line)))
+
+ (while (not (eobp))
+ (condition-case err
+ (let (group
+ min
+ max
+ (cur (current-buffer)))
+ (setq group (read cur)
+ min (read cur)
+ max (read cur))
+
+ (when (stringp group)
+ (setq group (intern group my-obarray)))
+
+ ;; NOTE: The '+ 0' ensure that min and max are both numerics.
+ (set group (cons (+ 0 min) (+ 0 max))))
+ (error
+ (gnus-message 3 "Warning - invalid agent local: %s on line %d: "
+ file line (error-message-string err))))
+ (forward-line 1)
+ (setq line (1+ line))))
+
+ (set (intern "+dirty" my-obarray) nil)
+ (set (intern "+method" my-obarray) gnus-command-method)
+ my-obarray))
+
+(defun gnus-agent-save-local (&optional force)
+ "Save gnus-agent-article-local under it method's agent.lib directory."
+ (let ((my-obarray gnus-agent-article-local))
+ (when (and my-obarray
+ (or force (symbol-value (intern "+dirty" my-obarray))))
+ (let* ((gnus-command-method (symbol-value (intern "+method" my-obarray)))
+ ;; NOTE: gnus-command-method is used within gnus-agent-lib-file.
+ (dest (gnus-agent-lib-file "local")))
+ (gnus-make-directory (gnus-agent-lib-file ""))
+
+ (let ((buffer-file-coding-system gnus-agent-file-coding-system))
+ (with-temp-file dest
+ (let ((gnus-command-method (symbol-value (intern "+method" my-obarray)))
+ (file-name-coding-system nnmail-pathname-coding-system)
+ print-level print-length item article
+ (standard-output (current-buffer)))
+ (mapatoms (lambda (symbol)
+ (cond ((not (boundp symbol))
+ nil)
+ ((member (symbol-name symbol) '("+dirty" "+method"))
+ nil)
+ (t
+ (prin1 symbol)
+ (let ((range (symbol-value symbol)))
+ (princ " ")
+ (princ (car range))
+ (princ " ")
+ (princ (cdr range))
+ (princ "\n")))))
+ my-obarray))))))))
+
+(defun gnus-agent-get-local (group &optional gmane method)
+ (let* ((gmane (or gmane (gnus-group-real-name group)))
+ (gnus-command-method (or method (gnus-find-method-for-group group)))
+ (local (gnus-agent-load-local))
+ (symb (intern gmane local))
+ (minmax (and (boundp symb) (symbol-value symb))))
+ (unless minmax
+ ;; Bind these so that gnus-agent-load-alist doesn't change the
+ ;; current alist (i.e. gnus-agent-article-alist)
+ (let* ((gnus-agent-article-alist gnus-agent-article-alist)
+ (gnus-agent-file-loading-cache gnus-agent-file-loading-cache)
+ (alist (gnus-agent-load-alist group)))
+ (when alist
+ (setq minmax
+ (cons (caar alist)
+ (caar (last alist))))
+ (gnus-agent-set-local group (car minmax) (cdr minmax)
+ gmane gnus-command-method local))))
+ minmax))
+
+(defun gnus-agent-set-local (group min max &optional gmane method local)
+ (let* ((gmane (or gmane (gnus-group-real-name group)))
+ (gnus-command-method (or method (gnus-find-method-for-group group)))
+ (local (or local (gnus-agent-load-local)))
+ (symb (intern gmane local))
+ (minmax (and (boundp symb) (symbol-value symb))))
+
+ (if (cond ((and minmax
+ (or (not (eq min (car minmax)))
+ (not (eq max (cdr minmax)))))
+ (setcar minmax min)
+ (setcdr minmax max)
+ t)
+ (minmax
+ nil)
+ ((and min max)
+ (set symb (cons min max))
+ t)
+ (t
+ (unintern symb local)))
+ (set (intern "+dirty" local) t))))
(defun gnus-agent-article-name (article group)
(expand-file-name article
(error "No servers are covered by the Gnus agent"))
(unless gnus-plugged
(error "Can't fetch articles while Gnus is unplugged"))
- (let ((methods gnus-agent-covered-methods)
+ (let ((methods (gnus-agent-covered-methods))
groups group gnus-command-method)
(save-excursion
(while methods
group gnus-command-method)
(error
(unless (funcall gnus-agent-confirmation-function
- (format "Error %s. Continue? "
+ (format "Error %s while fetching session. Should gnus continue? "
(error-message-string err)))
(error "Cannot fetch articles into the Gnus agent")))
(quit
+ (gnus-agent-regenerate-group group)
(unless (funcall gnus-agent-confirmation-function
(format
- "Quit fetching session %s. Continue? "
+ "%s while fetching session. Should gnus continue? "
(error-message-string err)))
(signal 'quit
"Cannot fetch articles into the Gnus agent")))))))))
- (pop methods))
+ (setq methods (cdr methods)))
(gnus-run-hooks 'gnus-agent-fetched-hook)
(gnus-message 6 "Finished fetching articles into the Gnus agent"))))
(dolist (article marked-articles)
(gnus-summary-set-agent-mark article t))
(dolist (article fetched-articles)
- (if gnus-agent-mark-unread-after-downloaded
- (gnus-summary-mark-article
- article gnus-unread-mark))
+ (when gnus-agent-mark-unread-after-downloaded
+ (setq gnus-newsgroup-downloadable
+ (delq article gnus-newsgroup-downloadable))
+ (gnus-summary-mark-article
+ article gnus-unread-mark))
(when (gnus-summary-goto-subject article nil t)
(gnus-summary-update-download-mark article)))
(dolist (article unfetched-articles)
(buffer-disable-undo)
(setq truncate-lines t)
(setq buffer-read-only t)
- (gnus-run-hooks 'gnus-category-mode-hook))
+ (gnus-run-mode-hooks 'gnus-category-mode-hook))
(defalias 'gnus-category-position-point 'gnus-goto-colon)
(gnus-category-position-point)))
(defun gnus-category-name ()
- (or (intern (get-text-property (gnus-point-at-bol) 'gnus-category))
+ (or (intern (get-text-property (point-at-bol) 'gnus-category))
(error "No category on the current line")))
(defun gnus-category-read ()
(cond
;; Functions are just returned as is.
((or (symbolp predicate)
- (gnus-functionp predicate))
+ (functionp predicate))
`(,(or (cdr (assq predicate gnus-category-predicate-alist))
predicate)))
;; More complex predicate.
(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
+That is, if this predicate returns true, then indeed the predicate must
return only unread articles."
- (gnus-function-implies-unread-1 (gnus-category-make-function predicate)))
+ (eq t (gnus-function-implies-unread-1
+ (gnus-category-make-function-1 predicate))))
(defun gnus-function-implies-unread-1 (function)
- (cond ((eq function (symbol-function 'gnus-agent-read-p))
- nil)
- ((not function)
- nil)
- ((gnus-functionp function)
- 'ignore)
- ((memq (car function) '(or and not))
- (apply (car function)
- (mapcar 'gnus-function-implies-unread-1 (cdr function))))
- (t
- (error "Unknown function: %s" function))))
+ "Recursively evaluate a predicate function to determine whether it can select
+any read articles. Returns t if the function is known to never
+return read articles, nil when it is known to always return read
+articles, and t_nil when the function may return both read and unread
+articles."
+ (let ((func (car function))
+ (args (mapcar 'gnus-function-implies-unread-1 (cdr function))))
+ (cond ((eq func 'and)
+ (cond ((memq t args) ; if any argument returns only unread articles
+ ;; then that argument constrains the result to only unread articles.
+ t)
+ ((memq 't_nil args) ; if any argument is indeterminate
+ ;; then the result is indeterminate
+ 't_nil)))
+ ((eq func 'or)
+ (cond ((memq nil args) ; if any argument returns read articles
+ ;; then that argument ensures that the results includes read articles.
+ nil)
+ ((memq 't_nil args) ; if any argument is indeterminate
+ ;; then that argument ensures that the results are indeterminate
+ 't_nil)
+ (t ; if all arguments return only unread articles
+ ;; then the result returns only unread articles
+ t)))
+ ((eq func 'not)
+ (cond ((eq (car args) 't_nil) ; if the argument is indeterminate
+ ; then the result is indeterminate
+ (car args))
+ (t ; otherwise
+ ; toggle the result to be the opposite of the argument
+ (not (car args)))))
+ ((eq func 'gnus-agent-read-p)
+ nil) ; The read predicate NEVER returns unread articles
+ ((eq func 'gnus-agent-false)
+ t) ; The false predicate returns t as the empty set excludes all read articles
+ ((eq func 'gnus-agent-true)
+ nil) ; The true predicate ALWAYS returns read articles
+ ((catch 'found-match
+ (let ((alist gnus-category-predicate-alist))
+ (while alist
+ (if (eq func (cdar alist))
+ (throw 'found-match t)
+ (setq alist (cdr alist))))))
+ 't_nil) ; All other predicates return read and unread articles
+ (t
+ (error "Unknown predicate function: %s" function)))))
(defun gnus-group-category (group)
"Return the category GROUP belongs to."
(if (not group)
(gnus-agent-expire articles group force)
- (if (or (not (eq articles t))
- (yes-or-no-p
- (concat "Are you sure that you want to "
- "expire all articles in " group ".")))
- (let ((gnus-command-method (gnus-find-method-for-group group))
- (overview (gnus-get-buffer-create " *expire overview*"))
- orig)
- (unwind-protect
- (let ((active-file (gnus-agent-lib-file "active")))
- (when (file-exists-p active-file)
- (with-temp-buffer
- (nnheader-insert-file-contents active-file)
- (gnus-active-to-gnus-format
- gnus-command-method
- (setq orig (gnus-make-hashtable
- (count-lines (point-min) (point-max))))))
- (save-excursion
- (gnus-agent-expire-group-1
- group overview (gnus-gethash-safe group orig)
- articles force))
- (gnus-agent-write-active active-file orig t)))
- (kill-buffer overview))))
- (gnus-message 4 "Expiry...done")))
+ (let ( ;; Bind gnus-agent-expire-stats to enable tracking of
+ ;; expiration statistics of this single group
+ (gnus-agent-expire-stats (list 0 0 0.0)))
+ (if (or (not (eq articles t))
+ (yes-or-no-p
+ (concat "Are you sure that you want to "
+ "expire all articles in " group ".")))
+ (let ((gnus-command-method (gnus-find-method-for-group group))
+ (overview (gnus-get-buffer-create " *expire overview*"))
+ orig)
+ (unwind-protect
+ (let ((active-file (gnus-agent-lib-file "active")))
+ (when (file-exists-p active-file)
+ (with-temp-buffer
+ (nnheader-insert-file-contents active-file)
+ (gnus-active-to-gnus-format
+ gnus-command-method
+ (setq orig (gnus-make-hashtable
+ (count-lines (point-min) (point-max))))))
+ (save-excursion
+ (gnus-agent-expire-group-1
+ group overview (gnus-gethash-safe group orig)
+ articles force))))
+ (kill-buffer overview))))
+ (gnus-message 4 (gnus-agent-expire-done-message)))))
(defun gnus-agent-expire-group-1 (group overview active articles force)
;; Internal function - requires caller to have set
;; provided a non-nil active
(let ((dir (gnus-agent-group-pathname group)))
- (when (boundp 'gnus-agent-expire-current-dirs)
- (set 'gnus-agent-expire-current-dirs
- (cons dir
- (symbol-value 'gnus-agent-expire-current-dirs))))
-
- (if (eq 'DISABLE (gnus-agent-find-parameter group
- 'agent-enable-expiration))
- (gnus-message 5 "Expiry skipping over %s" group)
- (gnus-message 5 "Expiring articles in %s" group)
- (gnus-agent-load-alist group)
- (let* ((info (gnus-get-info group))
- (alist gnus-agent-article-alist)
- (day (- (time-to-days (current-time))
- (gnus-agent-find-parameter group 'agent-days-until-old)))
- (specials (if (and alist
- (not force))
- ;; This could be a bit of a problem. I need to
- ;; keep the last article to avoid refetching
- ;; headers when using nntp in the backend. At
- ;; the same time, if someone uses a backend
- ;; that supports article moving then I may have
- ;; to remove the last article to complete the
- ;; move. Right now, I'm going to assume that
- ;; FORCE overrides specials.
- (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 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)
- (buffer-disable-undo)
- (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 \
+ (gnus-agent-with-refreshed-group
+ group
+ (when (boundp 'gnus-agent-expire-current-dirs)
+ (set 'gnus-agent-expire-current-dirs
+ (cons dir
+ (symbol-value 'gnus-agent-expire-current-dirs))))
+
+ (if (and (not force)
+ (eq 'DISABLE (gnus-agent-find-parameter group
+ 'agent-enable-expiration)))
+ (gnus-message 5 "Expiry skipping over %s" group)
+ (gnus-message 5 "Expiring articles in %s" group)
+ (gnus-agent-load-alist group)
+ (let* ((bytes-freed 0)
+ (size-files-deleted 0.0)
+ (files-deleted 0)
+ (nov-entries-deleted 0)
+ (info (gnus-get-info group))
+ (alist gnus-agent-article-alist)
+ (day (- (time-to-days (current-time))
+ (gnus-agent-find-parameter group 'agent-days-until-old)))
+ (specials (if (and alist
+ (not force))
+ ;; This could be a bit of a problem. I need to
+ ;; keep the last article to avoid refetching
+ ;; headers when using nntp in the backend. At
+ ;; the same time, if someone uses a backend
+ ;; that supports article moving then I may have
+ ;; to remove the last article to complete the
+ ;; move. Right now, I'm going to assume that
+ ;; FORCE overrides specials.
+ (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 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 excluded 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_position) 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)
+ (buffer-disable-undo)
+ (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), append the position
+ ;; to the list
+ (push (list (+ 0 (read (current-buffer))) nil nil
+ 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... ")
- ;; If two entries have the same article-number then sort by
- ;; ascending keep_flag.
- (let ((special 0)
- (marked 1)
- (unread 2))
- (setq dlist
- (sort dlist
- (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 (truncate (* 100.0
- (/ (setq cnt (1+ cnt))
- len)))))
- (when (> new-completed completed)
- (setq completed new-completed)
- (gnus-message 7 "%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
- (gnus-agent-message 10
- "gnus-agent-expire: Article %d: Kept %s article."
- article-number keep)
- (when fetch-date
- (unless (file-exists-p
- (concat dir (number-to-string
- article-number)))
- (setf (nth 1 entry) nil)
- (gnus-agent-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 \
+ ;; 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... ")
+ ;; If two entries have the same article-number then sort by
+ ;; ascending keep_flag.
+ (let ((special 0)
+ (marked 1)
+ (unread 2))
+ (setq dlist
+ (sort dlist
+ (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_position
+
+ (setcdr dlist (cddr dlist)))
+ (setq dlist (cdr dlist)))))
+
+ ;; Check the order of the entry positions. They should be in
+ ;; ascending order. If they aren't, the positions must be
+ ;; converted to markers.
+ (when (let ((dlist dlist)
+ (prev-pos -1)
+ pos)
+ (while dlist
+ (if (setq pos (nth 3 (pop dlist)))
+ (if (< pos prev-pos)
+ (throw 'sort-results 'unsorted)
+ (setq prev-pos pos)))))
+ (gnus-message 7 "gnus-agent-expire: Unsorted overview; inserting markers to compensate.")
+ (mapcar (lambda (entry)
+ (let ((pos (nth 3 entry)))
+ (if pos
+ (setf (nth 3 entry)
+ (set-marker (make-marker)
+ pos)))))
+ dlist))
+
+ (gnus-message 7 "gnus-agent-expire: Merging entries... Done")
+
+ (let* ((len (float (length dlist)))
+ (alist (list nil))
+ (tail-alist alist)
+ (position-offset 0)
+ )
+
+ (while dlist
+ (let ((new-completed (truncate (* 100.0
+ (/ (setq cnt (1+ cnt))
+ len))))
+ message-log-max)
+ (when (> new-completed completed)
+ (setq completed new-completed)
+ (gnus-message 7 "%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
+ (gnus-agent-message 10
+ "gnus-agent-expire: %s:%d: Kept %s article%s."
+ group article-number keep (if fetch-date " and file" ""))
+ (when fetch-date
+ (unless (file-exists-p
+ (concat dir (number-to-string
+ article-number)))
+ (setf (nth 1 entry) nil)
+ (gnus-agent-message 3 "gnus-agent-expire cleared \
+download flag on %s:%d as the cached article file is missing."
+ group (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 day)
- '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" actions)
- (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 (That is, articles that preceed the
- ;; first article in the new alist).
- (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 \
+ (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 day)
+ 'expired)
+ (force
+ 'forced)))
+
+ ;; I found some reason to expire this entry.
+
+ (let ((actions nil))
+ (when (memq type '(forced expired))
+ (ignore-errors ; Just being paranoid.
+ (let* ((file-name (nnheader-concat dir (number-to-string
+ article-number)))
+ (size (float (nth 7 (file-attributes file-name)))))
+ (incf bytes-freed size)
+ (incf size-files-deleted size)
+ (incf files-deleted)
+ (delete-file file-name))
+ (push "expired cached article" actions))
+ (setf (nth 1 entry) nil)
+ )
+
+ (when marker
+ (push "NOV entry removed" actions)
+
+ (goto-char (if (markerp marker)
+ marker
+ (- marker position-offset)))
+
+ (incf nov-entries-deleted)
+
+ (let* ((from (point-at-bol))
+ (to (progn (forward-line 1) (point)))
+ (freed (- to from)))
+ (incf bytes-freed freed)
+ (incf position-offset freed)
+ (delete-region from to)))
+
+ ;; If considering all articles is set, I can only
+ ;; expire article IDs that are no longer in the
+ ;; active range (That is, articles that preceed the
+ ;; first article in the new alist).
+ (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-agent-message 8 "gnus-agent-expire: Article %d: %s"
- article-number
- (mapconcat 'identity actions ", "))))
- (t
- (gnus-agent-message
- 10 "gnus-agent-expire: Article %d: Article kept as \
-expiration tests failed." article-number)
- (gnus-agent-append-to-list
- tail-alist (cons article-number fetch-date)))
- )
-
- ;; 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 group)
-
- ;; The active list changed, set the agent's active range
- ;; to match the beginning of the list.
- (if alist
- (setcar active (caar alist))))
-
- (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))))))))
+ (when actions
+ (gnus-agent-message 8 "gnus-agent-expire: %s:%d: %s"
+ group article-number
+ (mapconcat 'identity actions ", ")))))
+ (t
+ (gnus-agent-message
+ 10 "gnus-agent-expire: %s:%d: Article kept as \
+expiration tests failed." group article-number)
+ (gnus-agent-append-to-list
+ tail-alist (cons article-number fetch-date)))
+ )
+
+ ;; Remove markers as I intend to reuse this buffer again.
+ (when (and marker
+ (markerp 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 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)
+ (gnus-agent-update-view-total-fetched-for group t)))
+
+ (when (eq articles t)
+ (gnus-summary-update-info))))
+
+ (when (boundp 'gnus-agent-expire-stats)
+ (let ((stats (symbol-value 'gnus-agent-expire-stats)))
+ (incf (nth 2 stats) bytes-freed)
+ (incf (nth 1 stats) files-deleted)
+ (incf (nth 0 stats) nov-entries-deleted)))
+
+ (gnus-agent-update-files-total-fetched-for group (- size-files-deleted)))))))
(defun gnus-agent-expire (&optional articles group force)
"Expire all old articles.
Setting GROUP will limit expiration to that group.
FORCE is equivalent to setting the expiration predicates to true."
(interactive)
-
+
(if group
(gnus-agent-expire-group group articles force)
(if (or (not (eq articles t))
(yes-or-no-p "Are you sure that you want to expire all \
articles in every agentized group."))
- (let ((methods gnus-agent-covered-methods)
+ (let ((methods (gnus-agent-covered-methods))
;; Bind gnus-agent-expire-current-dirs to enable tracking
;; of agent directories.
(gnus-agent-expire-current-dirs nil)
+ ;; Bind gnus-agent-expire-stats to enable tracking of
+ ;; expiration statistics across all groups
+ (gnus-agent-expire-stats (list 0 0 0.0))
gnus-command-method overview orig)
(setq overview (gnus-get-buffer-create " *expire overview*"))
(unwind-protect
gnus-command-method))
(let* ((active
(gnus-gethash-safe expiring-group orig)))
-
+
(when active
(save-excursion
(gnus-agent-expire-group-1
- expiring-group overview active articles force)))))
- (gnus-agent-write-active active-file orig t))))
+ expiring-group overview active articles force))))))))
(kill-buffer overview))
(gnus-agent-expire-unagentized-dirs)
- (gnus-message 4 "Expiry...done")))))
+ (gnus-message 4 (gnus-agent-expire-done-message))))))
+
+(defun gnus-agent-expire-done-message ()
+ (if (and (> gnus-verbose 4)
+ (boundp 'gnus-agent-expire-stats))
+ (let* ((stats (symbol-value 'gnus-agent-expire-stats))
+ (size (nth 2 stats))
+ (units '(B KB MB GB)))
+ (while (and (> size 1024.0)
+ (cdr units))
+ (setq size (/ size 1024.0)
+ units (cdr units)))
+
+ (format "Expiry recovered %d NOV entries, deleted %d files,\
+ and freed %f %s."
+ (nth 0 stats)
+ (nth 1 stats)
+ size (car units)))
+ "Expiry...done"))
(defun gnus-agent-expire-unagentized-dirs ()
(when (and gnus-agent-expire-unagentized-dirs
(checker
(function
(lambda (d)
- "Given a directory, check it and its subdirectories for
- membership in the keep hash. If it isn't found, add
- it to to-remove."
+ "Given a directory, check it and its subdirectories for
+ membership in the keep hash. If it isn't found, add
+ it to to-remove."
(let ((files (directory-files d))
file)
(while (setq file (pop files))
nil)
((equal file "..") ; Ignore parent
nil)
- ((equal file ".overview")
+ ((equal file ".overview")
;; Directory must contain .overview to be
;; agent's cache of a group.
(let ((d (file-name-as-directory d))
d (directory-file-name d)))
;; if ANY ancestor was NOT in keep hash and
;; it it's already in to-remove, add it to
- ;; to-remove.
+ ;; to-remove.
(if (and r
(not (member r to-remove)))
(push r to-remove))))
deleting them?")))
(while to-remove
(let ((dir (pop to-remove)))
- (if (gnus-y-or-n-p (format "Delete %s?" dir))
+ (if (gnus-y-or-n-p (format "Delete %s? " dir))
(let* (delete-recursive
(delete-recursive
(function
(gnus-agent-append-to-list tail-unread candidate)
nil)
((> candidate max)
- (pop read)))))))
+ (setq read (cdr read))
+ ;; return t so that I always loop one more
+ ;; time. If I just iterated off the end of
+ ;; read, min will become nil and the current
+ ;; candidate will be added to the unread list.
+ t))))))
(while known
(gnus-agent-append-to-list tail-unread (car (pop known))))
(cdr unread)))
(defun gnus-agent-uncached-articles (articles group &optional cached-header)
"Restrict ARTICLES to numbers already fetched.
-Returns a sublist of ARTICLES that excludes thos article ids in GROUP
+Returns a sublist of ARTICLES that excludes those article ids in GROUP
that have already been fetched.
If CACHED-HEADER is nil, articles are only excluded if the article itself
has been fetched."
(v2 (caar ref)))
(cond ((< v1 v2) ; v1 does not appear in the reference list
(gnus-agent-append-to-list tail-uncached v1)
- (pop arts))
+ (setq arts (cdr arts)))
((= v1 v2)
(unless (or cached-header (cdar ref)) ; v1 is already cached
(gnus-agent-append-to-list tail-uncached v1))
- (pop arts)
- (pop ref))
+ (setq arts (cdr arts))
+ (setq ref (cdr ref)))
(t ; reference article (v2) preceeds the list being filtered
- (pop ref)))))
+ (setq ref (cdr ref))))))
(while arts
(gnus-agent-append-to-list tail-uncached (pop arts)))
(cdr uncached))
;; Get the list of articles that were fetched
(goto-char (point-min))
- (let ((pm (point-max)))
+ (let ((pm (point-max))
+ art)
(while (< (point) pm)
- (when (looking-at "[0-9]+\t")
- (gnus-agent-append-to-list
- tail-fetched-articles
- (read (current-buffer))))
+ (when (setq art (gnus-agent-read-article-number))
+ (gnus-agent-append-to-list tail-fetched-articles art))
(forward-line 1)))
;; Clip this list to the headers that will
(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))
+ ;; Merge the temp buffer with the known headers (found on
+ ;; disk in FILE) into the nntp-server-buffer
+ (when uncached-articles
(gnus-agent-braid-nov group uncached-articles file))
- ;; Save the new set of known headers to 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))
+ (gnus-agent-update-view-total-fetched-for group t)
+
;; Update the group's article alist to include the newly
;; fetched articles.
(gnus-agent-load-alist group)
(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 a list, the specified articles will be marked as unread.
+In addition, their NOV entries in .overview will be refreshed using
+the articles' current headers.
If REREAD is not nil, downloaded articles are marked as unread."
(interactive
(list (let ((def (or (gnus-group-group-name)
def)
def
select)))
- (intern-soft
- (read-string
- "Reread (nil)? (t=>all, nil=>none, some=>all downloaded): "))))
- (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 ((and (looking-at "[0-9]+\t")
- (<= (- (match-end 0) (match-beginning 0)) 9))
- (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\
+ (catch 'mark
+ (while (let (c
+ (cursor-in-echo-area t)
+ (echo-keystrokes 0))
+ (message "Mark as unread: (n)one / (a)ll / all (d)ownloaded articles? (n) ")
+ (setq c (read-char-exclusive))
+
+ (cond ((or (eq c ?\r) (eq c ?n) (eq c ?N))
+ (throw 'mark nil))
+ ((or (eq c ?a) (eq c ?A))
+ (throw 'mark t))
+ ((or (eq c ?d) (eq c ?D))
+ (throw 'mark 'some)))
+ (gnus-message 3 "Ignoring unexpected input")
+ (sit-for 1)
+ t)))))
+ (when group
+ (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-number 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 ((and (looking-at "[0-9]+\t")
+ (<= (- (match-end 0) (match-beginning 0)) 9))
+ (push (read (current-buffer)) nov-arts)
+ (forward-line 1)
+ (let ((l1 (car nov-arts))
+ (l2 (cadr nov-arts)))
+ (cond ((and (listp reread) (memq l1 reread))
+ (gnus-delete-line)
+ (setq nov-arts (cdr nov-arts))
+ (gnus-message 4 "gnus-agent-regenerate-group: NOV\
+ entry of article %s deleted." l1))
+ ((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\
+ ;; 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\
+ (gnus-delete-line)
+ (setq nov-arts (cdr 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\
+ (gnus-delete-line))))
+ (when load
+ (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 o)
- nil)
- ((not n)
- (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))
- )
-
- (gnus-message 5 nil)
- regenerated))
+ (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)
+ (setq downloaded (cdr downloaded))
+ (setq nov-arts (cdr nov-arts)))
+ (t
+ ;; This entry in the overview has not been downloaded
+ (push (cons (car nov-arts) nil) alist)
+ (setq nov-arts (cdr 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))))
+ (setq o (cdr o)))
+ ((< oID nID)
+ (setcdr n (cons (list oID) (cdr n)))
+ (setq o (cdr o)))
+ ((= oID nID)
+ (setq o (cdr o))
+ (setq n (cdr n)))
+ (t
+ (setq n (cdr 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 o)
+ nil)
+ ((not n)
+ (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)
+
+ ;; I have to alter the group's active range NOW as
+ ;; gnus-make-ascending-articles-unread will use it to
+ ;; recalculate the number of unread articles in the group
+
+ (let ((group (gnus-group-real-name group))
+ (group-active (or (gnus-active group)
+ (gnus-activate-group group))))
+ (gnus-agent-possibly-alter-active group group-active)))))
+
+ (when (and reread gnus-agent-article-alist)
+ (gnus-agent-synchronize-group-flags
+ group
+ (list (list
+ (if (listp reread)
+ reread
+ (delq nil (mapcar (function (lambda (c)
+ (cond ((eq reread t)
+ (car c))
+ ((cdr c)
+ (car c)))))
+ gnus-agent-article-alist)))
+ 'del '(read)))
+ gnus-command-method)
+
+ (when regenerated
+ (gnus-agent-update-files-total-fetched-for group nil)))
+
+ (gnus-message 5 "")
+ regenerated)))
;;;###autoload
(defun gnus-agent-regenerate (&optional clean reread)
"Regenerate all agent covered files.
-If CLEAN, don't read existing active files."
+If CLEAN, obsolete (ignore)."
(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 (gnus-command-method (gnus-agent-covered-methods))
(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)))))
+ regenerated))))
(gnus-message 4 "Regenerating Gnus agent files...done")
+
regenerated))
(defun gnus-agent-go-online (&optional force)
(if (eq status 'offline) 'online 'offline))))
(defun gnus-agent-group-covered-p (group)
- (member (gnus-group-method group)
- gnus-agent-covered-methods))
-
-(add-hook 'gnus-group-prepare-hook
- (lambda ()
- 'gnus-agent-do-once
-
- (when (listp gnus-agent-expire-days)
- (beep)
- (beep)
- (gnus-message 1 "WARNING: gnus-agent-expire-days no longer\
- supports being set to a list.")(sleep-for 3)
- (gnus-message 1 "Change your configuration to set it to an\
- integer.")(sleep-for 3)
- (gnus-message 1 "I am now setting group parameters on each\
- group to match the configuration that the list offered.")
-
- (save-excursion
- (let ((groups (gnus-group-listed-groups)))
- (while groups
- (let* ((group (pop groups))
- (days gnus-agent-expire-days)
- (day (catch 'found
- (while days
- (when (eq 0 (string-match
- (caar days)
- group))
- (throw 'found (cadar days)))
- (pop days))
- nil)))
- (when day
- (gnus-group-set-parameter group 'agent-days-until-old
- day))))))
-
- (let ((h gnus-group-prepare-hook))
- (while h
- (let ((func (pop h)))
- (when (and (listp func)
- (eq (cadr (caddr func)) 'gnus-agent-do-once))
- (remove-hook 'gnus-group-prepare-hook func)
- (setq h nil)))))
-
- (gnus-message 1 "I have finished setting group parameters on\
- each group. You may now customize your groups and/or topics to control the\
- agent."))))
+ (gnus-agent-method-p (gnus-group-method group)))
+
+;; Added to support XEmacs
+(eval-and-compile
+ (unless (fboundp 'directory-files-and-attributes)
+ (defun directory-files-and-attributes (directory
+ &optional full match nosort)
+ (let (result)
+ (dolist (file (directory-files directory full match nosort))
+ (push (cons file (file-attributes file)) result))
+ (nreverse result)))))
+
+(defun gnus-agent-update-files-total-fetched-for
+ (group delta &optional method path)
+ "Update, or set, the total disk space used by the articles that the
+agent has fetched."
+ (when gnus-agent-total-fetched-hashtb
+ (gnus-agent-with-refreshed-group
+ group
+ ;; if null, gnus-agent-group-pathname will calc method.
+ (let* ((gnus-command-method method)
+ (path (or path (gnus-agent-group-pathname group)))
+ (entry (or (gnus-gethash path gnus-agent-total-fetched-hashtb)
+ (gnus-sethash path (make-list 3 0)
+ gnus-agent-total-fetched-hashtb))))
+ (when (listp delta)
+ (if delta
+ (let ((sum 0.0)
+ file)
+ (while (setq file (pop delta))
+ (incf sum (float (or (nth 7 (file-attributes
+ (nnheader-concat
+ path
+ (if (numberp file)
+ (number-to-string file)
+ file)))) 0))))
+ (setq delta sum))
+ (let ((sum (- (nth 2 entry)))
+ (info (directory-files-and-attributes path nil "^-?[0-9]+$" t))
+ file)
+ (while (setq file (pop info))
+ (incf sum (float (or (nth 8 file) 0))))
+ (setq delta sum))))
+
+ (setq gnus-agent-need-update-total-fetched-for t)
+ (incf (nth 2 entry) delta)))))
+
+(defun gnus-agent-update-view-total-fetched-for
+ (group agent-over &optional method path)
+ "Update, or set, the total disk space used by the .agentview and
+.overview files. These files are calculated separately as they can be
+modified."
+ (when gnus-agent-total-fetched-hashtb
+ (gnus-agent-with-refreshed-group
+ group
+ ;; if null, gnus-agent-group-pathname will calc method.
+ (let* ((gnus-command-method method)
+ (path (or path (gnus-agent-group-pathname group)))
+ (entry (or (gnus-gethash path gnus-agent-total-fetched-hashtb)
+ (gnus-sethash path (make-list 3 0)
+ gnus-agent-total-fetched-hashtb)))
+ (size (or (nth 7 (file-attributes
+ (nnheader-concat
+ path (if agent-over
+ ".overview"
+ ".agentview"))))
+ 0)))
+ (setq gnus-agent-need-update-total-fetched-for t)
+ (setf (nth (if agent-over 1 0) entry) size)))))
+
+(defun gnus-agent-total-fetched-for (group &optional method no-inhibit)
+ "Get the total disk space used by the specified GROUP."
+ (unless gnus-agent-total-fetched-hashtb
+ (setq gnus-agent-total-fetched-hashtb (gnus-make-hashtable 1024)))
+
+ ;; if null, gnus-agent-group-pathname will calc method.
+ (let* ((gnus-command-method method)
+ (path (gnus-agent-group-pathname group))
+ (entry (gnus-gethash path gnus-agent-total-fetched-hashtb)))
+ (if entry
+ (apply '+ entry)
+ (let ((gnus-agent-inhibit-update-total-fetched-for (not no-inhibit)))
+ (+
+ (gnus-agent-update-view-total-fetched-for group nil method path)
+ (gnus-agent-update-view-total-fetched-for group t method path)
+ (gnus-agent-update-files-total-fetched-for group nil method path))))))
(provide 'gnus-agent)
+;;; arch-tag: b0ba4afc-5229-4cee-ad25-9956daa4e91e
;;; gnus-agent.el ends here
projects / gnus / blobdiff