X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-agent.el;h=432aabbc4ad293fa886a9cfd53c1047e5d76757d;hb=b7fcf976d418fab4b68186deac82998135d14db2;hp=8da2708596aed8679a125e151d172e36ea4859cc;hpb=e405b22c6b46721607c5e6c712a4705c23dee751;p=gnus diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index 8da270859..432aabbc4 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -1,24 +1,22 @@ ;;; gnus-agent.el --- unplugged support for Gnus -;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 -;; Free Software Foundation, Inc. + +;; Copyright (C) 1997-2014 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; 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. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -38,10 +36,8 @@ (require 'timer)) (require 'cl)) -(eval-and-compile - (autoload 'gnus-server-update-server "gnus-srvr") - (autoload 'gnus-agent-customize-category "gnus-cus") -) +(autoload 'gnus-server-update-server "gnus-srvr") +(autoload 'gnus-agent-customize-category "gnus-cus") (defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/") "Where the Gnus agent will store its files." @@ -117,6 +113,8 @@ If nil, only read articles will be expired." (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." + ;; If the default switches to something else than nil, then the function + ;; should be fixed not be exceedingly slow. See 2005-09-20 ChangeLog entry. :version "21.1" :type '(choice (const :tag "Always" t) (const :tag "Never" nil) @@ -185,10 +183,10 @@ When found, offer to remove them." :type 'boolean :group 'gnus-agent) -(defcustom gnus-agent-auto-agentize-methods '(nntp nnimap) +(defcustom gnus-agent-auto-agentize-methods nil "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'." +See Info nodes `(gnus)Server Buffer', `(gnus)Agent Variables'." :version "22.1" :type '(repeat symbol) :group 'gnus-agent) @@ -201,15 +199,26 @@ queue. Otherwise, queue if and only if unplugged." :group 'gnus-agent :type '(radio (const :format "Always" always) (const :format "Never" nil) - (const :format "When plugged" t))) + (const :format "When unplugged" t))) (defcustom gnus-agent-prompt-send-queue nil - "If non-nil, `gnus-group-send-queue' will prompt if called when -unplugged." + "If non-nil, `gnus-group-send-queue' will prompt if called when unplugged." :version "22.1" :group 'gnus-agent :type 'boolean) +(defcustom gnus-agent-article-alist-save-format 1 + "Indicates whether to use compression(2), versus no +compression(1), when writing agentview files. The compressed +files do save space but load times are 6-7 times higher. A group +must be opened then closed for the agentview to be updated using +the new format." + ;; Wouldn't symbols instead numbers be nicer? --rsteib + :version "22.1" + :group 'gnus-agent + :type '(radio (const :format "Compressed" 2) + (const :format "Uncompressed" 1))) + ;;; Internal variables (defvar gnus-agent-history-buffers nil) @@ -233,7 +242,6 @@ NOTES: (defvar gnus-category-group-cache nil) (defvar gnus-agent-spam-hashtb nil) (defvar gnus-agent-file-name nil) -(defvar gnus-agent-send-mail-function nil) (defvar gnus-agent-file-coding-system 'raw-text) (defvar gnus-agent-file-loading-cache nil) (defvar gnus-agent-total-fetched-hashtb nil) @@ -244,6 +252,16 @@ NOTES: (defvar gnus-headers) (defvar gnus-score) +;; 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))))) + ;;; ;;; Setup ;;; @@ -284,8 +302,7 @@ 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) + (with-current-buffer gnus-group-buffer (setq gnus-agent-need-update-total-fetched-for nil) (gnus-group-update-group ,group t))))) @@ -337,23 +354,11 @@ 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 - ))))) + (list 'cdr (list 'assq '',prop-name category))) + + (defsetf ,name (category) (value) + (list 'gnus-agent-cat-set-property + category '',prop-name value)))) ) (defmacro gnus-agent-cat-name (category) @@ -368,35 +373,23 @@ manipulated as follows: (gnus-agent-cat-defaccessor gnus-agent-cat-high-score agent-high-score) (gnus-agent-cat-defaccessor - gnus-agent-cat-length-when-long agent-length-when-long) + gnus-agent-cat-length-when-long agent-long-article) (gnus-agent-cat-defaccessor - gnus-agent-cat-length-when-short agent-length-when-short) + gnus-agent-cat-length-when-short agent-short-article) (gnus-agent-cat-defaccessor gnus-agent-cat-low-score agent-low-score) (gnus-agent-cat-defaccessor gnus-agent-cat-predicate agent-predicate) (gnus-agent-cat-defaccessor - gnus-agent-cat-score-file agent-score-file) + gnus-agent-cat-score-file agent-score) (gnus-agent-cat-defaccessor - gnus-agent-cat-enable-undownloaded-faces agent-enable-undownloaded-faces) - + gnus-agent-cat-enable-undownloaded-faces agent-enable-undownloaded-faces) -;; 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--)))) - ) +;; This form may expand to code that uses CL functions at run-time, +;; but that's OK since those functions will only ever be called from +;; something like `setf', so only when CL is loaded anyway. +(defsetf gnus-agent-cat-groups gnus-agent-set-cat-groups) (defun gnus-agent-set-cat-groups (category groups) (unless (eq groups 'ignore) @@ -423,7 +416,7 @@ manipulated as follows: (setf (gnus-agent-cat-groups old-category) (delete group (gnus-agent-cat-groups old-category)))))) - ;; Purge cache as preceeding loop invalidated it. + ;; Purge cache as preceding loop invalidated it. (setq gnus-category-group-cache nil)) (setcdr (or (assq 'agent-groups category) @@ -434,6 +427,13 @@ manipulated as follows: (defsubst gnus-agent-cat-make (name &optional default-agent-predicate) (list name `(agent-predicate . ,(or default-agent-predicate 'false)))) +(defun gnus-agent-read-group () + "Read a group name in the minibuffer, with completion." + (let ((def (or (gnus-group-group-name) gnus-newsgroup-name))) + (when def + (setq def (gnus-group-decoded-name def))) + (gnus-group-completing-read nil nil t nil nil def))) + ;;; Fetching setup functions. (defun gnus-agent-start-fetch () @@ -443,8 +443,7 @@ manipulated as follows: (defun gnus-agent-stop-fetch () "Save all data structures and clean up." (setq gnus-agent-spam-hashtb nil) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (widen))) (defmacro gnus-agent-with-fetch (&rest forms) @@ -487,13 +486,13 @@ manipulated as follows: ;; Set up the menu. (when (gnus-visual-p 'agent-menu 'menu) (funcall (intern (format "gnus-agent-%s-make-menu-bar" buffer)))) - (unless (assq 'gnus-agent-mode minor-mode-alist) - (push gnus-agent-mode-status minor-mode-alist)) + (unless (assq mode minor-mode-alist) + (push (cons mode (cdr gnus-agent-mode-status)) minor-mode-alist)) (unless (assq mode minor-mode-map-alist) (push (cons mode (symbol-value (intern (format "gnus-agent-%s-mode-map" buffer)))) minor-mode-map-alist)) - (when (eq major-mode 'gnus-group-mode) + (when (derived-mode-p 'gnus-group-mode) (let ((init-plugged gnus-plugged) (gnus-agent-go-online nil)) ;; g-a-t-p does nothing when gnus-plugged isn't changed. @@ -575,7 +574,15 @@ manipulated as follows: (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 + (if (and (featurep 'xemacs) + ;; XEmacs's `facep' only checks for a face + ;; object, not for a face name, so it's useless + ;; to check with `facep'. + (find-face 'modeline)) + 'modeline + 'mode-line-highlight)) string)) (defun gnus-agent-toggle-plugged (set-to) @@ -590,8 +597,7 @@ manipulated as follows: (gnus-agent-make-mode-line-string " Plugged" 'mouse-2 'gnus-agent-toggle-plugged)) - (gnus-agent-go-online gnus-agent-go-online) - (gnus-agent-possibly-synchronize-flags)) + (gnus-agent-go-online gnus-agent-go-online)) (t (gnus-agent-close-connections) (setq gnus-plugged set-to) @@ -652,17 +658,14 @@ This will modify the `gnus-setup-news-hook', and minor mode in all Gnus buffers." (interactive) (gnus-open-agent) - (add-hook 'gnus-setup-news-hook 'gnus-agent-queue-setup) - (unless gnus-agent-send-mail-function - (setq gnus-agent-send-mail-function - (or message-send-mail-real-function - (function (lambda () (funcall message-send-mail-function)))) - message-send-mail-real-function 'gnus-agent-send-mail)) + (setq message-send-mail-real-function 'gnus-agent-send-mail) ;; 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")) + (when (and (not (file-exists-p (nnheader-concat + gnus-agent-directory "lib/servers"))) + gnus-agent-auto-agentize-methods) (gnus-message 3 "First time agent user, agentizing remote groups...") (mapc (lambda (server-or-method) @@ -691,13 +694,14 @@ Optional arg GROUP-NAME allows to specify another group." (defun gnus-agent-send-mail () (if (or (not gnus-agent-queue-mail) (and gnus-plugged (not (eq gnus-agent-queue-mail 'always)))) - (funcall gnus-agent-send-mail-function) + (message-multi-smtp-send-mail) (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n")) (replace-match "\n") (gnus-agent-insert-meta-information 'mail) - (gnus-request-accept-article "nndraft:queue" nil t t))) + (gnus-request-accept-article "nndraft:queue" nil t t) + (gnus-group-refresh-group "nndraft:queue"))) (defun gnus-agent-insert-meta-information (type &optional method) "Insert meta-information into the message that says how it's to be posted. @@ -768,23 +772,24 @@ be a select method." (setq group (or group gnus-newsgroup-name)) (unless group (error "No group on the current line")) - - (gnus-agent-while-plugged - (let ((gnus-command-method (gnus-find-method-for-group group))) - (gnus-agent-with-fetch - (gnus-agent-fetch-group-1 group gnus-command-method) - (gnus-message 5 "Fetching %s...done" group))))) + (if (not (gnus-agent-group-covered-p group)) + (message "%s isn't covered by the agent" group) + (gnus-agent-while-plugged + (let ((gnus-command-method (gnus-find-method-for-group group))) + (gnus-agent-with-fetch + (gnus-agent-fetch-group-1 group gnus-command-method) + (gnus-message 5 "Fetching %s...done" group)))))) (defun gnus-agent-add-group (category arg) "Add the current group to an agent category." (interactive (list (intern - (completing-read - "Add to category: " - (mapcar (lambda (cat) (list (symbol-name (car cat)))) + (gnus-completing-read + "Add to category" + (mapcar (lambda (cat) (symbol-name (car cat))) gnus-category-alist) - nil t)) + t)) current-prefix-arg)) (let ((cat (assq category gnus-category-alist)) c groups) @@ -822,8 +827,7 @@ be a select method." (interactive) (save-excursion (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))) + (when (eq (gnus-server-status gnus-command-method) 'ok) (gnus-agent-possibly-synchronize-flags-server gnus-command-method))))) (defun gnus-agent-synchronize-flags-server (method) @@ -859,26 +863,31 @@ be a select method." (defun gnus-agent-possibly-synchronize-flags-server (method) "Synchronize flags for server according to `gnus-agent-synchronize-flags'." - (when (or (and gnus-agent-synchronize-flags - (not (eq gnus-agent-synchronize-flags 'ask))) - (and (eq gnus-agent-synchronize-flags 'ask) - (gnus-y-or-n-p (format "Synchronize flags on server `%s'? " - (cadr method))))) + (when (and (file-exists-p (gnus-agent-lib-file "flags")) + (or (and gnus-agent-synchronize-flags + (not (eq gnus-agent-synchronize-flags 'ask))) + (and (eq gnus-agent-synchronize-flags 'ask) + (gnus-y-or-n-p + (format "Synchronize flags on server `%s'? " + (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." + "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) + (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))))) + (let ((gnus-command-method new-command-method)) + (gnus-agent-group-pathname new-group)))) + (file-name-coding-system nnmail-pathname-coding-system)) (gnus-rename-file old-path new-path t) (let* ((old-real-group (gnus-group-real-name old-group)) @@ -898,23 +907,25 @@ next enabled. Depends upon the caller to determine whether group renaming is sup ;;;###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." + "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))))) + (let ((gnus-command-method command-method)) + (gnus-agent-group-pathname group)))) + (file-name-coding-system nnmail-pathname-coding-system)) (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))))) + ;; FIXME: Does gnus-agent-get-local have any useful side-effect? + (gnus-agent-get-local group real-group command-method) + (gnus-agent-set-local group + nil nil + real-group command-method)))) ;;; ;;; Server mode commands @@ -983,7 +994,7 @@ next enabled. Depends upon the caller to determine whether group deletion is sup (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)))) + (gnus-message 8 "Ignoring disappeared server `%s'" server)))) (prog1 gnus-agent-covered-methods (setq gnus-agent-covered-methods nil)))) @@ -1089,7 +1100,7 @@ article's mark is toggled." (setq alist (cdr alist))) ((> a h) ;; Headers that are not in the alist should be - ;; fictious (see nnagent-retrieve-headers); they + ;; fictitious (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) @@ -1140,24 +1151,27 @@ downloadable." (gnus-summary-position-point))) (defun gnus-agent-summary-fetch-series () + "Fetch the process-marked articles into the Agent." (interactive) (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. - - ;; 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))))) + (processable (sort (gnus-copy-sequence gnus-newsgroup-processable) '<)) + (gnus-newsgroup-downloadable processable)) + (gnus-agent-summary-fetch-group) + + ;; 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 preceding 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. @@ -1185,8 +1199,9 @@ Optional arg ALL, if non-nil, means to fetch all articles." (cond (gnus-agent-mark-unread-after-downloaded (setq gnus-newsgroup-downloadable (delq article gnus-newsgroup-downloadable)) - - (gnus-summary-mark-article article gnus-unread-mark)) + (when (and (not (member article gnus-newsgroup-dormant)) + (not (member article gnus-newsgroup-marked))) + (gnus-summary-mark-article article gnus-unread-mark))) (was-marked-downloadable (gnus-summary-set-agent-mark article t))) (when (gnus-summary-goto-subject article nil t) @@ -1250,18 +1265,31 @@ This can be added to `gnus-select-article-hook' or 'gnus-range-add 'gnus-remove-from-range) (cdr info-marks) - range))))))))) + 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) +(defun gnus-agent-save-active (method &optional groups-p) + "Sync the agent's active file with the current buffer. +Pass non-nil for GROUPS-P if the buffer starts out in groups format. +Regardless, both the file and the buffer end up in active format +if METHOD is agentized; otherwise the function is a no-op." (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"))) - (gnus-active-to-gnus-format nil new) + (if groups-p + (gnus-groups-to-gnus-format nil new) + (gnus-active-to-gnus-format nil new)) (gnus-agent-write-active file new) (erase-buffer) - (nnheader-insert-file-contents file)))) + (let ((nnheader-file-coding-system gnus-agent-file-coding-system)) + (nnheader-insert-file-contents file))))) (defun gnus-agent-write-active (file new) (gnus-make-directory (file-name-directory file)) @@ -1318,7 +1346,7 @@ downloaded into the agent." ;; 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. + ;; encompass the new active range. (gnus-agent-set-local group agent-min (1- active-min))))))) (defun gnus-agent-save-group-info (method group active) @@ -1374,6 +1402,18 @@ downloaded into the agent." oactive-min (read (current-buffer))) ;; min (cons oactive-min oactive-max)))))))) +(defvar gnus-agent-decoded-group-names nil + "Alist of non-ASCII group names and decoded ones.") + +(defun gnus-agent-decoded-group-name (group) + "Return a decoded group name of GROUP." + (or (cdr (assoc group gnus-agent-decoded-group-names)) + (if (string-match "[^\000-\177]" group) + (let ((decoded (gnus-group-decoded-name group))) + (push (cons group decoded) gnus-agent-decoded-group-names) + decoded) + group))) + (defun gnus-agent-group-path (group) "Translate GROUP into a file name." @@ -1385,26 +1425,25 @@ downloaded into the agent." (nnheader-translate-file-chars (nnheader-replace-duplicate-chars-in-string (nnheader-replace-chars-in-string - (gnus-group-real-name (gnus-group-decoded-name group)) + (gnus-group-real-name (gnus-agent-decoded-group-name group)) ?/ ?_) ?. ?_))) (if (or nnmail-use-long-file-names (file-directory-p (expand-file-name group (gnus-agent-directory)))) group - (mm-encode-coding-string - (nnheader-replace-chars-in-string group ?. ?/) - nnmail-pathname-coding-system))) + (nnheader-replace-chars-in-string group ?. ?/))) (defun gnus-agent-group-pathname (group) "Translate GROUP into a file name." ;; nnagent uses nnmail-group-pathname to read articles while ;; unplugged. The agent must, therefore, use the same directory ;; while plugged. - (let ((gnus-command-method (or gnus-command-method - (gnus-find-method-for-group group)))) - (nnmail-group-pathname (gnus-group-real-name - (gnus-group-decoded-name group)) - (gnus-agent-directory)))) + (nnmail-group-pathname + (gnus-group-real-name (gnus-agent-decoded-group-name group)) + (if gnus-command-method + (gnus-agent-directory) + (let ((gnus-command-method (gnus-find-method-for-group group))) + (gnus-agent-directory))))) (defun gnus-agent-get-function (method) (if (gnus-online method) @@ -1449,9 +1488,10 @@ downloaded into the agent." (defun gnus-agent-fetch-articles (group articles) "Fetch ARTICLES from GROUP and put them into the Agent." - (when articles + (when (and articles + (gnus-online (gnus-group-method group))) (gnus-agent-load-alist group) - (let* ((alist gnus-agent-article-alist) + (let* ((alist gnus-agent-article-alist) (headers (if (< (length articles) 2) nil gnus-newsgroup-headers)) (selected-sets (list nil)) (current-set-size 0) @@ -1459,14 +1499,14 @@ downloaded into the agent." header-number) ;; Check each article (while (setq article (pop articles)) - ;; Skip alist entries preceeding this article + ;; Skip alist entries preceding this article (while (> article (or (caar alist) (1+ article))) (setq alist (cdr alist))) ;; Prune off articles that we have already fetched. (unless (and (eq article (caar alist)) (cdar alist)) - ;; Skip headers preceeding this article + ;; Skip headers preceding this article (while (> article (setq header-number (let* ((header (car headers))) @@ -1493,9 +1533,9 @@ downloaded into the agent." ;; 65 char/line. If the line count ;; is missing, arbitrarily assume a ;; size of 1000 characters. - (max (* 65 (mail-header-lines - (car headers))) - 1000) + (max (* 65 (mail-header-lines + (car headers))) + 1000) char-size)) 0)))) (setcar selected-sets (nreverse (car selected-sets))) @@ -1508,13 +1548,15 @@ downloaded into the agent." (dir (gnus-agent-group-pathname group)) (date (time-to-days (current-time))) (case-fold-search t) - pos crosses id) + pos crosses + (file-name-coding-system nnmail-pathname-coding-system)) (setcar selected-sets (nreverse (car selected-sets))) (setq selected-sets (nreverse selected-sets)) (gnus-make-directory dir) - (gnus-message 7 "Fetching articles for %s..." group) + (gnus-message 7 "Fetching articles for %s..." + (gnus-agent-decoded-group-name group)) (unwind-protect (while (setq articles (pop selected-sets)) @@ -1525,7 +1567,8 @@ downloaded into the agent." (let (article) (while (setq article (pop articles)) (gnus-message 10 "Fetching article %s for %s..." - article group) + article + (gnus-agent-decoded-group-name group)) (when (or (gnus-backlog-request-article group article nntp-server-buffer) @@ -1537,8 +1580,7 @@ downloaded into the agent." nntp-server-buffer (point-min) (point-max)) (setq pos (nreverse pos))))) ;; Then save these articles into the Agent. - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (while pos (narrow-to-region (cdar pos) (or (cdadr pos) (point-max))) (goto-char (point-min)) @@ -1553,18 +1595,13 @@ downloaded into the agent." (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) (goto-char (match-end 0))) (gnus-agent-crosspost crosses (caar pos) date))) (goto-char (point-min)) - (if (not (re-search-forward - "^Message-ID: *<\\([^>\n]+\\)>" nil t)) - (setq id "No-Message-ID-in-article") - (setq id (buffer-substring - (match-beginning 1) (match-end 1)))) (let ((coding-system-for-write gnus-agent-file-coding-system)) (write-region (point-min) (point-max) @@ -1585,7 +1622,7 @@ downloaded into the agent." (defun gnus-agent-unfetch-articles (group articles) "Delete ARTICLES that were fetched from GROUP into the agent." (when articles - (gnus-agent-with-refreshed-group + (gnus-agent-with-refreshed-group group (gnus-agent-load-alist group) (let* ((alist (cons nil gnus-agent-article-alist)) @@ -1594,22 +1631,27 @@ downloaded into the agent." (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)))))) + (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))) + (file-name-coding-system + nnmail-pathname-coding-system)) + (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))))) @@ -1617,8 +1659,7 @@ downloaded into the agent." (setq date (or date t)) (let (gnus-agent-article-alist group alist beg end) - (save-excursion - (set-buffer gnus-agent-overview-buffer) + (with-current-buffer gnus-agent-overview-buffer (when (nnheader-find-nov-line article) (forward-word 1) (setq beg (point)) @@ -1629,14 +1670,14 @@ downloaded into the agent." (push (setq alist (list group (gnus-agent-load-alist (caar crosses)))) gnus-agent-group-alist)) (setcdr alist (cons (cons (cdar crosses) date) (cdr alist))) - (save-excursion - (set-buffer (gnus-get-buffer-create (format " *Gnus agent overview %s*" - group))) + (with-current-buffer (gnus-get-buffer-create + (format " *Gnus agent overview %s*"group)) (when (= (point-max) (point-min)) (push (cons group (current-buffer)) gnus-agent-buffer-alist) (ignore-errors - (nnheader-insert-file-contents - (gnus-agent-article-name ".overview" group)))) + (let ((file-name-coding-system nnmail-pathname-coding-system)) + (nnheader-insert-file-contents + (gnus-agent-article-name ".overview" group))))) (nnheader-find-nov-line (string-to-number (cdar crosses))) (insert (string-to-number (cdar crosses))) (insert-buffer-substring gnus-agent-overview-buffer beg end) @@ -1647,7 +1688,8 @@ downloaded into the agent." (when gnus-newsgroup-name (let ((root (gnus-agent-article-name ".overview" gnus-newsgroup-name)) (cnt 0) - name) + name + (file-name-coding-system nnmail-pathname-coding-system)) (while (file-exists-p (setq name (concat root "~" (int-to-string (setq cnt (1+ cnt))) "~")))) @@ -1699,25 +1741,71 @@ and that there are no duplicates." (setq prev-num cur))) (forward-line 1))))))) +(defun gnus-agent-flush-server (&optional server-or-method) + "Flush all agent index files for every subscribed group within + the given SERVER-OR-METHOD. When called with nil, the current + value of gnus-command-method identifies the server." + (let* ((gnus-command-method (if server-or-method + (gnus-server-to-method server-or-method) + gnus-command-method)) + (alist gnus-newsrc-alist)) + (while alist + (let ((entry (pop alist))) + (when (gnus-methods-equal-p gnus-command-method (gnus-info-method entry)) + (gnus-agent-flush-group (gnus-info-group entry))))))) + +(defun gnus-agent-flush-group (group) + "Flush the agent's index files such that the GROUP no longer +appears to have any local content. The actual content, the +article files, may then be deleted using gnus-agent-expire-group. +If flushing was a mistake, the gnus-agent-regenerate-group method +provides an undo mechanism by reconstructing the index files from +the article files." + (interactive (list (gnus-agent-read-group))) + + (let* ((gnus-command-method (or gnus-command-method + (gnus-find-method-for-group group))) + (overview (gnus-agent-article-name ".overview" group)) + (agentview (gnus-agent-article-name ".agentview" group)) + (file-name-coding-system nnmail-pathname-coding-system)) + + (if (file-exists-p overview) + (delete-file overview)) + (if (file-exists-p agentview) + (delete-file agentview)) + + (gnus-agent-update-view-total-fetched-for group nil gnus-command-method) + (gnus-agent-update-view-total-fetched-for group t gnus-command-method) + + ;(gnus-agent-set-local group nil nil) + ;(gnus-agent-save-local t) + (gnus-agent-save-group-info nil group nil))) + (defun gnus-agent-flush-cache () + "Flush the agent's index files such that the group no longer +appears to have any local content. The actual content, the +article files, is then deleted using gnus-agent-expire-group. The +gnus-agent-regenerate-group method provides an undo mechanism by +reconstructing the index files from the article files." + (interactive) (save-excursion - (while gnus-agent-buffer-alist - (set-buffer (cdar gnus-agent-buffer-alist)) - (let ((coding-system-for-write - gnus-agent-file-coding-system)) - (write-region (point-min) (point-max) - (gnus-agent-article-name ".overview" - (caar gnus-agent-buffer-alist)) - nil 'silent)) - (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)) - (princ (cdar gnus-agent-group-alist)) - (insert "\n") - (princ 1 (current-buffer)) - (insert "\n")) - (setq gnus-agent-group-alist (cdr gnus-agent-group-alist))))) + (let ((file-name-coding-system nnmail-pathname-coding-system)) + (while gnus-agent-buffer-alist + (set-buffer (cdar gnus-agent-buffer-alist)) + (let ((coding-system-for-write gnus-agent-file-coding-system)) + (write-region (point-min) (point-max) + (gnus-agent-article-name ".overview" + (caar gnus-agent-buffer-alist)) + nil 'silent)) + (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)) + (princ (cdar gnus-agent-group-alist)) + (insert "\n") + (princ 1 (current-buffer)) + (insert "\n")) + (setq gnus-agent-group-alist (cdr gnus-agent-group-alist)))))) ;;;###autoload (defun gnus-agent-find-parameter (group symbol) @@ -1738,7 +1826,7 @@ variables. Returns the first non-nil value found." . gnus-agent-enable-expiration) (agent-predicate . gnus-agent-predicate))))))) -(defun gnus-agent-fetch-headers (group &optional force) +(defun gnus-agent-fetch-headers (group) "Fetch interesting headers into the agent. The group's overview file will be updated to include the headers while a list of available article numbers will be returned." @@ -1749,10 +1837,20 @@ article numbers will be returned." (gnus-agent-find-parameter group 'agent-predicate))))) (articles (if fetch-all - (gnus-uncompress-range (gnus-active group)) + (if gnus-newsgroup-maximum-articles + (let ((active (gnus-active group))) + (gnus-uncompress-range + (cons (max (car active) + (- (cdr active) + gnus-newsgroup-maximum-articles + -1)) + (cdr active)))) + (gnus-uncompress-range (gnus-active group))) (gnus-list-of-unread-articles group))) (gnus-decode-encoded-word-function 'identity) - (file (gnus-agent-article-name ".overview" group))) + (gnus-decode-encoded-address-function 'identity) + (file (gnus-agent-article-name ".overview" group)) + (file-name-coding-system nnmail-pathname-coding-system)) (unless fetch-all ;; Add articles with marks to the list of article headers we want to @@ -1801,16 +1899,16 @@ article numbers will be returned." (setq articles (gnus-list-range-intersection articles (list (cons low high))))))) - (gnus-message - 10 "gnus-agent-fetch-headers: undownloaded articles are '%s'" - (gnus-compress-sequence articles t)) - - (save-excursion - (set-buffer nntp-server-buffer) + (when articles + (gnus-message + 10 "gnus-agent-fetch-headers: undownloaded articles are '%s'" + (gnus-compress-sequence articles t))) + (with-current-buffer nntp-server-buffer (if articles (progn - (gnus-message 7 "Fetching headers for %s..." group) + (gnus-message 8 "Fetching headers for %s..." + (gnus-agent-decoded-group-name group)) ;; Fetch them. (gnus-make-directory (nnheader-translate-file-chars @@ -1827,7 +1925,7 @@ article numbers will be returned." ;; 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) + (gnus-agent-braid-nov articles file) (let ((coding-system-for-write gnus-agent-file-coding-system)) (gnus-agent-check-overview-buffer) @@ -1843,7 +1941,7 @@ article numbers will be returned." (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 + ;; It is unfortunate 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") @@ -1876,7 +1974,7 @@ article numbers will be returned." (set-buffer nntp-server-buffer) (insert-buffer-substring gnus-agent-overview-buffer b e)))) -(defun gnus-agent-braid-nov (group articles file) +(defun gnus-agent-braid-nov (articles file) "Merge agent overview data with given file. Takes unvalidated headers for ARTICLES from `gnus-agent-overview-buffer' and validated headers from the given @@ -1902,21 +2000,21 @@ doesn't exist, to valid the overview buffer." (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))))) + (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)) @@ -1932,102 +2030,125 @@ doesn't exist, to valid the overview buffer." (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))))))) + (while (catch 'problems + (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)) + ((= art last) + ;; Bad repeat of art number - delete this line + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point)))) + (t + ;; Good art num + (setq last art) + (forward-line 1)))) + (when sort + ;; something is seriously wrong as we simply shouldn't see out-of-order data. + ;; First, we'll fix the sort. + (sort-numeric-fields 1 (point-min) (point-max)) + + ;; but now we have to consider that we may have duplicate rows... + ;; so reset to beginning of file + (goto-char (point-min)) + (setq last -134217728) + + ;; and throw a code that restarts this scan + (throw 'problems t)) + nil)))))) ;; Keeps the compiler from warning about the free variable in ;; gnus-agent-read-agentview. -(eval-when-compile - (defvar gnus-agent-read-agentview)) +(defvar gnus-agent-read-agentview) (defun gnus-agent-load-alist (group) "Load the article-state alist for GROUP." ;; Bind free variable that's used in `gnus-agent-read-agentview'. - (let ((gnus-agent-read-agentview group)) + (let* ((gnus-agent-read-agentview group) + (file-name-coding-system nnmail-pathname-coding-system) + (agentview (gnus-agent-article-name ".agentview" group))) (setq gnus-agent-article-alist - (gnus-cache-file-contents - (gnus-agent-article-name ".agentview" group) - 'gnus-agent-file-loading-cache - 'gnus-agent-read-agentview)))) - -;; Save format may be either 1 or 2. Two is the new, compressed -;; format that is still being tested. Format 1 is uncompressed but -;; known to be reliable. -(defconst gnus-agent-article-alist-save-format 2) + (and (file-exists-p agentview) + (gnus-cache-file-contents + agentview + 'gnus-agent-file-loading-cache + 'gnus-agent-read-agentview))))) (defun gnus-agent-read-agentview (file) "Load FILE and do a `read' there." (with-temp-buffer (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)))) + (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 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 (state sequence uncomp) + (while alist + (setq state (caar alist) + sequence (inline (gnus-uncompress-range (cdar alist))) + alist (cdr alist)) + (while sequence + (push (cons (pop sequence) state) uncomp))) + (setq alist (sort uncomp 'car-less-than-car))) + (setq changed-version (not (= 2 gnus-agent-article-alist-save-format))))) + (when changed-version + (let ((gnus-agent-article-alist alist)) + (gnus-agent-save-alist gnus-agent-read-agentview))) + alist)) + ((end-of-file file-error) + ;; The agentview file is missing. + (condition-case nil + ;; If the agent directory exists, attempt to perform a brute-force + ;; reconstruction of its contents. + (let* (alist + (file-name-coding-system nnmail-pathname-coding-system) + (file-attributes (directory-files-and-attributes + (gnus-agent-article-name "" + gnus-agent-read-agentview) nil "^[0-9]+$" t))) + (while file-attributes + (let ((fa (pop file-attributes))) + (unless (nth 1 fa) + (push (cons (string-to-number (nth 0 fa)) (time-to-days (nth 5 fa))) alist)))) + 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)) (all prev) - print-level print-length item article) + print-level print-length article) (while (setq article (pop articles)) (while (and (cdr prev) (< (caadr prev) article)) @@ -2051,23 +2172,21 @@ doesn't exist, to valid the overview buffer." (cond ((eq gnus-agent-article-alist-save-format 1) (princ gnus-agent-article-alist (current-buffer))) ((eq gnus-agent-article-alist-save-format 2) - (let ((compressed nil)) - (mapcar (lambda (pair) - (let* ((article-id (car pair)) - (day-of-download (cdr pair)) - (comp-list (assq day-of-download compressed))) - (if comp-list - (setcdr comp-list - (cons article-id (cdr comp-list))) - (setq compressed - (cons (list day-of-download article-id) - compressed))) - nil)) gnus-agent-article-alist) - (mapcar (lambda (comp-list) - (setcdr comp-list - (gnus-compress-sequence - (nreverse (cdr comp-list))))) - compressed) + (let ((alist gnus-agent-article-alist) + article-id day-of-download comp-list compressed) + (while alist + (setq article-id (caar alist) + day-of-download (cdar alist) + comp-list (assq day-of-download compressed) + alist (cdr alist)) + (if comp-list + (setcdr comp-list (cons article-id (cdr comp-list))) + (push (list day-of-download article-id) compressed))) + (setq alist compressed) + (while alist + (setq comp-list (pop alist)) + (setcdr comp-list + (gnus-compress-sequence (nreverse (cdr comp-list))))) (princ compressed (current-buffer))))) (insert "\n") (princ gnus-agent-article-alist-save-format (current-buffer)) @@ -2076,23 +2195,31 @@ doesn't exist, to valid the overview buffer." (gnus-agent-update-view-total-fetched-for group nil))) (defvar gnus-agent-article-local nil) +(defvar gnus-agent-article-local-times 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)))) + (when (or (null gnus-agent-article-local-times) + (zerop gnus-agent-article-local-times) + (not (gnus-methods-equal-p + gnus-command-method + (symbol-value (intern "+method" gnus-agent-article-local))))) + (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)) + (when gnus-agent-article-local-times + (incf gnus-agent-article-local-times))) + gnus-agent-article-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)) @@ -2120,7 +2247,8 @@ modified) original contents, they are first saved to their own file." (let (group min max - (cur (current-buffer))) + (cur (current-buffer)) + (obarray my-obarray)) (setq group (read cur) min (read cur) max (read cur)) @@ -2131,7 +2259,7 @@ modified) original contents, they are first saved to their own file." ;; 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: " + (gnus-message 3 "Warning - invalid agent local: %s on line %d: %s" file line (error-message-string err)))) (forward-line 1) (setq line (1+ line)))) @@ -2150,11 +2278,11 @@ modified) original contents, they are first saved to their own file." (dest (gnus-agent-lib-file "local"))) (gnus-make-directory (gnus-agent-lib-file "")) - (let ((buffer-file-coding-system gnus-agent-file-coding-system)) + (let ((coding-system-for-write gnus-agent-file-coding-system) + (file-name-coding-system nnmail-pathname-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 + print-level print-length (standard-output (current-buffer))) (mapatoms (lambda (symbol) (cond ((not (boundp symbol)) @@ -2162,13 +2290,14 @@ modified) original contents, they are first saved to their own file." ((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"))))) + (when range + (prin1 symbol) + (princ " ") + (princ (car range)) + (princ " ") + (princ (cdr range)) + (princ "\n")))))) my-obarray)))))))) (defun gnus-agent-get-local (group &optional gmane method) @@ -2197,10 +2326,11 @@ modified) original contents, they are first saved to their own file." (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))))) + (not (eq max (cdr minmax)))) + min + max) (setcar minmax min) (setcdr minmax max) t) @@ -2220,7 +2350,7 @@ modified) original contents, they are first saved to their own file." (defun gnus-agent-batch-confirmation (msg) "Show error message and return t." - (gnus-message 1 msg) + (gnus-message 1 "%s" msg) t) ;;;###autoload @@ -2275,6 +2405,18 @@ modified) original contents, they are first saved to their own file." (gnus-run-hooks 'gnus-agent-fetched-hook) (gnus-message 6 "Finished fetching articles into the Gnus agent")))) +(defvar gnus-agent-short-article 500 + "Articles that have fewer lines than this are short.") + +(defvar gnus-agent-long-article 1000 + "Articles that have more lines than this are long.") + +(defvar gnus-agent-low-score 0 + "Articles that have a score lower than this have a low score.") + +(defvar gnus-agent-high-score 0 + "Articles that have a score higher than this have a high score.") + (defun gnus-agent-fetch-group-1 (group method) "Fetch GROUP." (let ((gnus-command-method method) @@ -2291,8 +2433,8 @@ modified) original contents, they are first saved to their own file." gnus-headers gnus-score - articles arts - category predicate info marks score-param + articles + predicate info marks ) (unless (gnus-check-group group) (error "Can't open server for %s" group)) @@ -2335,9 +2477,6 @@ modified) original contents, they are first saved to their own file." ;; timeout reason. If so, recreate it. (gnus-agent-create-buffer) - ;; Figure out how to select articles in this group - (setq category (gnus-group-category group)) - (setq predicate (gnus-get-predicate (gnus-agent-find-parameter group 'agent-predicate))) @@ -2423,9 +2562,11 @@ modified) original contents, they are first saved to their own file." (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) @@ -2459,7 +2600,9 @@ modified) original contents, they are first saved to their own file." (gnus-dribble-enter (concat "(gnus-group-set-info '" (gnus-prin1-to-string info) - ")")))))))))))) + ")") + (concat "^(gnus-group-set-info '(\"" + (regexp-quote group) "\"")))))))))))) ;;; ;;; Agent Category Mode @@ -2484,23 +2627,14 @@ General format specifiers can also be used. See Info node (defvar gnus-agent-predicate 'false "The selection predicate used when no other source is available.") -(defvar gnus-agent-short-article 100 - "Articles that have fewer lines than this are short.") - -(defvar gnus-agent-long-article 200 - "Articles that have more lines than this are long.") - -(defvar gnus-agent-low-score 0 - "Articles that have a score lower than this have a low score.") - -(defvar gnus-agent-high-score 0 - "Articles that have a score higher than this have a high score.") - ;;; Internal variables. (defvar gnus-category-buffer "*Agent Category*") +(defvar gnus-tmp-name) +(defvar gnus-tmp-groups) + (defvar gnus-category-line-format-alist `((?c gnus-tmp-name ?s) (?g gnus-tmp-groups ?d))) @@ -2552,7 +2686,7 @@ General format specifiers can also be used. See Info node (gnus-run-hooks 'gnus-category-menu-hook))) -(defun gnus-category-mode () +(define-derived-mode gnus-category-mode fundamental-mode "Category" "Major mode for listing and editing agent categories. All normal editing commands are switched off. @@ -2563,20 +2697,14 @@ For more in-depth information on this mode, read the manual The following commands are available: \\{gnus-category-mode-map}" - (interactive) (when (gnus-visual-p 'category-menu 'menu) (gnus-category-make-menu-bar)) - (kill-all-local-variables) (gnus-simplify-mode-line) - (setq major-mode 'gnus-category-mode) - (setq mode-name "Category") (gnus-set-default-directory) (setq mode-line-process nil) - (use-local-map gnus-category-mode-map) (buffer-disable-undo) (setq truncate-lines t) - (setq buffer-read-only t) - (gnus-run-hooks 'gnus-category-mode-hook)) + (setq buffer-read-only t)) (defalias 'gnus-category-position-point 'gnus-goto-colon) @@ -2600,8 +2728,7 @@ The following commands are available: (defun gnus-category-setup-buffer () (unless (get-buffer gnus-category-buffer) - (save-excursion - (set-buffer (gnus-get-buffer-create gnus-category-buffer)) + (with-current-buffer (gnus-get-buffer-create gnus-category-buffer) (gnus-category-mode)))) (defun gnus-category-prepare () @@ -2853,9 +2980,7 @@ The following commands are available: "Return the function implementing PREDICATE." (or (cdr (assoc predicate gnus-category-predicate-cache)) (let ((func (gnus-category-make-function predicate))) - (setq gnus-category-predicate-cache - (nconc gnus-category-predicate-cache - (list (cons predicate func)))) + (push (cons predicate func) gnus-category-predicate-cache) func))) (defun gnus-predicate-implies-unread (predicate) @@ -2927,6 +3052,9 @@ articles." (or (gnus-gethash group gnus-category-group-cache) (assq 'default gnus-category-alist))) +(defvar gnus-agent-expire-current-dirs) +(defvar gnus-agent-expire-stats) + (defun gnus-agent-expire-group (group &optional articles force) "Expire all old articles in GROUP. If you want to force expiring of certain articles, this function can @@ -2937,27 +3065,17 @@ The articles on which the expiration process runs are selected as follows: if ARTICLES is t, all articles. if ARTICLES is a list, just those articles. FORCE is equivalent to setting the expiration predicates to true." - (interactive - (list (let ((def (or (gnus-group-group-name) - gnus-newsgroup-name))) - (let ((select (read-string (if def - (concat "Group Name (" - def "): ") - "Group Name: ")))) - (if (and (equal "" select) - def) - def - select))))) + (interactive (list (gnus-agent-read-group))) (if (not group) (gnus-agent-expire articles group force) - (let ( ;; Bind gnus-agent-expire-stats to enable tracking of + (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 "."))) + "expire all articles in " group "? "))) (let ((gnus-command-method (gnus-find-method-for-group group)) (overview (gnus-get-buffer-create " *expire overview*")) orig) @@ -2975,26 +3093,26 @@ FORCE is equivalent to setting the expiration predicates to true." group overview (gnus-gethash-safe group orig) articles force)))) (kill-buffer overview)))) - (gnus-message 4 (gnus-agent-expire-done-message))))) + (gnus-message 4 "%s" (gnus-agent-expire-done-message))))) (defun gnus-agent-expire-group-1 (group overview active articles force) ;; Internal function - requires caller to have set ;; gnus-command-method, initialized overview buffer, and to have ;; provided a non-nil active - (let ((dir (gnus-agent-group-pathname group))) + (let ((dir (gnus-agent-group-pathname group)) + (file-name-coding-system nnmail-pathname-coding-system) + (decoded (gnus-agent-decoded-group-name group))) (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)))) + (push dir 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-message 5 "Expiry skipping over %s" decoded) + (gnus-message 5 "Expiring articles in %s" decoded) (gnus-agent-load-alist group) (let* ((bytes-freed 0) (size-files-deleted 0.0) @@ -3074,7 +3192,7 @@ FORCE is equivalent to setting the expiration predicates to true." ;; 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 + ;; 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 @@ -3084,7 +3202,7 @@ FORCE is equivalent to setting the expiration predicates to true." ;; 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 + ;; These statements are sorted by ascending precedence of the ;; keep_flag. (setq dlist (nconc dlist (mapcar (lambda (e) @@ -3111,10 +3229,10 @@ FORCE is equivalent to setting the expiration predicates to true." (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 + ;; ensures a numeric type), append the position ;; to the list (push (list (+ 0 (read (current-buffer))) nil nil - (set-marker (make-marker) p)) + p) dlist) (error (gnus-message 1 "gnus-agent-expire: read error \ @@ -3132,24 +3250,24 @@ line." (point) nov-file))) ;; 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)))))))) + (setq dlist + (sort dlist + (lambda (a b) + (cond ((< (nth 0 a) (nth 0 b)) + t) + ((> (nth 0 a) (nth 0 b)) + nil) + (t + ;; If two entries have the same article-number + ;; then sort by ascending keep_flag. + (let* ((kf-score '((special . 0) + (marked . 1) + (unread . 2))) + (a (or (cdr (assq (nth 2 a) kf-score)) + 3)) + (b (or (cdr (assq (nth 2 b) kf-score)) + 3))) + (<= a b))))))) (gnus-message 7 "gnus-agent-expire: Sorting entries... Done") (gnus-message 7 "gnus-agent-expire: Merging entries... ") (let ((dlist dlist)) @@ -3166,15 +3284,40 @@ line." (point) nov-file))) (setq first (cdr first) secnd (cdr secnd)) (setcar first (or (car first) - (car secnd))) ; NOV_entry_marker + (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 (catch 'sort-results + (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.") + (mapc (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)) + (tail-alist alist) + (position-offset 0) + ) + (while dlist (let ((new-completed (truncate (* 100.0 (/ (setq cnt (1+ cnt)) @@ -3194,7 +3337,7 @@ line." (point) nov-file))) (keep (gnus-agent-message 10 "gnus-agent-expire: %s:%d: Kept %s article%s." - group article-number keep (if fetch-date " and file" "")) + decoded article-number keep (if fetch-date " and file" "")) (when fetch-date (unless (file-exists-p (concat dir (number-to-string @@ -3202,7 +3345,7 @@ line." (point) nov-file))) (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))) + decoded (caar dlist))) (unless marker (gnus-message 1 "gnus-agent-expire detected a \ missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) @@ -3251,18 +3394,23 @@ missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) (when marker (push "NOV entry removed" actions) - (goto-char marker) + + (goto-char (if (markerp marker) + marker + (- marker position-offset))) (incf nov-entries-deleted) - (let ((from (point-at-bol)) - (to (progn (forward-line 1) (point)))) - (incf bytes-freed (- to from)) + (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 + ;; active range (That is, articles that precede the ;; first article in the new alist). (if (and gnus-agent-consider-all-articles (>= article-number (car active))) @@ -3274,19 +3422,19 @@ article alist" type) actions)) (when actions (gnus-agent-message 8 "gnus-agent-expire: %s:%d: %s" - group article-number + decoded article-number (mapconcat 'identity actions ", "))))) (t (gnus-agent-message 10 "gnus-agent-expire: %s:%d: Article kept as \ -expiration tests failed." group article-number) +expiration tests failed." decoded 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 + ;; Remove markers as I intend to reuse this buffer again. + (when (and marker + (markerp marker)) (set-marker marker nil)) (setq dlist (cdr dlist)))) @@ -3313,7 +3461,7 @@ expiration tests failed." group article-number) (gnus-summary-update-info)))) (when (boundp 'gnus-agent-expire-stats) - (let ((stats (symbol-value 'gnus-agent-expire-stats))) + (let ((stats gnus-agent-expire-stats)) (incf (nth 2 stats) bytes-freed) (incf (nth 1 stats) files-deleted) (incf (nth 0 stats) nov-entries-deleted))) @@ -3337,7 +3485,7 @@ FORCE is equivalent to setting the expiration predicates to true." (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.")) +articles in every agentized group? ")) (let ((methods (gnus-agent-covered-methods)) ;; Bind gnus-agent-expire-current-dirs to enable tracking ;; of agent directories. @@ -3368,12 +3516,12 @@ articles in every agentized group.")) expiring-group overview active articles force)))))))) (kill-buffer overview)) (gnus-agent-expire-unagentized-dirs) - (gnus-message 4 (gnus-agent-expire-done-message)))))) + (gnus-message 4 "%s" (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)) + (let* ((stats gnus-agent-expire-stats) (size (nth 2 stats)) (units '(B KB MB GB))) (while (and (> size 1024.0) @@ -3382,7 +3530,7 @@ articles in every agentized group.")) units (cdr units))) (format "Expiry recovered %d NOV entries, deleted %d files,\ - and freed %f %s." + and freed %.f %s." (nth 0 stats) (nth 1 stats) size (car units))) @@ -3392,15 +3540,10 @@ articles in every agentized group.")) (when (and gnus-agent-expire-unagentized-dirs (boundp 'gnus-agent-expire-current-dirs)) (let* ((keep (gnus-make-hashtable)) - ;; Formally bind gnus-agent-expire-current-dirs so that the - ;; compiler will not complain about free references. - (gnus-agent-expire-current-dirs - (symbol-value 'gnus-agent-expire-current-dirs)) - dir) + (file-name-coding-system nnmail-pathname-coding-system)) (gnus-sethash gnus-agent-directory t keep) - (while gnus-agent-expire-current-dirs - (setq dir (pop gnus-agent-expire-current-dirs)) + (dolist (dir gnus-agent-expire-current-dirs) (when (and (stringp dir) (file-directory-p dir)) (while (not (gnus-gethash dir keep)) @@ -3434,7 +3577,7 @@ articles in every agentized group.")) (setq r 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 + ;; it's not already in to-remove, add it to ;; to-remove. (if (and r (not (member r to-remove))) @@ -3447,12 +3590,14 @@ articles in every agentized group.")) (or gnus-expert-user (gnus-y-or-n-p "gnus-agent-expire has identified local directories that are\ - not currently required by any agentized group. Do you wish to consider\ + not currently required by any agentized group. Do you wish to consider\ deleting them?"))) (while to-remove (let ((dir (pop to-remove))) - (if (gnus-y-or-n-p (format "Delete %s? " dir)) + (if (or gnus-expert-user + (gnus-y-or-n-p (format "Delete %s? " dir))) (let* (delete-recursive + files f (delete-recursive (function (lambda (f-or-d) @@ -3461,12 +3606,13 @@ articles in every agentized group.")) (condition-case nil (delete-directory f-or-d) (file-error - (mapcar (lambda (f) - (or (member f '("." "..")) - (funcall delete-recursive - (nnheader-concat - f-or-d f)))) - (directory-files f-or-d)) + (setq files (directory-files f-or-d)) + (while files + (setq f (pop files)) + (or (member f '("." "..")) + (funcall delete-recursive + (nnheader-concat + f-or-d f)))) (delete-directory f-or-d))) (delete-file f-or-d))))))) (funcall delete-recursive dir)))))))))) @@ -3536,7 +3682,7 @@ has been fetched." (gnus-agent-append-to-list tail-uncached v1)) (setq arts (cdr arts)) (setq ref (cdr ref))) - (t ; reference article (v2) preceeds the list being filtered + (t ; reference article (v2) precedes the list being filtered (setq ref (cdr ref)))))) (while arts (gnus-agent-append-to-list tail-uncached (pop arts))) @@ -3548,11 +3694,20 @@ has been fetched." (save-excursion (gnus-agent-create-buffer) (let ((gnus-decode-encoded-word-function 'identity) + (gnus-decode-encoded-address-function 'identity) (file (gnus-agent-article-name ".overview" group)) - cached-articles uncached-articles) + uncached-articles + (file-name-coding-system nnmail-pathname-coding-system)) (gnus-make-directory (nnheader-translate-file-chars (file-name-directory file) t)) + (when fetch-old + (setq articles (gnus-uncompress-range + (cons (if (numberp fetch-old) + (max 1 (- (car articles) fetch-old)) + 1) + (car (last articles)))))) + ;; Populate temp buffer with known headers (when (file-exists-p file) (with-current-buffer gnus-agent-overview-buffer @@ -3569,7 +3724,7 @@ has been fetched." (erase-buffer) (cond ((not (eq 'nov (let (gnus-agent) ; Turn off agent (gnus-retrieve-headers - uncached-articles group fetch-old)))) + uncached-articles group)))) (nnvirtual-convert-headers)) ((eq 'nntp (car gnus-current-select-method)) ;; The author of gnus-get-newsgroup-headers-xover @@ -3589,12 +3744,7 @@ has been fetched." (set-buffer nntp-server-buffer) (let* ((fetched-articles (list nil)) (tail-fetched-articles fetched-articles) - (min (cond ((numberp fetch-old) - (max 1 (- (car articles) fetch-old))) - (fetch-old - 1) - (t - (car articles)))) + (min (car articles)) (max (car (last articles)))) ;; Get the list of articles that were fetched @@ -3643,7 +3793,7 @@ has been fetched." ;; 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)) + (gnus-agent-braid-nov uncached-articles file)) ;; Save the new set of known headers to FILE (set-buffer nntp-server-buffer) @@ -3669,8 +3819,7 @@ has been fetched." (not (numberp fetch-old))) t ; Don't remove anything. (nnheader-nov-delete-outside-range - (if fetch-old (max 1 (- (car articles) fetch-old)) - (car articles)) + (car articles) (car (last articles))) t) @@ -3684,7 +3833,8 @@ has been fetched." (numberp article)) (let* ((gnus-command-method (gnus-find-method-for-group group)) (file (gnus-agent-article-name (number-to-string article) group)) - (buffer-read-only nil)) + (buffer-read-only nil) + (file-name-coding-system nnmail-pathname-coding-system)) (when (and (file-exists-p file) (> (nth 7 (file-attributes file)) 0)) (erase-buffer) @@ -3693,6 +3843,20 @@ has been fetched." (insert-file-contents file)) t)))) +(defun gnus-agent-store-article (article group) + (let* ((gnus-command-method (gnus-find-method-for-group group)) + (file (gnus-agent-article-name (number-to-string article) group)) + (file-name-coding-system nnmail-pathname-coding-system) + (coding-system-for-write gnus-cache-coding-system)) + (when (not (file-exists-p file)) + (gnus-make-directory (file-name-directory file)) + (write-region (point-min) (point-max) file nil 'silent) + ;; Tell the Agent when the article was fetched, so that it can + ;; be expired later. + (gnus-agent-load-alist group) + (gnus-agent-save-alist group (list article) + (time-to-days (current-time)))))) + (defun gnus-agent-regenerate-group (group &optional reread) "Regenerate GROUP. If REREAD is t, all articles in the .overview are marked as unread. @@ -3701,16 +3865,7 @@ 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) - gnus-newsgroup-name))) - (let ((select (read-string (if def - (concat "Group Name (" - def "): ") - "Group Name: ")))) - (if (and (equal "" select) - def) - def - select))) + (list (gnus-agent-read-group) (catch 'mark (while (let (c (cursor-in-echo-area t) @@ -3728,18 +3883,20 @@ If REREAD is not nil, downloaded articles are marked as unread." (sit-for 1) t))))) (when group - (gnus-message 5 "Regenerating in %s" group) + (gnus-message 5 "Regenerating in %s" (gnus-agent-decoded-group-name 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 + (file-name-coding-system nnmail-pathname-coding-system) (downloaded (if (file-exists-p dir) - (sort (mapcar (lambda (name) (string-to-int name)) - (directory-files dir nil "^[0-9]+$" t)) + (sort (delq nil (mapcar (lambda (name) + (and (not (file-directory-p (nnheader-concat dir name))) + (string-to-number name))) + (directory-files dir nil "^[0-9]+$" t))) '>) (progn (gnus-make-directory dir) nil))) - dl nov-arts + nov-arts alist header regenerated) @@ -3767,7 +3924,7 @@ If REREAD is not nil, downloaded articles are marked as unread." (gnus-delete-line) (setq nov-arts (cdr nov-arts)) (gnus-message 4 "gnus-agent-regenerate-group: NOV\ -entry of article %s deleted." l1)) + entry of article %s deleted." l1)) ((not l2) nil) ((< l1 l2) @@ -3802,7 +3959,8 @@ entry of article %s deleted." l1)) (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 + (gnus-message 3 "Regenerating NOV %s %d..." + (gnus-agent-decoded-group-name group) (car downloaded)) (let ((file (concat dir (number-to-string (car downloaded))))) (mm-with-unibyte-buffer @@ -3842,8 +4000,8 @@ entry of article %s deleted." l1)) ;; 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 + ;; situation, the last article ID in the list implies that it, + ;; and every article ID preceding it, have been fetched from the ;; server. (if gnus-agent-consider-all-articles @@ -3885,12 +4043,11 @@ entry of article %s deleted." l1)) (and reread gnus-agent-article-alist) (not (equal alist gnus-agent-article-alist)))) -<<<<<<< TREE (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 @@ -3901,41 +4058,19 @@ entry of article %s deleted." l1)) (gnus-agent-possibly-alter-active group group-active))))) (when (and reread gnus-agent-article-alist) - (gnus-make-ascending-articles-unread + (gnus-agent-synchronize-group-flags group - (if (listp reread) - reread - (delq nil (mapcar (function (lambda (c) - (cond ((eq reread t) - (car c)) - ((cdr c) - (car c))))) - gnus-agent-article-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-make-ascending-articles-unread - group - (if (listp reread) - reread - (delq nil (mapcar (function (lambda (c) - (cond ((eq reread t) - (car c)) - ((cdr c) - (car c))))) - gnus-agent-article-alist)))) ->>>>>>> MERGE-SOURCE + (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))) @@ -3944,16 +4079,16 @@ entry of article %s deleted." l1)) regenerated))) ;;;###autoload -(defun gnus-agent-regenerate (&optional clean reread) +(defun gnus-agent-regenerate (&optional _clean reread) "Regenerate all agent covered files. -If CLEAN, obsolete (ignore)." - (interactive "P") +CLEAN is obsolete and ignored." + (interactive) (let (regenerated) (gnus-message 4 "Regenerating Gnus agent files...") (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)))) + (dolist (group (gnus-groups-from-server gnus-command-method)) + (setq regenerated (or (gnus-agent-regenerate-group group reread) + regenerated)))) (gnus-message 4 "Regenerating Gnus agent files...done") regenerated)) @@ -3986,17 +4121,7 @@ If CLEAN, obsolete (ignore)." (defun gnus-agent-group-covered-p (group) (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 +(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." @@ -4004,24 +4129,25 @@ agent has fetched." (gnus-agent-with-refreshed-group group ;; if null, gnus-agent-group-pathname will calc method. - (let* ((gnus-command-method 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)))) + (gnus-sethash path (make-list 3 0) + gnus-agent-total-fetched-hashtb))) + (file-name-coding-system nnmail-pathname-coding-system)) (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 + (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 0.0) + (let ((sum (- (nth 2 entry))) (info (directory-files-and-attributes path nil "^-?[0-9]+$" t)) file) (while (setq file (pop info)) @@ -4031,7 +4157,7 @@ agent has fetched." (setq gnus-agent-need-update-total-fetched-for t) (incf (nth 2 entry) delta))))) -(defun gnus-agent-update-view-total-fetched-for +(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 @@ -4040,14 +4166,15 @@ modified." (gnus-agent-with-refreshed-group group ;; if null, gnus-agent-group-pathname will calc method. - (let* ((gnus-command-method 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-sethash path (make-list 3 0) gnus-agent-total-fetched-hashtb))) - (size (or (nth 7 (file-attributes + (file-name-coding-system nnmail-pathname-coding-system) + (size (or (nth 7 (file-attributes (nnheader-concat - path (if agent-over + path (if agent-over ".overview" ".agentview")))) 0))) @@ -4056,22 +4183,22 @@ modified." (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)))))) + (unless (equal group "dummy.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