X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-agent.el;h=5e73432a3c74c1eb603cc7b832171e01209db797;hp=39b9d61b43ecfe5e51d9e334a791e10ac024401d;hb=55c26cf1a9939dc7b28fcbab35f1d05d56d53242;hpb=fe70196e10cdd849981dbd014882fb20237d0740 diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index 39b9d61b4..5e73432a3 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -1,15 +1,14 @@ ;;; gnus-agent.el --- unplugged support for Gnus -;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007 Free Software Foundation, Inc. +;; Copyright (C) 1997-2012 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 @@ -17,9 +16,7 @@ ;; 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., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -39,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." @@ -188,7 +183,7 @@ 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'." @@ -207,8 +202,7 @@ queue. Otherwise, queue if and only if unplugged." (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) @@ -309,8 +303,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))))) @@ -448,7 +441,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) @@ -459,6 +452,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 () @@ -468,8 +468,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) @@ -512,8 +511,8 @@ 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)))) @@ -602,16 +601,13 @@ manipulated as follows: (propertize string 'local-map (make-mode-line-mouse-map mouse-button mouse-func) 'mouse-face - (cond ((and (featurep 'xemacs) - ;; XEmacs' `facep' only checks for a face - ;; object, not for a face name, so it's useless - ;; to check with `facep'. - (find-face 'modeline)) - 'modeline) - ((facep 'mode-line-highlight) ;; Emacs 22 - 'mode-line-highlight) - ((facep 'mode-line) ;; Emacs 21 - 'mode-line)) ) + (if (and (featurep 'xemacs) + ;; XEmacs' `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) @@ -626,8 +622,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) @@ -688,7 +683,6 @@ 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 @@ -698,7 +692,9 @@ minor mode in all Gnus buffers." ;; 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) @@ -733,7 +729,8 @@ Optional arg GROUP-NAME allows to specify another group." (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. @@ -804,23 +801,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) @@ -858,8 +856,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")) - (eq (gnus-server-status gnus-command-method) 'ok)) + (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) @@ -895,11 +892,13 @@ 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 @@ -916,7 +915,8 @@ supported." (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-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)) @@ -944,7 +944,8 @@ 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-agent-group-pathname group)))) + (file-name-coding-system nnmail-pathname-coding-system)) (gnus-delete-directory path) (let* ((real-group (gnus-group-real-name group))) @@ -1023,7 +1024,7 @@ supported." (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)))) @@ -1129,7 +1130,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) @@ -1194,7 +1195,7 @@ downloadable." (mapc #'gnus-summary-remove-process-mark (gnus-sorted-ndifference gnus-newsgroup-processable gnus-newsgroup-undownloaded)) - ;; The preceeding call to (gnus-agent-summary-fetch-group) + ;; 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 @@ -1309,7 +1310,8 @@ This can be added to `gnus-select-article-hook' or (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)) @@ -1366,7 +1368,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) @@ -1422,6 +1424,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." @@ -1433,26 +1447,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) @@ -1499,7 +1512,7 @@ downloaded into the agent." "Fetch ARTICLES from GROUP and put them into the Agent." (when articles (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) @@ -1507,14 +1520,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))) @@ -1541,9 +1554,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))) @@ -1556,13 +1569,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 id + (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)) @@ -1573,7 +1588,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) @@ -1585,8 +1601,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)) @@ -1642,22 +1657,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))))) @@ -1665,8 +1685,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)) @@ -1677,14 +1696,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) @@ -1695,7 +1714,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))) "~")))) @@ -1758,7 +1778,7 @@ and that there are no duplicates." (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))))))) + (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 @@ -1767,22 +1787,13 @@ 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 (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))) (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))) + (agentview (gnus-agent-article-name ".agentview" group)) + (file-name-coding-system nnmail-pathname-coding-system)) (if (file-exists-p overview) (delete-file overview)) @@ -1797,29 +1808,30 @@ the article files." (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 + "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) @@ -1851,10 +1863,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 @@ -1903,16 +1925,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 @@ -2070,18 +2092,20 @@ doesn't exist, to valid the overview buffer." ;; 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)))) + (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." @@ -2115,17 +2139,13 @@ doesn't exist, to valid the overview buffer." ((= 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) + (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 @@ -2133,12 +2153,13 @@ doesn't exist, to valid the overview buffer." (gnus-agent-save-alist gnus-agent-read-agentview))) alist)) ((end-of-file file-error) - ;; The agentview file is missing. + ;; 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-attributes (directory-files-and-attributes + (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 @@ -2177,23 +2198,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)) @@ -2202,23 +2221,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)) @@ -2277,10 +2304,10 @@ 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 (standard-output (current-buffer))) (mapatoms (lambda (symbol) @@ -2325,7 +2352,6 @@ 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)))) @@ -2350,7 +2376,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 @@ -2591,7 +2617,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 @@ -2616,10 +2644,10 @@ 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 +(defvar gnus-agent-short-article 500 "Articles that have fewer lines than this are short.") -(defvar gnus-agent-long-article 200 +(defvar gnus-agent-long-article 1000 "Articles that have more lines than this are long.") (defvar gnus-agent-low-score 0 @@ -2732,8 +2760,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 () @@ -3069,17 +3096,7 @@ 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) @@ -3107,14 +3124,16 @@ 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) @@ -3125,8 +3144,8 @@ FORCE is equivalent to setting the expiration predicates to true." (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) @@ -3216,7 +3235,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) @@ -3238,7 +3257,7 @@ FORCE is equivalent to setting the expiration predicates to true." (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 @@ -3306,16 +3325,17 @@ line." (point) nov-file))) ;; 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))))) + (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.") - (mapcar (lambda (entry) + (mapc (lambda (entry) (let ((pos (nth 3 entry))) (if pos (setf (nth 3 entry) @@ -3350,7 +3370,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 @@ -3358,7 +3378,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."))) @@ -3423,7 +3443,7 @@ missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) ;; 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))) @@ -3435,12 +3455,12 @@ 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))) ) @@ -3529,7 +3549,7 @@ 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) @@ -3543,7 +3563,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))) @@ -3557,7 +3577,8 @@ articles in every agentized group? ")) ;; compiler will not complain about free references. (gnus-agent-expire-current-dirs (symbol-value 'gnus-agent-expire-current-dirs)) - dir) + dir + (file-name-coding-system nnmail-pathname-coding-system)) (gnus-sethash gnus-agent-directory t keep) (while gnus-agent-expire-current-dirs @@ -3595,7 +3616,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 already in to-remove, add it to ;; to-remove. (if (and r (not (member r to-remove))) @@ -3612,8 +3633,10 @@ articles in every agentized group? ")) 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) @@ -3622,12 +3645,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)))))))))) @@ -3697,7 +3721,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))) @@ -3709,8 +3733,10 @@ 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) + cached-articles uncached-articles + (file-name-coding-system nnmail-pathname-coding-system)) (gnus-make-directory (nnheader-translate-file-chars (file-name-directory file) t)) @@ -3730,7 +3756,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 @@ -3845,7 +3871,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) @@ -3854,6 +3881,15 @@ 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)))) + (defun gnus-agent-regenerate-group (group &optional reread) "Regenerate GROUP. If REREAD is t, all articles in the .overview are marked as unread. @@ -3862,16 +3898,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) @@ -3889,12 +3916,13 @@ 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 (delq nil (mapcar (lambda (name) (and (not (file-directory-p (nnheader-concat dir name))) @@ -3965,7 +3993,8 @@ If REREAD is not nil, downloaded articles are marked as unread." (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 @@ -4005,8 +4034,8 @@ If REREAD is not nil, downloaded articles are marked as unread." ;; 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 @@ -4138,7 +4167,8 @@ agent has fetched." (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-agent-total-fetched-hashtb))) + (file-name-coding-system nnmail-pathname-coding-system)) (when (listp delta) (if delta (let ((sum 0.0) @@ -4175,6 +4205,7 @@ modified." (entry (or (gnus-gethash path 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) (size (or (nth 7 (file-attributes (nnheader-concat path (if agent-over @@ -4204,5 +4235,4 @@ modified." (provide 'gnus-agent) -;;; arch-tag: b0ba4afc-5229-4cee-ad25-9956daa4e91e ;;; gnus-agent.el ends here