;;; gnus-agent.el --- unplugged support for Gnus
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2012 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
: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)
(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)
(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)
`(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)))))
(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)
(let ((def (or (gnus-group-group-name) gnus-newsgroup-name)))
(when def
(setq def (gnus-group-decoded-name def)))
- (gnus-group-completing-read (if def
- (concat "Group Name (" def "): ")
- "Group Name: ")
- nil nil t nil nil def)))
+ (gnus-group-completing-read nil nil t nil nil def)))
;;; Fetching setup functions.
(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))))
(propertize string 'local-map
(make-mode-line-mouse-map mouse-button mouse-func)
'mouse-face
- (cond ((and (featurep 'xemacs)
- ;; XEmacs' `facep' only checks for a face
- ;; object, not for a face name, so it's useless
- ;; to check with `facep'.
- (find-face 'modeline))
- 'modeline)
- ((facep 'mode-line-highlight) ;; Emacs 22
- 'mode-line-highlight)
- ((facep 'mode-line) ;; Emacs 21
- 'mode-line)) )
+ (if (and (featurep 'xemacs)
+ ;; XEmacs' `facep' only checks for a face
+ ;; object, not for a face name, so it's useless
+ ;; to check with `facep'.
+ (find-face 'modeline))
+ 'modeline
+ 'mode-line-highlight))
string))
(defun gnus-agent-toggle-plugged (set-to)
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)
(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
(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)
;; 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)
"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)
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)))
(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))
(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
(while alist
(let ((entry (pop alist)))
(when (gnus-methods-equal-p gnus-command-method (gnus-info-method entry))
- (gnus-agent-flush-group (gnus-info-group entry)))))))
+ (gnus-agent-flush-group (gnus-info-group entry)))))))
(defun gnus-agent-flush-group (group)
"Flush the agent's index files such that the GROUP no longer
(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
(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)
- (file-name-coding-system nnmail-pathname-coding-system))
+ (let* ((gnus-agent-read-agentview group)
+ (file-name-coding-system nnmail-pathname-coding-system)
+ (agentview (gnus-agent-article-name ".agentview" group)))
(setq gnus-agent-article-alist
- (gnus-cache-file-contents
- (gnus-agent-article-name ".agentview" group)
- 'gnus-agent-file-loading-cache
- 'gnus-agent-read-agentview))))
+ (and (file-exists-p agentview)
+ (gnus-cache-file-contents
+ agentview
+ 'gnus-agent-file-loading-cache
+ 'gnus-agent-read-agentview)))))
(defun gnus-agent-read-agentview (file)
"Load FILE and do a `read' there."
(gnus-agent-save-alist gnus-agent-read-agentview)))
alist))
((end-of-file file-error)
- ;; The agentview file is missing.
+ ;; The agentview file is missing.
(condition-case nil
;; If the agent directory exists, attempt to perform a brute-force
;; reconstruction of its contents.
(let* (alist
(file-name-coding-system nnmail-pathname-coding-system)
- (file-attributes (directory-files-and-attributes
+ (file-attributes (directory-files-and-attributes
(gnus-agent-article-name ""
gnus-agent-read-agentview) nil "^[0-9]+$" t)))
(while file-attributes
(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))
(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))))
(defun gnus-agent-batch-confirmation (msg)
"Show error message and return t."
- (gnus-message 1 msg)
+ (gnus-message 1 "%s" msg)
t)
;;;###autoload
(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
+(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
(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 ()
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
;; 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
;; 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)))
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."
+ and freed %.f %s."
(nth 0 stats)
(nth 1 stats)
size (car units)))
(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)))
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
(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)))
(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
(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.
(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))
(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
(provide 'gnus-agent)
-;; arch-tag: b0ba4afc-5229-4cee-ad25-9956daa4e91e
;;; gnus-agent.el ends here
projects / gnus / blobdiff