X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-agent.el;h=60d6102f7c0d013d72c6fa0fe687987c95b8f9af;hp=fbd86f2e6f5eebbab2ec3fb10861e07152ad66b7;hb=d6d90fbbda04a990e100832c709d6c746d872aa3;hpb=94e654a528ca715abe35cfd19a190466d57f7524 diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index fbd86f2e6..60d6102f7 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -1,7 +1,6 @@ ;;; gnus-agent.el --- unplugged support for Gnus -;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1997-2012 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; This file is part of GNU Emacs. @@ -187,7 +186,7 @@ When found, offer to remove them." (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) @@ -203,8 +202,7 @@ queue. Otherwise, queue if and only if unplugged." (const :format "When unplugged" t))) (defcustom gnus-agent-prompt-send-queue nil - "If non-nil, `gnus-group-send-queue' will prompt if called when -unplugged." + "If non-nil, `gnus-group-send-queue' will prompt if called when unplugged." :version "22.1" :group 'gnus-agent :type 'boolean) @@ -244,7 +242,6 @@ NOTES: (defvar gnus-category-group-cache nil) (defvar gnus-agent-spam-hashtb nil) (defvar gnus-agent-file-name nil) -(defvar gnus-agent-send-mail-function nil) (defvar gnus-agent-file-coding-system 'raw-text) (defvar gnus-agent-file-loading-cache nil) (defvar gnus-agent-total-fetched-hashtb nil) @@ -357,23 +354,11 @@ manipulated as follows: (func LIST): Returns VALUE1 (setf (func LIST) NEW_VALUE1): Replaces VALUE1 with NEW_VALUE1." `(progn (defmacro ,name (category) - (list (quote cdr) (list (quote assq) - (quote (quote ,prop-name)) category))) - - (define-setf-method ,name (category) - (let* ((--category--temp-- (make-symbol "--category--")) - (--value--temp-- (make-symbol "--value--"))) - (list (list --category--temp--) ; temporary-variables - (list category) ; value-forms - (list --value--temp--) ; store-variables - (let* ((category --category--temp--) ; store-form - (value --value--temp--)) - (list (quote gnus-agent-cat-set-property) - category - (quote (quote ,prop-name)) - value)) - (list (quote ,name) --category--temp--) ; access-form - ))))) + (list 'cdr (list 'assq '',prop-name category))) + + (defsetf ,name (category) (value) + (list 'gnus-agent-cat-set-property + category '',prop-name value)))) ) (defmacro gnus-agent-cat-name (category) @@ -401,22 +386,10 @@ manipulated as follows: 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) @@ -443,7 +416,7 @@ manipulated as follows: (setf (gnus-agent-cat-groups old-category) (delete group (gnus-agent-cat-groups old-category)))))) - ;; Purge cache as preceeding loop invalidated it. + ;; Purge cache as preceding loop invalidated it. (setq gnus-category-group-cache nil)) (setcdr (or (assq 'agent-groups category) @@ -604,7 +577,7 @@ manipulated as follows: (make-mode-line-mouse-map mouse-button mouse-func) 'mouse-face (if (and (featurep 'xemacs) - ;; XEmacs' `facep' only checks for a face + ;; 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)) @@ -685,11 +658,7 @@ This will modify the `gnus-setup-news-hook', and minor mode in all Gnus buffers." (interactive) (gnus-open-agent) - (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 @@ -725,13 +694,14 @@ Optional arg GROUP-NAME allows to specify another group." (defun gnus-agent-send-mail () (if (or (not gnus-agent-queue-mail) (and gnus-plugged (not (eq gnus-agent-queue-mail 'always)))) - (funcall gnus-agent-send-mail-function) + (message-multi-smtp-send-mail) (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n")) (replace-match "\n") (gnus-agent-insert-meta-information 'mail) - (gnus-request-accept-article "nndraft:queue" nil t t))) + (gnus-request-accept-article "nndraft:queue" nil t t) + (gnus-group-refresh-group "nndraft:queue"))) (defun gnus-agent-insert-meta-information (type &optional method) "Insert meta-information into the message that says how it's to be posted. @@ -1131,7 +1101,7 @@ article's mark is toggled." (setq alist (cdr alist))) ((> a h) ;; Headers that are not in the alist should be - ;; fictious (see nnagent-retrieve-headers); they + ;; fictitious (see nnagent-retrieve-headers); they ;; imply that this article isn't in the agent. (gnus-agent-append-to-list tail-undownloaded h) (gnus-agent-append-to-list tail-unfetched h) @@ -1182,6 +1152,7 @@ downloadable." (gnus-summary-position-point))) (defun gnus-agent-summary-fetch-series () + "Fetch the process-marked articles into the Agent." (interactive) (when gnus-newsgroup-processable (setq gnus-newsgroup-downloadable @@ -1196,7 +1167,7 @@ downloadable." (mapc #'gnus-summary-remove-process-mark (gnus-sorted-ndifference gnus-newsgroup-processable gnus-newsgroup-undownloaded)) - ;; The preceeding call to (gnus-agent-summary-fetch-group) + ;; The preceding call to (gnus-agent-summary-fetch-group) ;; updated the temporary gnus-newsgroup-downloadable to ;; remove each article successfully fetched. Now, I ;; update the real gnus-newsgroup-downloadable to only @@ -1229,8 +1200,9 @@ Optional arg ALL, if non-nil, means to fetch all articles." (cond (gnus-agent-mark-unread-after-downloaded (setq gnus-newsgroup-downloadable (delq article gnus-newsgroup-downloadable)) - - (gnus-summary-mark-article article gnus-unread-mark)) + (when (and (not (member article gnus-newsgroup-dormant)) + (not (member article gnus-newsgroup-marked))) + (gnus-summary-mark-article article gnus-unread-mark))) (was-marked-downloadable (gnus-summary-set-agent-mark article t))) (when (gnus-summary-goto-subject article nil t) @@ -1303,12 +1275,18 @@ This can be added to `gnus-select-article-hook' or (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) (let ((nnheader-file-coding-system gnus-agent-file-coding-system)) @@ -1369,7 +1347,7 @@ downloaded into the agent." ;; disable the set read each time this server is opened. ;; NOTE: Opening this group will restore the valid local ;; range but it will also expand the local range to - ;; incompass the new active range. + ;; encompass the new active range. (gnus-agent-set-local group agent-min (1- active-min))))))) (defun gnus-agent-save-group-info (method group active) @@ -1513,7 +1491,7 @@ downloaded into the agent." "Fetch ARTICLES from GROUP and put them into the Agent." (when articles (gnus-agent-load-alist group) - (let* ((alist gnus-agent-article-alist) + (let* ((alist gnus-agent-article-alist) (headers (if (< (length articles) 2) nil gnus-newsgroup-headers)) (selected-sets (list nil)) (current-set-size 0) @@ -1521,14 +1499,14 @@ downloaded into the agent." header-number) ;; Check each article (while (setq article (pop articles)) - ;; Skip alist entries preceeding this article + ;; Skip alist entries preceding this article (while (> article (or (caar alist) (1+ article))) (setq alist (cdr alist))) ;; Prune off articles that we have already fetched. (unless (and (eq article (caar alist)) (cdar alist)) - ;; Skip headers preceeding this article + ;; Skip headers preceding this article (while (> article (setq header-number (let* ((header (car headers))) @@ -1555,9 +1533,9 @@ downloaded into the agent." ;; 65 char/line. If the line count ;; is missing, arbitrarily assume a ;; size of 1000 characters. - (max (* 65 (mail-header-lines - (car headers))) - 1000) + (max (* 65 (mail-header-lines + (car headers))) + 1000) char-size)) 0)))) (setcar selected-sets (nreverse (car selected-sets))) @@ -1926,14 +1904,15 @@ article numbers will be returned." (setq articles (gnus-list-range-intersection articles (list (cons low high))))))) - (gnus-message - 10 "gnus-agent-fetch-headers: undownloaded articles are '%s'" - (gnus-compress-sequence articles t)) + (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..." + (gnus-message 8 "Fetching headers for %s..." (gnus-agent-decoded-group-name group)) ;; Fetch them. @@ -2229,7 +2208,10 @@ doesn't exist, to valid the overview buffer." article counts for each of the method's subscribed groups." (let ((gnus-command-method (or method gnus-command-method))) (when (or (null gnus-agent-article-local-times) - (zerop 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") @@ -2614,7 +2596,9 @@ modified) original contents, they are first saved to their own file." (gnus-dribble-enter (concat "(gnus-group-set-info '" (gnus-prin1-to-string info) - ")")))))))))))) + ")") + (concat "^(gnus-group-set-info '(\"" + (regexp-quote group) "\"")))))))))))) ;;; ;;; Agent Category Mode @@ -3230,7 +3214,7 @@ FORCE is equivalent to setting the expiration predicates to true." ;; Convert the keep lists to elements that look like (article# ;; nil keep_flag nil) then append it to the expanded dlist - ;; These statements are sorted by ascending precidence of the + ;; These statements are sorted by ascending precedence of the ;; keep_flag. (setq dlist (nconc dlist (mapcar (lambda (e) @@ -3438,7 +3422,7 @@ missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) ;; If considering all articles is set, I can only ;; expire article IDs that are no longer in the - ;; active range (That is, articles that preceed the + ;; active range (That is, articles that precede the ;; first article in the new alist). (if (and gnus-agent-consider-all-articles (>= article-number (car active))) @@ -3558,7 +3542,7 @@ articles in every agentized group? ")) units (cdr units))) (format "Expiry recovered %d NOV entries, deleted %d files,\ - and freed %f %s." + and freed %.f %s." (nth 0 stats) (nth 1 stats) size (car units))) @@ -3611,7 +3595,7 @@ articles in every agentized group? ")) (setq r d d (directory-file-name d))) ;; if ANY ancestor was NOT in keep hash and - ;; it it's already in to-remove, add it to + ;; it's not already in to-remove, add it to ;; to-remove. (if (and r (not (member r to-remove))) @@ -3716,7 +3700,7 @@ has been fetched." (gnus-agent-append-to-list tail-uncached v1)) (setq arts (cdr arts)) (setq ref (cdr ref))) - (t ; reference article (v2) preceeds the list being filtered + (t ; reference article (v2) precedes the list being filtered (setq ref (cdr ref)))))) (while arts (gnus-agent-append-to-list tail-uncached (pop arts))) @@ -3735,6 +3719,13 @@ has been fetched." (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 @@ -3771,12 +3762,7 @@ has been fetched." (set-buffer nntp-server-buffer) (let* ((fetched-articles (list nil)) (tail-fetched-articles fetched-articles) - (min (cond ((numberp fetch-old) - (max 1 (- (car articles) fetch-old))) - (fetch-old - 1) - (t - (car articles)))) + (min (car articles)) (max (car (last articles)))) ;; Get the list of articles that were fetched @@ -3851,8 +3837,7 @@ has been fetched." (not (numberp fetch-old))) t ; Don't remove anything. (nnheader-nov-delete-outside-range - (if fetch-old (max 1 (- (car articles) fetch-old)) - (car articles)) + (car articles) (car (last articles))) t) @@ -3876,6 +3861,20 @@ has been fetched." (insert-file-contents file)) t)))) +(defun gnus-agent-store-article (article group) + (let* ((gnus-command-method (gnus-find-method-for-group group)) + (file (gnus-agent-article-name (number-to-string article) group)) + (file-name-coding-system nnmail-pathname-coding-system) + (coding-system-for-write gnus-cache-coding-system)) + (when (not (file-exists-p file)) + (gnus-make-directory (file-name-directory file)) + (write-region (point-min) (point-max) file nil 'silent) + ;; Tell the Agent when the article was fetched, so that it can + ;; be expired later. + (gnus-agent-load-alist group) + (gnus-agent-save-alist group (list article) + (time-to-days (current-time)))))) + (defun gnus-agent-regenerate-group (group &optional reread) "Regenerate GROUP. If REREAD is t, all articles in the .overview are marked as unread. @@ -4020,8 +4019,8 @@ If REREAD is not nil, downloaded articles are marked as unread." ;; gnus-agent-regenerate-group can remove the article ID of every ;; article (with the exception of the last ID in the list - it's ;; special) that no longer appears in the overview. In this - ;; situtation, the last article ID in the list implies that it, - ;; and every article ID preceeding it, have been fetched from the + ;; situation, the last article ID in the list implies that it, + ;; and every article ID preceding it, have been fetched from the ;; server. (if gnus-agent-consider-all-articles