;;; gnus-agent.el --- unplugged support for Gnus
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2014 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., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, 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."
:type 'boolean
:group 'gnus-agent)
-(defcustom gnus-agent-auto-agentize-methods '(nntp nnimap)
+(defcustom gnus-agent-auto-agentize-methods nil
"Initially, all servers from these methods are agentized.
The user may remove or add servers using the Server buffer.
-See Info node `(gnus)Server Buffer'."
+See Info nodes `(gnus)Server Buffer', `(gnus)Agent Variables'."
:version "22.1"
:type '(repeat symbol)
:group 'gnus-agent)
:group 'gnus-agent
:type '(radio (const :format "Always" always)
(const :format "Never" nil)
- (const :format "When plugged" t)))
+ (const :format "When unplugged" t)))
(defcustom gnus-agent-prompt-send-queue nil
- "If non-nil, `gnus-group-send-queue' will prompt if called when
-unplugged."
+ "If non-nil, `gnus-group-send-queue' will prompt if called when unplugged."
:version "22.1"
:group 'gnus-agent
:type 'boolean)
+(defcustom gnus-agent-article-alist-save-format 1
+ "Indicates whether to use compression(2), versus no
+compression(1), when writing agentview files. The compressed
+files do save space but load times are 6-7 times higher. A group
+must be opened then closed for the agentview to be updated using
+the new format."
+ ;; Wouldn't symbols instead numbers be nicer? --rsteib
+ :version "22.1"
+ :group 'gnus-agent
+ :type '(radio (const :format "Compressed" 2)
+ (const :format "Uncompressed" 1)))
+
;;; Internal variables
(defvar gnus-agent-history-buffers nil)
(defvar gnus-category-group-cache nil)
(defvar gnus-agent-spam-hashtb nil)
(defvar gnus-agent-file-name nil)
-(defvar gnus-agent-send-mail-function nil)
(defvar gnus-agent-file-coding-system 'raw-text)
(defvar gnus-agent-file-loading-cache nil)
(defvar gnus-agent-total-fetched-hashtb nil)
(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)))))
(func LIST): Returns VALUE1
(setf (func LIST) NEW_VALUE1): Replaces VALUE1 with NEW_VALUE1."
`(progn (defmacro ,name (category)
- (list (quote cdr) (list (quote assq)
- (quote (quote ,prop-name)) category)))
-
- (define-setf-method ,name (category)
- (let* ((--category--temp-- (make-symbol "--category--"))
- (--value--temp-- (make-symbol "--value--")))
- (list (list --category--temp--) ; temporary-variables
- (list category) ; value-forms
- (list --value--temp--) ; store-variables
- (let* ((category --category--temp--) ; store-form
- (value --value--temp--))
- (list (quote gnus-agent-cat-set-property)
- category
- (quote (quote ,prop-name))
- value))
- (list (quote ,name) --category--temp--) ; access-form
- )))))
+ (list 'cdr (list 'assq '',prop-name category)))
+
+ (defsetf ,name (category) (value)
+ (list 'gnus-agent-cat-set-property
+ category '',prop-name value))))
)
(defmacro gnus-agent-cat-name (category)
gnus-agent-cat-enable-undownloaded-faces agent-enable-undownloaded-faces)
-;; This form is equivalent to defsetf except that it calls make-symbol
-;; whereas defsetf calls gensym (Using gensym creates a run-time
-;; dependency on the CL library).
-
-(eval-and-compile
- (define-setf-method gnus-agent-cat-groups (category)
- (let* ((--category--temp-- (make-symbol "--category--"))
- (--groups--temp-- (make-symbol "--groups--")))
- (list (list --category--temp--)
- (list category)
- (list --groups--temp--)
- (let* ((category --category--temp--)
- (groups --groups--temp--))
- (list (quote gnus-agent-set-cat-groups) category groups))
- (list (quote gnus-agent-cat-groups) --category--temp--))))
- )
+;; This form may expand to code that uses CL functions at run-time,
+;; but that's OK since those functions will only ever be called from
+;; something like `setf', so only when CL is loaded anyway.
+(defsetf gnus-agent-cat-groups gnus-agent-set-cat-groups)
(defun gnus-agent-set-cat-groups (category groups)
(unless (eq groups 'ignore)
(setf (gnus-agent-cat-groups old-category)
(delete group (gnus-agent-cat-groups
old-category))))))
- ;; Purge cache as preceeding loop invalidated it.
+ ;; Purge cache as preceding loop invalidated it.
(setq gnus-category-group-cache nil))
(setcdr (or (assq 'agent-groups category)
(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)
;; Set up the menu.
(when (gnus-visual-p 'agent-menu 'menu)
(funcall (intern (format "gnus-agent-%s-make-menu-bar" buffer))))
- (unless (assq 'gnus-agent-mode minor-mode-alist)
- (push gnus-agent-mode-status minor-mode-alist))
+ (unless (assq mode minor-mode-alist)
+ (push (cons mode (cdr gnus-agent-mode-status)) minor-mode-alist))
(unless (assq mode minor-mode-map-alist)
(push (cons mode (symbol-value (intern (format "gnus-agent-%s-mode-map"
buffer))))
minor-mode-map-alist))
- (when (eq major-mode 'gnus-group-mode)
+ (when (derived-mode-p 'gnus-group-mode)
(let ((init-plugged gnus-plugged)
(gnus-agent-go-online nil))
;; g-a-t-p does nothing when gnus-plugged isn't changed.
(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's `facep' only checks for a face
+ ;; object, not for a face name, so it's useless
+ ;; to check with `facep'.
+ (find-face 'modeline))
+ 'modeline
+ 'mode-line-highlight))
string))
(defun gnus-agent-toggle-plugged (set-to)
(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)
minor mode in all Gnus buffers."
(interactive)
(gnus-open-agent)
- (add-hook 'gnus-setup-news-hook 'gnus-agent-queue-setup)
- (unless gnus-agent-send-mail-function
- (setq gnus-agent-send-mail-function
- (or message-send-mail-real-function
- (function (lambda () (funcall message-send-mail-function))))
- message-send-mail-real-function 'gnus-agent-send-mail))
+ (setq message-send-mail-real-function 'gnus-agent-send-mail)
;; If the servers file doesn't exist, auto-agentize some servers and
;; save the servers file so this auto-agentizing isn't invoked
;; again.
- (unless (file-exists-p (nnheader-concat gnus-agent-directory "lib/servers"))
+ (when (and (not (file-exists-p (nnheader-concat
+ gnus-agent-directory "lib/servers")))
+ gnus-agent-auto-agentize-methods)
(gnus-message 3 "First time agent user, agentizing remote groups...")
(mapc
(lambda (server-or-method)
(defun gnus-agent-send-mail ()
(if (or (not gnus-agent-queue-mail)
(and gnus-plugged (not (eq gnus-agent-queue-mail 'always))))
- (funcall gnus-agent-send-mail-function)
+ (message-multi-smtp-send-mail)
(goto-char (point-min))
(re-search-forward
(concat "^" (regexp-quote mail-header-separator) "\n"))
(replace-match "\n")
(gnus-agent-insert-meta-information 'mail)
- (gnus-request-accept-article "nndraft:queue" nil t t)))
+ (gnus-request-accept-article "nndraft:queue" nil t t)
+ (gnus-group-refresh-group "nndraft:queue")))
(defun gnus-agent-insert-meta-information (type &optional method)
"Insert meta-information into the message that says how it's to be posted.
(setq group (or group gnus-newsgroup-name))
(unless group
(error "No group on the current line"))
-
- (gnus-agent-while-plugged
- (let ((gnus-command-method (gnus-find-method-for-group group)))
- (gnus-agent-with-fetch
- (gnus-agent-fetch-group-1 group gnus-command-method)
- (gnus-message 5 "Fetching %s...done" group)))))
+ (if (not (gnus-agent-group-covered-p group))
+ (message "%s isn't covered by the agent" group)
+ (gnus-agent-while-plugged
+ (let ((gnus-command-method (gnus-find-method-for-group group)))
+ (gnus-agent-with-fetch
+ (gnus-agent-fetch-group-1 group gnus-command-method)
+ (gnus-message 5 "Fetching %s...done" group))))))
(defun gnus-agent-add-group (category arg)
"Add the current group to an agent category."
(interactive
(list
(intern
- (completing-read
- "Add to category: "
- (mapcar (lambda (cat) (list (symbol-name (car cat))))
+ (gnus-completing-read
+ "Add to category"
+ (mapcar (lambda (cat) (symbol-name (car cat)))
gnus-category-alist)
- nil t))
+ t))
current-prefix-arg))
(let ((cat (assq category gnus-category-alist))
c groups)
(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)
(defun gnus-agent-possibly-synchronize-flags-server (method)
"Synchronize flags for server according to `gnus-agent-synchronize-flags'."
- (when (or (and gnus-agent-synchronize-flags
- (not (eq gnus-agent-synchronize-flags 'ask)))
- (and (eq gnus-agent-synchronize-flags 'ask)
- (gnus-y-or-n-p (format "Synchronize flags on server `%s'? "
- (cadr method)))))
+ (when (and (file-exists-p (gnus-agent-lib-file "flags"))
+ (or (and gnus-agent-synchronize-flags
+ (not (eq gnus-agent-synchronize-flags 'ask)))
+ (and (eq gnus-agent-synchronize-flags 'ask)
+ (gnus-y-or-n-p
+ (format "Synchronize flags on server `%s'? "
+ (cadr method))))))
(gnus-agent-synchronize-flags-server method)))
;;;###autoload
(defun gnus-agent-rename-group (old-group new-group)
- "Rename fully-qualified OLD-GROUP as NEW-GROUP. Always updates the agent, even when
-disabled, as the old agent files would corrupt gnus when the agent was
-next enabled. Depends upon the caller to determine whether group renaming is supported."
+ "Rename fully-qualified OLD-GROUP as NEW-GROUP.
+Always updates the agent, even when disabled, as the old agent
+files would corrupt gnus when the agent was next enabled.
+Depends upon the caller to determine whether group renaming is
+supported."
(let* ((old-command-method (gnus-find-method-for-group old-group))
(old-path (directory-file-name
- (let (gnus-command-method old-command-method)
+ (let ((gnus-command-method old-command-method))
(gnus-agent-group-pathname old-group))))
(new-command-method (gnus-find-method-for-group new-group))
(new-path (directory-file-name
- (let (gnus-command-method new-command-method)
- (gnus-agent-group-pathname new-group)))))
+ (let ((gnus-command-method new-command-method))
+ (gnus-agent-group-pathname new-group))))
+ (file-name-coding-system nnmail-pathname-coding-system))
(gnus-rename-file old-path new-path t)
(let* ((old-real-group (gnus-group-real-name old-group))
;;;###autoload
(defun gnus-agent-delete-group (group)
- "Delete fully-qualified GROUP. Always updates the agent, even when
-disabled, as the old agent files would corrupt gnus when the agent was
-next enabled. Depends upon the caller to determine whether group deletion is supported."
+ "Delete fully-qualified GROUP.
+Always updates the agent, even when disabled, as the old agent
+files would corrupt gnus when the agent was next enabled.
+Depends upon the caller to determine whether group deletion is
+supported."
(let* ((command-method (gnus-find-method-for-group group))
(path (directory-file-name
- (let (gnus-command-method command-method)
- (gnus-agent-group-pathname group)))))
+ (let ((gnus-command-method command-method))
+ (gnus-agent-group-pathname group))))
+ (file-name-coding-system nnmail-pathname-coding-system))
(gnus-delete-directory path)
(let* ((real-group (gnus-group-real-name group)))
(gnus-agent-save-group-info command-method real-group nil)
-
- (let ((local (gnus-agent-get-local group
- real-group command-method)))
- (gnus-agent-set-local group
- nil nil
- real-group command-method)))))
+ ;; FIXME: Does gnus-agent-get-local have any useful side-effect?
+ (gnus-agent-get-local group real-group command-method)
+ (gnus-agent-set-local group
+ nil nil
+ real-group command-method))))
;;;
;;; Server mode commands
(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))))
(setq alist (cdr alist)))
((> a h)
;; Headers that are not in the alist should be
- ;; fictious (see nnagent-retrieve-headers); they
+ ;; fictitious (see nnagent-retrieve-headers); they
;; imply that this article isn't in the agent.
(gnus-agent-append-to-list tail-undownloaded h)
(gnus-agent-append-to-list tail-unfetched h)
(gnus-summary-position-point)))
(defun gnus-agent-summary-fetch-series ()
+ "Fetch the process-marked articles into the Agent."
(interactive)
(when gnus-newsgroup-processable
(setq gnus-newsgroup-downloadable
;; 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)
+ ;; The preceding call to (gnus-agent-summary-fetch-group)
;; updated the temporary gnus-newsgroup-downloadable to
;; remove each article successfully fetched. Now, I
;; update the real gnus-newsgroup-downloadable to only
(cond (gnus-agent-mark-unread-after-downloaded
(setq gnus-newsgroup-downloadable
(delq article gnus-newsgroup-downloadable))
-
- (gnus-summary-mark-article article gnus-unread-mark))
+ (when (and (not (member article gnus-newsgroup-dormant))
+ (not (member article gnus-newsgroup-marked)))
+ (gnus-summary-mark-article article gnus-unread-mark)))
(was-marked-downloadable
(gnus-summary-set-agent-mark article t)))
(when (gnus-summary-goto-subject article nil t)
(gnus-group-update-group group t)))
nil))
-(defun gnus-agent-save-active (method)
+(defun gnus-agent-save-active (method &optional groups-p)
+ "Sync the agent's active file with the current buffer.
+Pass non-nil for GROUPS-P if the buffer starts out in groups format.
+Regardless, both the file and the buffer end up in active format
+if METHOD is agentized; otherwise the function is a no-op."
(when (gnus-agent-method-p method)
(let* ((gnus-command-method method)
(new (gnus-make-hashtable (count-lines (point-min) (point-max))))
(file (gnus-agent-lib-file "active")))
- (gnus-active-to-gnus-format nil new)
+ (if groups-p
+ (gnus-groups-to-gnus-format nil new)
+ (gnus-active-to-gnus-format nil new))
(gnus-agent-write-active file new)
(erase-buffer)
- (nnheader-insert-file-contents file))))
+ (let ((nnheader-file-coding-system gnus-agent-file-coding-system))
+ (nnheader-insert-file-contents file)))))
(defun gnus-agent-write-active (file new)
(gnus-make-directory (file-name-directory file))
;; disable the set read each time this server is opened.
;; NOTE: Opening this group will restore the valid local
;; range but it will also expand the local range to
- ;; incompass the new active range.
+ ;; encompass the new active range.
(gnus-agent-set-local group agent-min (1- active-min)))))))
(defun gnus-agent-save-group-info (method group active)
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."
(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)
(defun gnus-agent-fetch-articles (group articles)
"Fetch ARTICLES from GROUP and put them into the Agent."
- (when articles
+ (when (and articles
+ (gnus-online (gnus-group-method group)))
(gnus-agent-load-alist group)
- (let* ((alist gnus-agent-article-alist)
+ (let* ((alist gnus-agent-article-alist)
(headers (if (< (length articles) 2) nil gnus-newsgroup-headers))
(selected-sets (list nil))
(current-set-size 0)
header-number)
;; Check each article
(while (setq article (pop articles))
- ;; Skip alist entries preceeding this article
+ ;; Skip alist entries preceding this article
(while (> article (or (caar alist) (1+ article)))
(setq alist (cdr alist)))
;; Prune off articles that we have already fetched.
(unless (and (eq article (caar alist))
(cdar alist))
- ;; Skip headers preceeding this article
+ ;; Skip headers preceding this article
(while (> article
(setq header-number
(let* ((header (car headers)))
;; 65 char/line. If the line count
;; is missing, arbitrarily assume a
;; size of 1000 characters.
- (max (* 65 (mail-header-lines
- (car headers)))
- 1000)
+ (max (* 65 (mail-header-lines
+ (car headers)))
+ 1000)
char-size))
0))))
(setcar selected-sets (nreverse (car selected-sets)))
(dir (gnus-agent-group-pathname group))
(date (time-to-days (current-time)))
(case-fold-search t)
- pos crosses id)
+ pos crosses
+ (file-name-coding-system nnmail-pathname-coding-system))
(setcar selected-sets (nreverse (car selected-sets)))
(setq selected-sets (nreverse selected-sets))
(gnus-make-directory dir)
- (gnus-message 7 "Fetching articles for %s..." group)
+ (gnus-message 7 "Fetching articles for %s..."
+ (gnus-agent-decoded-group-name group))
(unwind-protect
(while (setq articles (pop selected-sets))
(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))
(goto-char (match-end 0)))
(gnus-agent-crosspost crosses (caar pos) date)))
(goto-char (point-min))
- (if (not (re-search-forward
- "^Message-ID: *<\\([^>\n]+\\)>" nil t))
- (setq id "No-Message-ID-in-article")
- (setq id (buffer-substring
- (match-beginning 1) (match-end 1))))
(let ((coding-system-for-write
gnus-agent-file-coding-system))
(write-region (point-min) (point-max)
(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-enable-expiration)
(agent-predicate . gnus-agent-predicate)))))))
-(defun gnus-agent-fetch-headers (group &optional force)
+(defun gnus-agent-fetch-headers (group)
"Fetch interesting headers into the agent. The group's overview
file will be updated to include the headers while a list of available
article numbers will be returned."
(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
(setq articles (gnus-list-range-intersection
articles (list (cons low high)))))))
- (gnus-message
- 10 "gnus-agent-fetch-headers: undownloaded articles are '%s'"
- (gnus-compress-sequence articles t))
-
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (when articles
+ (gnus-message
+ 10 "gnus-agent-fetch-headers: undownloaded articles are '%s'"
+ (gnus-compress-sequence articles t)))
+ (with-current-buffer nntp-server-buffer
(if articles
(progn
- (gnus-message 7 "Fetching headers for %s..." group)
+ (gnus-message 8 "Fetching headers for %s..."
+ (gnus-agent-decoded-group-name group))
;; Fetch them.
(gnus-make-directory (nnheader-translate-file-chars
;; NOTE: Call g-a-brand-nov even when the file does not
;; exist. As a minimum, it will validate the article
;; numbers already in the buffer.
- (gnus-agent-braid-nov group articles file)
+ (gnus-agent-braid-nov articles file)
(let ((coding-system-for-write
gnus-agent-file-coding-system))
(gnus-agent-check-overview-buffer)
(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")
(set-buffer nntp-server-buffer)
(insert-buffer-substring gnus-agent-overview-buffer b e))))
-(defun gnus-agent-braid-nov (group articles file)
+(defun gnus-agent-braid-nov (articles file)
"Merge agent overview data with given file.
Takes unvalidated headers for ARTICLES from
`gnus-agent-overview-buffer' and validated headers from the given
(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."
(let* ((file-name-coding-system nnmail-pathname-coding-system)
(prev (cons nil gnus-agent-article-alist))
(all prev)
- print-level print-length item article)
+ print-level print-length article)
(while (setq article (pop articles))
(while (and (cdr prev)
(< (caadr prev) article))
(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)
+ (not (gnus-methods-equal-p
+ gnus-command-method
+ (symbol-value (intern "+method" gnus-agent-article-local)))))
+ (setq gnus-agent-article-local
+ (gnus-cache-file-contents
+ (gnus-agent-lib-file "local")
+ 'gnus-agent-file-loading-local
+ 'gnus-agent-read-and-cache-local))
+ (when gnus-agent-article-local-times
+ (incf gnus-agent-article-local-times)))
+ gnus-agent-article-local))
(defun gnus-agent-read-and-cache-local (file)
"Load and read FILE then bind its contents to
gnus-agent-article-local. If that variable had `dirty' (also known as
modified) original contents, they are first saved to their own file."
-
(if (and gnus-agent-article-local
(symbol-value (intern "+dirty" gnus-agent-article-local)))
(gnus-agent-save-local))
(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))))
(dest (gnus-agent-lib-file "local")))
(gnus-make-directory (gnus-agent-lib-file ""))
- (let ((buffer-file-coding-system gnus-agent-file-coding-system))
+ (let ((coding-system-for-write gnus-agent-file-coding-system)
+ (file-name-coding-system nnmail-pathname-coding-system))
(with-temp-file dest
(let ((gnus-command-method (symbol-value (intern "+method" my-obarray)))
- (file-name-coding-system nnmail-pathname-coding-system)
- print-level print-length item article
+ print-level print-length
(standard-output (current-buffer)))
(mapatoms (lambda (symbol)
(cond ((not (boundp symbol))
((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)
(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
(gnus-run-hooks 'gnus-agent-fetched-hook)
(gnus-message 6 "Finished fetching articles into the Gnus agent"))))
+(defvar gnus-agent-short-article 500
+ "Articles that have fewer lines than this are short.")
+
+(defvar gnus-agent-long-article 1000
+ "Articles that have more lines than this are long.")
+
+(defvar gnus-agent-low-score 0
+ "Articles that have a score lower than this have a low score.")
+
+(defvar gnus-agent-high-score 0
+ "Articles that have a score higher than this have a high score.")
+
(defun gnus-agent-fetch-group-1 (group method)
"Fetch GROUP."
(let ((gnus-command-method method)
gnus-headers
gnus-score
- articles arts
- category predicate info marks score-param
+ articles
+ predicate info marks
)
(unless (gnus-check-group group)
(error "Can't open server for %s" group))
;; timeout reason. If so, recreate it.
(gnus-agent-create-buffer)
- ;; Figure out how to select articles in this group
- (setq category (gnus-group-category group))
-
(setq predicate
(gnus-get-predicate
(gnus-agent-find-parameter group 'agent-predicate)))
(gnus-dribble-enter
(concat "(gnus-group-set-info '"
(gnus-prin1-to-string info)
- ")"))))))))))))
+ ")")
+ (concat "^(gnus-group-set-info '(\""
+ (regexp-quote group) "\""))))))))))))
;;;
;;; Agent Category Mode
(defvar gnus-agent-predicate 'false
"The selection predicate used when no other source is available.")
-(defvar gnus-agent-short-article 100
- "Articles that have fewer lines than this are short.")
-
-(defvar gnus-agent-long-article 200
- "Articles that have more lines than this are long.")
-
-(defvar gnus-agent-low-score 0
- "Articles that have a score lower than this have a low score.")
-
-(defvar gnus-agent-high-score 0
- "Articles that have a score higher than this have a high score.")
-
;;; Internal variables.
(defvar gnus-category-buffer "*Agent Category*")
+(defvar gnus-tmp-name)
+(defvar gnus-tmp-groups)
+
(defvar gnus-category-line-format-alist
`((?c gnus-tmp-name ?s)
(?g gnus-tmp-groups ?d)))
(gnus-run-hooks 'gnus-category-menu-hook)))
-(defun gnus-category-mode ()
+(define-derived-mode gnus-category-mode fundamental-mode "Category"
"Major mode for listing and editing agent categories.
All normal editing commands are switched off.
The following commands are available:
\\{gnus-category-mode-map}"
- (interactive)
(when (gnus-visual-p 'category-menu 'menu)
(gnus-category-make-menu-bar))
- (kill-all-local-variables)
(gnus-simplify-mode-line)
- (setq major-mode 'gnus-category-mode)
- (setq mode-name "Category")
(gnus-set-default-directory)
(setq mode-line-process nil)
- (use-local-map gnus-category-mode-map)
(buffer-disable-undo)
(setq truncate-lines t)
- (setq buffer-read-only t)
- (gnus-run-mode-hooks 'gnus-category-mode-hook))
+ (setq buffer-read-only t))
(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 ()
"Return the function implementing PREDICATE."
(or (cdr (assoc predicate gnus-category-predicate-cache))
(let ((func (gnus-category-make-function predicate)))
- (setq gnus-category-predicate-cache
- (nconc gnus-category-predicate-cache
- (list (cons predicate func))))
+ (push (cons predicate func) gnus-category-predicate-cache)
func)))
(defun gnus-predicate-implies-unread (predicate)
(or (gnus-gethash group gnus-category-group-cache)
(assq 'default gnus-category-alist)))
+(defvar gnus-agent-expire-current-dirs)
+(defvar gnus-agent-expire-stats)
+
(defun gnus-agent-expire-group (group &optional articles force)
"Expire all old articles in GROUP.
If you want to force expiring of certain articles, this function can
if ARTICLES is t, all articles.
if ARTICLES is a list, just those articles.
FORCE is equivalent to setting the expiration predicates to true."
- (interactive
- (list (let ((def (or (gnus-group-group-name)
- gnus-newsgroup-name)))
- (let ((select (read-string (if def
- (concat "Group Name ("
- def "): ")
- "Group Name: "))))
- (if (and (equal "" select)
- def)
- def
- select)))))
+ (interactive (list (gnus-agent-read-group)))
(if (not group)
(gnus-agent-expire articles group force)
- (let ( ;; Bind gnus-agent-expire-stats to enable tracking of
+ (let (;; Bind gnus-agent-expire-stats to enable tracking of
;; expiration statistics of this single group
(gnus-agent-expire-stats (list 0 0 0.0)))
(if (or (not (eq articles t))
(yes-or-no-p
(concat "Are you sure that you want to "
- "expire all articles in " group ".")))
+ "expire all articles in " group "? ")))
(let ((gnus-command-method (gnus-find-method-for-group group))
(overview (gnus-get-buffer-create " *expire overview*"))
orig)
group overview (gnus-gethash-safe group orig)
articles force))))
(kill-buffer overview))))
- (gnus-message 4 (gnus-agent-expire-done-message)))))
+ (gnus-message 4 "%s" (gnus-agent-expire-done-message)))))
(defun gnus-agent-expire-group-1 (group overview active articles force)
;; Internal function - requires caller to have set
;; gnus-command-method, initialized overview buffer, and to have
;; provided a non-nil active
- (let ((dir (gnus-agent-group-pathname group)))
+ (let ((dir (gnus-agent-group-pathname group))
+ (file-name-coding-system nnmail-pathname-coding-system)
+ (decoded (gnus-agent-decoded-group-name group)))
(gnus-agent-with-refreshed-group
group
(when (boundp 'gnus-agent-expire-current-dirs)
- (set 'gnus-agent-expire-current-dirs
- (cons dir
- (symbol-value 'gnus-agent-expire-current-dirs))))
+ (push dir gnus-agent-expire-current-dirs))
(if (and (not force)
(eq 'DISABLE (gnus-agent-find-parameter group
'agent-enable-expiration)))
- (gnus-message 5 "Expiry skipping over %s" group)
- (gnus-message 5 "Expiring articles in %s" group)
+ (gnus-message 5 "Expiry skipping over %s" decoded)
+ (gnus-message 5 "Expiring articles in %s" decoded)
(gnus-agent-load-alist group)
(let* ((bytes-freed 0)
(size-files-deleted 0.0)
;; Convert the keep lists to elements that look like (article#
;; nil keep_flag nil) then append it to the expanded dlist
- ;; These statements are sorted by ascending precidence of the
+ ;; These statements are sorted by ascending precedence of the
;; keep_flag.
(setq dlist (nconc dlist
(mapcar (lambda (e)
(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
;; only problem is that much of it is spread across multiple
;; entries. Sort then MERGE!!
(gnus-message 7 "gnus-agent-expire: Sorting entries... ")
- ;; If two entries have the same article-number then sort by
- ;; ascending keep_flag.
- (let ((special 0)
- (marked 1)
- (unread 2))
- (setq dlist
- (sort dlist
- (lambda (a b)
- (cond ((< (nth 0 a) (nth 0 b))
- t)
- ((> (nth 0 a) (nth 0 b))
- nil)
- (t
- (let ((a (or (symbol-value (nth 2 a))
- 3))
- (b (or (symbol-value (nth 2 b))
- 3)))
- (<= a b))))))))
+ (setq dlist
+ (sort dlist
+ (lambda (a b)
+ (cond ((< (nth 0 a) (nth 0 b))
+ t)
+ ((> (nth 0 a) (nth 0 b))
+ nil)
+ (t
+ ;; If two entries have the same article-number
+ ;; then sort by ascending keep_flag.
+ (let* ((kf-score '((special . 0)
+ (marked . 1)
+ (unread . 2)))
+ (a (or (cdr (assq (nth 2 a) kf-score))
+ 3))
+ (b (or (cdr (assq (nth 2 b) kf-score))
+ 3)))
+ (<= a b)))))))
(gnus-message 7 "gnus-agent-expire: Sorting entries... Done")
(gnus-message 7 "gnus-agent-expire: Merging entries... ")
(let ((dlist dlist))
;; 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)
(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.")))
;; If considering all articles is set, I can only
;; expire article IDs that are no longer in the
- ;; active range (That is, articles that preceed the
+ ;; active range (That is, articles that precede the
;; first article in the new alist).
(if (and gnus-agent-consider-all-articles
(>= article-number (car active)))
(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)))
)
(gnus-summary-update-info))))
(when (boundp 'gnus-agent-expire-stats)
- (let ((stats (symbol-value 'gnus-agent-expire-stats)))
+ (let ((stats gnus-agent-expire-stats))
(incf (nth 2 stats) bytes-freed)
(incf (nth 1 stats) files-deleted)
(incf (nth 0 stats) nov-entries-deleted)))
(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.
expiring-group overview active articles force))))))))
(kill-buffer overview))
(gnus-agent-expire-unagentized-dirs)
- (gnus-message 4 (gnus-agent-expire-done-message))))))
+ (gnus-message 4 "%s" (gnus-agent-expire-done-message))))))
(defun gnus-agent-expire-done-message ()
(if (and (> gnus-verbose 4)
(boundp 'gnus-agent-expire-stats))
- (let* ((stats (symbol-value 'gnus-agent-expire-stats))
+ (let* ((stats gnus-agent-expire-stats)
(size (nth 2 stats))
(units '(B KB MB GB)))
(while (and (> size 1024.0)
units (cdr units)))
(format "Expiry recovered %d NOV entries, deleted %d files,\
- and freed %f %s."
+ and freed %.f %s."
(nth 0 stats)
(nth 1 stats)
size (car units)))
(when (and gnus-agent-expire-unagentized-dirs
(boundp 'gnus-agent-expire-current-dirs))
(let* ((keep (gnus-make-hashtable))
- ;; Formally bind gnus-agent-expire-current-dirs so that the
- ;; compiler will not complain about free references.
- (gnus-agent-expire-current-dirs
- (symbol-value 'gnus-agent-expire-current-dirs))
- dir)
+ (file-name-coding-system nnmail-pathname-coding-system))
(gnus-sethash gnus-agent-directory t keep)
- (while gnus-agent-expire-current-dirs
- (setq dir (pop gnus-agent-expire-current-dirs))
+ (dolist (dir gnus-agent-expire-current-dirs)
(when (and (stringp dir)
(file-directory-p dir))
(while (not (gnus-gethash dir keep))
(setq r d
d (directory-file-name d)))
;; if ANY ancestor was NOT in keep hash and
- ;; it it's already in to-remove, add it to
+ ;; it's not already in to-remove, add it to
;; to-remove.
(if (and r
(not (member r to-remove)))
(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))))))))))
(gnus-agent-append-to-list tail-uncached v1))
(setq arts (cdr arts))
(setq ref (cdr ref)))
- (t ; reference article (v2) preceeds the list being filtered
+ (t ; reference article (v2) precedes the list being filtered
(setq ref (cdr ref))))))
(while arts
(gnus-agent-append-to-list tail-uncached (pop arts)))
(save-excursion
(gnus-agent-create-buffer)
(let ((gnus-decode-encoded-word-function 'identity)
+ (gnus-decode-encoded-address-function 'identity)
(file (gnus-agent-article-name ".overview" group))
- cached-articles uncached-articles)
+ uncached-articles
+ (file-name-coding-system nnmail-pathname-coding-system))
(gnus-make-directory (nnheader-translate-file-chars
(file-name-directory file) t))
+ (when fetch-old
+ (setq articles (gnus-uncompress-range
+ (cons (if (numberp fetch-old)
+ (max 1 (- (car articles) fetch-old))
+ 1)
+ (car (last articles))))))
+
;; Populate temp buffer with known headers
(when (file-exists-p file)
(with-current-buffer gnus-agent-overview-buffer
(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
(set-buffer nntp-server-buffer)
(let* ((fetched-articles (list nil))
(tail-fetched-articles fetched-articles)
- (min (cond ((numberp fetch-old)
- (max 1 (- (car articles) fetch-old)))
- (fetch-old
- 1)
- (t
- (car articles))))
+ (min (car articles))
(max (car (last articles))))
;; Get the list of articles that were fetched
;; Merge the temp buffer with the known headers (found on
;; disk in FILE) into the nntp-server-buffer
(when uncached-articles
- (gnus-agent-braid-nov group uncached-articles file))
+ (gnus-agent-braid-nov uncached-articles file))
;; Save the new set of known headers to FILE
(set-buffer nntp-server-buffer)
(not (numberp fetch-old)))
t ; Don't remove anything.
(nnheader-nov-delete-outside-range
- (if fetch-old (max 1 (- (car articles) fetch-old))
- (car articles))
+ (car articles)
(car (last articles)))
t)
(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)
(insert-file-contents file))
t))))
+(defun gnus-agent-store-article (article group)
+ (let* ((gnus-command-method (gnus-find-method-for-group group))
+ (file (gnus-agent-article-name (number-to-string article) group))
+ (file-name-coding-system nnmail-pathname-coding-system)
+ (coding-system-for-write gnus-cache-coding-system))
+ (when (not (file-exists-p file))
+ (gnus-make-directory (file-name-directory file))
+ (write-region (point-min) (point-max) file nil 'silent)
+ ;; Tell the Agent when the article was fetched, so that it can
+ ;; be expired later.
+ (gnus-agent-load-alist group)
+ (gnus-agent-save-alist group (list article)
+ (time-to-days (current-time))))))
+
(defun gnus-agent-regenerate-group (group &optional reread)
"Regenerate GROUP.
If REREAD is t, all articles in the .overview are marked as unread.
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-number name))
- (directory-files dir nil "^[0-9]+$" t))
+ (sort (delq nil (mapcar (lambda (name)
+ (and (not (file-directory-p (nnheader-concat dir name)))
+ (string-to-number name)))
+ (directory-files dir nil "^[0-9]+$" t)))
'>)
(progn (gnus-make-directory dir) nil)))
- dl nov-arts
+ nov-arts
alist header
regenerated)
(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
;; gnus-agent-regenerate-group can remove the article ID of every
;; article (with the exception of the last ID in the list - it's
;; special) that no longer appears in the overview. In this
- ;; situtation, the last article ID in the list implies that it,
- ;; and every article ID preceeding it, have been fetched from the
+ ;; situation, the last article ID in the list implies that it,
+ ;; and every article ID preceding it, have been fetched from the
;; server.
(if gnus-agent-consider-all-articles
(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
regenerated)))
;;;###autoload
-(defun gnus-agent-regenerate (&optional clean reread)
+(defun gnus-agent-regenerate (&optional _clean reread)
"Regenerate all agent covered files.
-If CLEAN, obsolete (ignore)."
- (interactive "P")
+CLEAN is obsolete and ignored."
+ (interactive)
(let (regenerated)
(gnus-message 4 "Regenerating Gnus agent files...")
(dolist (gnus-command-method (gnus-agent-covered-methods))
- (dolist (group (gnus-groups-from-server gnus-command-method))
- (setq regenerated (or (gnus-agent-regenerate-group group reread)
- regenerated))))
+ (dolist (group (gnus-groups-from-server gnus-command-method))
+ (setq regenerated (or (gnus-agent-regenerate-group group reread)
+ regenerated))))
(gnus-message 4 "Regenerating Gnus agent files...done")
regenerated))
(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
(group delta &optional method path)
"Update, or set, the total disk space used by the articles that the
(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)
(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
(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