;;; gnus-agent.el --- unplugged support for Gnus
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
-;; 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 <larsi@gnus.org>
;; 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 <http://www.gnu.org/licenses/>.
;;; Commentary:
(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."
(defcustom gnus-agent-fetched-hook nil
"Hook run when finished fetching articles."
- :version "21.4"
+ :version "22.1"
:group 'gnus-agent
:type 'hook)
:group 'gnus-agent
:type 'function)
-(defcustom gnus-agent-synchronize-flags 'ask
+(defcustom gnus-agent-synchronize-flags nil
"Indicate if flags are synchronized when you plug in.
If this is `ask' the hook will query the user."
+ ;; 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)
groups with large active ranges may open slower and you may also want
to look into the agent expiry settings to block the expiration of
read articles as they would just be downloaded again."
- :version "21.4"
+ :version "22.1"
:type 'boolean
:group 'gnus-agent)
"Chunk size for `gnus-agent-fetch-session'.
The function will split its article fetches into chunks smaller than
this limit."
+ :version "22.1"
:group 'gnus-agent
:type 'integer)
to disable expiration in specific categories, topics, and groups. Of
course, you could change gnus-agent-enable-expiration to DISABLE then
enable expiration per categories, topics, and groups."
+ :version "22.1"
:group 'gnus-agent
:type '(radio (const :format "Enable " ENABLE)
(const :format "Disable " DISABLE)))
Have gnus-agent-expire scan the directories under
\(gnus-agent-directory) for groups that are no longer agentized.
When found, offer to remove them."
- :version "21.4"
+ :version "22.1"
: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'."
- :version "21.4"
+ :version "22.1"
:type '(repeat symbol)
:group 'gnus-agent)
"Whether and when outgoing mail should be queued by the agent.
When `always', always queue outgoing mail. When nil, never
queue. Otherwise, queue if and only if unplugged."
+ :version "22.1"
:group 'gnus-agent
:type '(radio (const :format "Always" always)
(const :format "Never" nil)
- (const :format "When plugged" t)))
+ (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."
+ :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)
(defvar gnus-agent-buffer-alist nil)
(defvar gnus-agent-article-alist nil
- "An assoc list identifying the articles whose headers have been fetched.
+ "An assoc list identifying the articles whose headers have been fetched.
If successfully fetched, these headers will be stored in the group's overview
file. The key of each assoc pair is the article ID, the value of each assoc
pair is a flag indicating whether the identified article has been downloaded
\(gnus-agent-fetch-articles sets the value to the day of the download).
NOTES:
-1) The last element of this list can not be expired as some
+1) The last element of this list can not be expired as some
routines (for example, get-agent-fetch-headers) use the last
value to track which articles have had their headers retrieved.
2) The function `gnus-agent-regenerate' may destructively modify the value.")
(defvar gnus-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
;;;
`(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)))))
(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
+ (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)
(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
(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 ()
(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)
(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' `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)
(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)
(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)
(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)
(erase-buffer)
(nnheader-insert-file-contents (gnus-agent-lib-file "flags"))
(cond ((null gnus-plugged)
- (gnus-message
- 1 "You must be plugged to synchronize flags with server %s"
+ (gnus-message
+ 1 "You must be plugged to synchronize flags with server %s"
(nth 1 gnus-command-method)))
((null (gnus-check-server gnus-command-method))
- (gnus-message
+ (gnus-message
1 "Couldn't open server %s" (nth 1 gnus-command-method)))
(t
(condition-case err
(delete-file (gnus-agent-lib-file "flags")))
(error
(let ((file (gnus-agent-lib-file "flags")))
- (write-file file)
+ (write-region (point-min) (point-max)
+ (gnus-agent-lib-file "flags") nil 'silent)
(error "Couldn't set flags from file %s due to %s"
file (error-message-string err)))))))
(kill-buffer nil))))
(defun gnus-agent-possibly-synchronize-flags-server (method)
"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)
(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))
(gnus-agent-save-group-info old-command-method old-real-group nil)
(gnus-agent-save-group-info new-command-method new-real-group old-active)
- (let ((old-local (gnus-agent-get-local old-group
+ (let ((old-local (gnus-agent-get-local old-group
old-real-group old-command-method)))
(gnus-agent-set-local old-group
nil nil
;;;###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)))))
- (gnus-delete-file path)
+ (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
+ (let ((local (gnus-agent-get-local group
real-group command-method)))
(gnus-agent-set-local group
nil nil
(unless (member named-server gnus-agent-covered-methods)
(error "Server not in the agent program"))
- (setq gnus-agent-covered-methods
+ (setq gnus-agent-covered-methods
(delete named-server gnus-agent-covered-methods)
gnus-agent-method-p-cache nil)
(defun gnus-agent-read-servers ()
"Read the alist of covered servers."
- (setq gnus-agent-covered-methods
+ (setq gnus-agent-covered-methods
(gnus-agent-read-file
(nnheader-concat gnus-agent-directory "lib/servers"))
gnus-agent-method-p-cache nil)
(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))))
;; 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)
- (setq headers (cdr headers)))
+ (setq headers (cdr headers)))
((cdar alist)
(setq alist (cdr alist))
(setq headers (cdr headers))
(t
(setq alist (cdr alist))
(setq headers (cdr headers))
-
+
;; This article isn't in the agent. Check to see
;; if it is in the cache. If it is, it's been
;; downloaded.
(when gnus-newsgroup-processable
(setq gnus-newsgroup-downloadable
(let* ((dl gnus-newsgroup-downloadable)
- (gnus-newsgroup-downloadable
- (sort (gnus-copy-sequence gnus-newsgroup-processable) '<))
- (fetched-articles (gnus-agent-summary-fetch-group)))
- ;; The preceeding call to (gnus-agent-summary-fetch-group)
- ;; updated gnus-newsgroup-downloadable to remove each
- ;; article successfully fetched.
+ (processable (sort (gnus-copy-sequence gnus-newsgroup-processable) '<))
+ (gnus-newsgroup-downloadable processable))
+ (gnus-agent-summary-fetch-group)
- ;; For each article that I processed, remove its
- ;; processable mark IF the article is no longer
- ;; downloadable (i.e. it's already downloaded)
- (dolist (article gnus-newsgroup-processable)
- (unless (memq article gnus-newsgroup-downloadable)
- (gnus-summary-remove-process-mark article)))
- (gnus-sorted-ndifference dl fetched-articles)))))
+ ;; For each article that I processed that is no longer
+ ;; undownloaded, remove its processable mark.
+
+ (mapc #'gnus-summary-remove-process-mark
+ (gnus-sorted-ndifference gnus-newsgroup-processable gnus-newsgroup-undownloaded))
+
+ ;; The preceeding call to (gnus-agent-summary-fetch-group)
+ ;; updated the temporary gnus-newsgroup-downloadable to
+ ;; remove each article successfully fetched. Now, I
+ ;; update the real gnus-newsgroup-downloadable to only
+ ;; include undownloaded articles.
+ (gnus-sorted-ndifference dl (gnus-sorted-ndifference processable gnus-newsgroup-undownloaded))))))
(defun gnus-agent-summary-fetch-group (&optional all)
"Fetch the downloadable articles in the group.
gnus-newsgroup-name articles)))))
(save-excursion
(dolist (article articles)
- (let ((was-marked-downloadable
+ (let ((was-marked-downloadable
(memq article gnus-newsgroup-downloadable)))
(cond (gnus-agent-mark-unread-after-downloaded
(setq gnus-newsgroup-downloadable
(defun gnus-agent-synchronize-group-flags (group actions server)
"Update a plugged group by performing the indicated actions."
(let* ((gnus-command-method (gnus-server-to-method server))
- (info (or (gnus-get-info group)
- (gnus-get-info (gnus-group-full-name
- group gnus-command-method)))))
+ (info
+ ;; This initializer is required as gnus-request-set-mark
+ ;; calls gnus-group-real-name to strip off the host name
+ ;; before calling the backend. Now that the backend is
+ ;; trying to call gnus-request-set-mark, I have to
+ ;; reconstruct the original group name.
+ (or (gnus-get-info group)
+ (gnus-get-info
+ (setq group (gnus-group-full-name
+ group gnus-command-method))))))
(gnus-request-set-mark group actions)
(when info
(let ((range (nth 0 action))
(what (nth 1 action))
(marks (nth 2 action)))
- (when (memq 'read marks)
- (gnus-info-set-read
- info
- (funcall (if (eq what 'add)
- 'gnus-range-add
- 'gnus-remove-from-range)
- (gnus-info-read info)
- range))
- (gnus-get-unread-articles-in-group
- info
- (gnus-active (gnus-info-group info)))))))
+ (dolist (mark marks)
+ (cond ((eq mark 'read)
+ (gnus-info-set-read
+ info
+ (funcall (if (eq what 'add)
+ 'gnus-range-add
+ 'gnus-remove-from-range)
+ (gnus-info-read info)
+ range))
+ (gnus-get-unread-articles-in-group
+ info
+ (gnus-active (gnus-info-group info))))
+ ((memq mark '(tick))
+ (let ((info-marks (assoc mark (gnus-info-marks info))))
+ (unless info-marks
+ (gnus-info-set-marks info (cons (setq info-marks (list mark)) (gnus-info-marks info))))
+ (setcdr info-marks (funcall (if (eq what 'add)
+ 'gnus-range-add
+ 'gnus-remove-from-range)
+ (cdr info-marks)
+ range))))))))
+
+ ;;Marks can be synchronized at any time by simply toggling from
+ ;;unplugged to plugged. If that is what is happening right now, make
+ ;;sure that the group buffer is up to date.
+ (when (gnus-buffer-live-p gnus-group-buffer)
+ (gnus-group-update-group group t)))
nil))
(defun gnus-agent-save-active (method)
(gnus-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))
;; file.
(let ((read (gnus-info-read info)))
- (gnus-info-set-read
- info
- (gnus-range-add
- read
- (list (cons (1+ agent-max)
+ (gnus-info-set-read
+ info
+ (gnus-range-add
+ read
+ (list (cons (1+ agent-max)
(1- active-min))))))
;; Lie about the agent's local range for this group to
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."
(setq group
(nnheader-translate-file-chars
(nnheader-replace-duplicate-chars-in-string
- (nnheader-replace-chars-in-string
- (gnus-group-real-name group)
+ (nnheader-replace-chars-in-string
+ (gnus-group-real-name (gnus-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 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)
(unless (and (eq article (caar alist))
(cdar alist))
;; Skip headers preceeding this article
- (while (> article
+ (while (> article
(setq header-number
(let* ((header (car headers)))
(if header
(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))
(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)
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))
(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)
(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))
(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)))))
(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))
(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)
(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))) "~"))))
(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)
(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
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
(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")
(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))
(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."
(setq prev (cdr prev)))
(setq gnus-agent-article-alist (cdr all))
- (gnus-agent-set-local group
- (caar gnus-agent-article-alist)
+ (gnus-agent-set-local group
+ (caar gnus-agent-article-alist)
(caar (last gnus-agent-article-alist)))
(gnus-make-directory (gnus-agent-article-name "" group))
(cond ((eq gnus-agent-article-alist-save-format 1)
(princ gnus-agent-article-alist (current-buffer)))
((eq gnus-agent-article-alist-save-format 2)
- (let ((compressed nil))
- (mapcar (lambda (pair)
- (let* ((article-id (car pair))
- (day-of-download (cdr pair))
- (comp-list (assq day-of-download compressed)))
- (if comp-list
- (setcdr comp-list
- (cons article-id (cdr comp-list)))
- (setq compressed
- (cons (list day-of-download article-id)
- compressed)))
- nil)) gnus-agent-article-alist)
- (mapcar (lambda (comp-list)
- (setcdr comp-list
- (gnus-compress-sequence
- (nreverse (cdr comp-list)))))
- compressed)
+ (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))
(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))
(defun gnus-agent-read-local (file)
"Load FILE and do a `read' there."
- (let ((my-obarray (gnus-make-hashtable (count-lines (point-min)
+ (let ((my-obarray (gnus-make-hashtable (count-lines (point-min)
(point-max))))
(line 1))
(with-temp-buffer
(while (not (eobp))
(condition-case err
- (let (group
+ (let (group
min
max
- (cur (current-buffer)))
+ (cur (current-buffer))
+ (obarray my-obarray))
(setq group (read cur)
min (read cur)
max (read cur))
;; 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))))
-
+
(set (intern "+dirty" my-obarray) nil)
(set (intern "+method" my-obarray) gnus-command-method)
my-obarray))
(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)
((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)
(setq minmax
(cons (caar alist)
(caar (last alist))))
- (gnus-agent-set-local group (car minmax) (cdr minmax)
+ (gnus-agent-set-local group (car minmax) (cdr minmax)
gmane gnus-command-method local))))
minmax))
(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)
(defun gnus-agent-batch-confirmation (msg)
"Show error message and return t."
- (gnus-message 1 msg)
+ (gnus-message 1 "%s" msg)
t)
;;;###autoload
(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)
(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
(buffer-disable-undo)
(setq truncate-lines t)
(setq buffer-read-only t)
- (gnus-run-hooks 'gnus-category-mode-hook))
+ (gnus-run-mode-hooks 'gnus-category-mode-hook))
(defalias 'gnus-category-position-point 'gnus-goto-colon)
(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 ()
It is okay to miss some cases, but there must be no false positives.
That is, if this predicate returns true, then indeed the predicate must
return only unread articles."
- (eq t (gnus-function-implies-unread-1
+ (eq t (gnus-function-implies-unread-1
(gnus-category-make-function-1 predicate))))
(defun gnus-function-implies-unread-1 (function)
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)
(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)
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)))
- (gnus-agent-with-refreshed-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
+ (set 'gnus-agent-expire-current-dirs
+ (cons dir
(symbol-value 'gnus-agent-expire-current-dirs))))
(if (and (not force)
- (eq 'DISABLE (gnus-agent-find-parameter group
+ (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)
;; 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
(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 \
(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))
(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
(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.")))
(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
(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))))
Setting GROUP will limit expiration to that group.
FORCE is equivalent to setting the expiration predicates to true."
(interactive)
-
+
(if group
(gnus-agent-expire-group group articles force)
(if (or (not (eq articles t))
(yes-or-no-p "Are you sure that you want to expire all \
-articles in every agentized group."))
+articles in every agentized group? "))
(let ((methods (gnus-agent-covered-methods))
;; Bind gnus-agent-expire-current-dirs to enable tracking
;; of agent directories.
gnus-command-method))
(let* ((active
(gnus-gethash-safe expiring-group orig)))
-
+
(when active
(save-excursion
(gnus-agent-expire-group-1
expiring-group overview active articles force))))))))
(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)
units (cdr units)))
(format "Expiry recovered %d NOV entries, deleted %d files,\
- and freed %f %s."
- (nth 0 stats)
- (nth 1 stats)
+ and freed %f %s."
+ (nth 0 stats)
+ (nth 1 stats)
size (car units)))
"Expiry...done"))
;; 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
(checker
(function
(lambda (d)
- "Given a directory, check it and its subdirectories for
- membership in the keep hash. If it isn't found, add
- it to to-remove."
+ "Given a directory, check it and its subdirectories for
+ membership in the keep hash. If it isn't found, add
+ it to to-remove."
(let ((files (directory-files d))
file)
(while (setq file (pop files))
nil)
((equal file "..") ; Ignore parent
nil)
- ((equal file ".overview")
+ ((equal file ".overview")
;; Directory must contain .overview to be
;; agent's cache of a group.
(let ((d (file-name-as-directory d))
d (directory-file-name d)))
;; if ANY ancestor was NOT in keep hash and
;; it it's already in to-remove, add it to
- ;; to-remove.
+ ;; to-remove.
(if (and r
(not (member r to-remove)))
(push r to-remove))))
(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)
(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))))))))))
(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))
(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
(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)
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)
(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
(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)
(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
(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
(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))))
+ (list (list
+ (if (listp reread)
+ reread
+ (delq nil (mapcar (function (lambda (c)
+ (cond ((eq reread t)
+ (car c))
+ ((cdr c)
+ (car c)))))
+ gnus-agent-article-alist)))
+ 'del '(read)))
+ gnus-command-method)
(when regenerated
- (gnus-agent-update-files-total-fetched-for group nil)))
+ (gnus-agent-update-files-total-fetched-for group nil)))
(gnus-message 5 "")
regenerated)))
(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."
(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))
(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
(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)))
(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
projects / gnus / blobdiff