X-Git-Url: https://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-agent.el;h=04bdb3be6267a8621dfc801f0d82403bdc0bff02;hp=66b10f57bef2635e81e78303ab52e91073b8bfc8;hb=ca3685c9e20ae1fe87c3147c6b6eb9b4d18f9ccb;hpb=a99c5e708dfb594addc414947e32b396fd986f4f diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index 66b10f57b..04bdb3be6 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -1,25 +1,23 @@ ;;; gnus-agent.el --- unplugged support for Gnus -;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, +;; 2006, 2007, 2008, 2009, 2010 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., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -39,10 +37,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 +184,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'." @@ -259,6 +255,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 ;;; @@ -299,8 +305,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))))) @@ -449,15 +454,12 @@ manipulated as follows: (defsubst gnus-agent-cat-make (name &optional default-agent-predicate) (list name `(agent-predicate . ,(or default-agent-predicate 'false)))) -;; 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-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. @@ -468,8 +470,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) @@ -601,7 +602,14 @@ manipulated as follows: (fboundp 'make-mode-line-mouse-map)) (propertize string 'local-map (make-mode-line-mouse-map mouse-button mouse-func) - 'mouse-face 'mode-line-highlight) + 'mouse-face + (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) @@ -616,8 +624,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) @@ -806,11 +813,11 @@ be a select method." (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) @@ -848,8 +855,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) @@ -885,11 +891,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 @@ -906,7 +914,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)) @@ -934,7 +943,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))) @@ -1013,7 +1023,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)))) @@ -1181,7 +1191,7 @@ downloadable." ;; For each article that I processed that is no longer ;; undownloaded, remove its processable mark. - (mapc #'gnus-summary-remove-process-mark + (mapc #'gnus-summary-remove-process-mark (gnus-sorted-ndifference gnus-newsgroup-processable gnus-newsgroup-undownloaded)) ;; The preceeding call to (gnus-agent-summary-fetch-group) @@ -1299,7 +1309,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)) @@ -1412,6 +1423,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." @@ -1423,26 +1446,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) @@ -1546,13 +1568,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)) @@ -1563,7 +1587,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) @@ -1575,8 +1600,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)) @@ -1632,22 +1656,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))))) @@ -1655,8 +1684,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)) @@ -1667,14 +1695,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) @@ -1685,7 +1713,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))) "~")))) @@ -1748,7 +1777,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 @@ -1757,22 +1786,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)) @@ -1787,29 +1807,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) @@ -1841,10 +1862,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 @@ -1897,12 +1928,11 @@ article numbers will be returned." 10 "gnus-agent-fetch-headers: undownloaded articles are '%s'" (gnus-compress-sequence articles t)) - (save-excursion - (set-buffer nntp-server-buffer) - + (with-current-buffer nntp-server-buffer (if articles (progn - (gnus-message 7 "Fetching headers for %s..." group) + (gnus-message 7 "Fetching headers for %s..." + (gnus-agent-decoded-group-name group)) ;; Fetch them. (gnus-make-directory (nnheader-translate-file-chars @@ -2049,29 +2079,31 @@ doesn't exist, to valid the overview buffer." ;; 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... + ;; 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)))) + (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." @@ -2105,17 +2137,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 @@ -2123,18 +2151,21 @@ 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. Perform a brute-force - ;; reconstruction of its contents. - (let* (alist - (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)) - (artnum (string-to-number (nth 0 fa))) - (days (time-to-days (nth 5 fa)))) - (push (cons artnum days) alist))) - alist))))) + ;; 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." @@ -2165,23 +2196,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)) @@ -2190,23 +2219,28 @@ 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)) + (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)) @@ -2265,10 +2299,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) @@ -2313,7 +2347,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)))) @@ -2338,7 +2371,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 @@ -2604,10 +2637,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 @@ -2720,8 +2753,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 () @@ -3057,17 +3089,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) @@ -3095,14 +3117,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) @@ -3113,8 +3137,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) @@ -3226,7 +3250,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 @@ -3294,16 +3318,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) @@ -3338,7 +3363,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 @@ -3346,7 +3371,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,12 +3448,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))) ) @@ -3517,7 +3542,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) @@ -3545,7 +3570,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 @@ -3596,12 +3622,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) @@ -3610,12 +3638,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,8 +3726,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)) @@ -3718,7 +3749,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 @@ -3833,7 +3864,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) @@ -3850,16 +3882,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) @@ -3877,14 +3900,15 @@ 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) + (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))) @@ -3953,7 +3977,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 @@ -4051,8 +4076,8 @@ If REREAD is not nil, downloaded articles are marked as unread." (gnus-agent-possibly-alter-active group group-active))))) (when (and reread gnus-agent-article-alist) - (gnus-agent-synchronize-group-flags - group + (gnus-agent-synchronize-group-flags + group (list (list (if (listp reread) reread @@ -4126,7 +4151,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) @@ -4163,6 +4189,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 @@ -4192,5 +4219,4 @@ modified." (provide 'gnus-agent) -;;; arch-tag: b0ba4afc-5229-4cee-ad25-9956daa4e91e ;;; gnus-agent.el ends here