X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-agent.el;h=3375b937de94758c918c5a9d76ba24bf83093300;hb=af028a6180a847dbc8a1049fbbf594c1a38f5642;hp=c71fdaf87a0a3132b186de530efbbfabea9b4124;hpb=e910338590586be432743047ab8d4ae38d6a2b08;p=gnus diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index c71fdaf87..3375b937d 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -27,6 +27,7 @@ (require 'gnus-cache) (require 'nnvirtual) (require 'gnus-sum) +(require 'gnus-score) (eval-when-compile (if (featurep 'xemacs) (require 'itimer) @@ -81,9 +82,19 @@ If nil, only read articles will be expired." (defcustom gnus-agent-confirmation-function 'y-or-n-p "Function to confirm when error happens." + :version "21.1" :group 'gnus-agent :type 'function) +(defcustom gnus-agent-synchronize-flags 'ask + "Indicate if flags are synchronized when you plug in. +If this is `ask' the hook will query the user." + :version "21.1" + :type '(choice (const :tag "Always" t) + (const :tag "Never" nil) + (const :tag "Ask" ask)) + :group 'gnus-agent) + ;;; Internal variables (defvar gnus-agent-history-buffers nil) @@ -161,7 +172,9 @@ If nil, only read articles will be expired." (defun gnus-agent-lib-file (file) "The full path of the Gnus agent library FILE." - (concat (gnus-agent-directory) "agent.lib/" file)) + (expand-file-name file + (file-name-as-directory + (expand-file-name "agent.lib" (gnus-agent-directory))))) ;;; Fetching setup functions. @@ -183,7 +196,7 @@ If nil, only read articles will be expired." (defmacro gnus-agent-with-fetch (&rest forms) "Do FORMS safely." `(unwind-protect - (progn + (let ((gnus-agent-fetching t)) (gnus-agent-start-fetch) ,@forms) (gnus-agent-stop-fetch))) @@ -230,7 +243,7 @@ If nil, only read articles will be expired." "Jc" gnus-enter-category-buffer "Jj" gnus-agent-toggle-plugged "Js" gnus-agent-fetch-session - "JY" gnus-agent-synchronize + "JY" gnus-agent-synchronize-flags "JS" gnus-group-send-drafts "Ja" gnus-agent-add-group "Jr" gnus-agent-remove-group) @@ -287,6 +300,7 @@ If nil, only read articles will be expired." (if plugged (progn (setq gnus-plugged plugged) + (gnus-agent-possibly-synchronize-flags) (gnus-run-hooks 'gnus-agent-plugged-hook) (setcar (cdr gnus-agent-mode-status) " Plugged")) (gnus-agent-close-connections) @@ -368,6 +382,43 @@ be a select method." (while (search-backward "\n" nil t) (replace-match "\\n" t t)))) +(defun gnus-agent-restore-gcc () + "Restore GCC field from saved header." + (save-excursion + (goto-char (point-min)) + (while (re-search-forward (concat gnus-agent-gcc-header ":") nil t) + (replace-match "Gcc:" 'fixedcase)))) + +(defun gnus-agent-any-covered-gcc () + (save-restriction + (message-narrow-to-headers) + (let* ((gcc (mail-fetch-field "gcc" nil t)) + (methods (and gcc + (mapcar 'gnus-inews-group-method + (message-unquote-tokens + (message-tokenize-header + gcc " ,"))))) + covered) + (while (and (not covered) methods) + (setq covered + (member (car methods) gnus-agent-covered-methods) + methods (cdr methods))) + covered))) + +(defun gnus-agent-possibly-save-gcc () + "Save GCC if Gnus is unplugged." + (when (and (not gnus-plugged) (gnus-agent-any-covered-gcc)) + (save-excursion + (goto-char (point-min)) + (let ((case-fold-search t)) + (while (re-search-forward "^gcc:" nil t) + (replace-match (concat gnus-agent-gcc-header ":") 'fixedcase)))))) + +(defun gnus-agent-possibly-do-gcc () + "Do GCC if Gnus is plugged." + (when (or gnus-plugged (not (gnus-agent-any-covered-gcc))) + (gnus-inews-do-gcc))) + ;;; ;;; Group mode commands ;;; @@ -422,27 +473,49 @@ be a select method." (setf (cadddr c) (delete group (cadddr c)))))) (gnus-category-write))) -(defun gnus-agent-synchronize () - "Synchronize local, unplugged, data with backend. -Currently sends flag setting requests, if any." +(defun gnus-agent-synchronize-flags () + "Synchronize unplugged flags with servers." + (interactive) + (save-excursion + (dolist (gnus-command-method gnus-agent-covered-methods) + (when (file-exists-p (gnus-agent-lib-file "flags")) + (gnus-agent-synchronize-flags-server gnus-command-method))))) + +(defun gnus-agent-possibly-synchronize-flags () + "Synchronize flags according to `gnus-agent-synchronize-flags'." (interactive) (save-excursion (dolist (gnus-command-method gnus-agent-covered-methods) (when (file-exists-p (gnus-agent-lib-file "flags")) - (set-buffer (get-buffer-create " *Gnus Agent flag synchronize*")) - (erase-buffer) - (nnheader-insert-file-contents (gnus-agent-lib-file "flags")) - (if (null (gnus-check-server gnus-command-method)) - (message "Couldn't open server %s" (nth 1 gnus-command-method)) - (while (not (eobp)) - (if (null (eval (read (current-buffer)))) - (progn (forward-line) - (kill-line -1)) - (write-file (gnus-agent-lib-file "flags")) - (error "Couldn't set flags from file %s" - (gnus-agent-lib-file "flags")))) - (write-file (gnus-agent-lib-file "flags"))) - (kill-buffer nil))))) + (gnus-agent-possibly-synchronize-flags-server gnus-command-method))))) + +(defun gnus-agent-synchronize-flags-server (method) + "Synchronize flags set when unplugged for server." + (let ((gnus-command-method method)) + (when (file-exists-p (gnus-agent-lib-file "flags")) + (set-buffer (get-buffer-create " *Gnus Agent flag synchronize*")) + (erase-buffer) + (nnheader-insert-file-contents (gnus-agent-lib-file "flags")) + (if (null (gnus-check-server gnus-command-method)) + (message "Couldn't open server %s" (nth 1 gnus-command-method)) + (while (not (eobp)) + (if (null (eval (read (current-buffer)))) + (progn (forward-line) + (kill-line -1)) + (write-file (gnus-agent-lib-file "flags")) + (error "Couldn't set flags from file %s" + (gnus-agent-lib-file "flags")))) + (delete-file (gnus-agent-lib-file "flags"))) + (kill-buffer nil)))) + +(defun gnus-agent-possibly-synchronize-flags-server (method) + "Synchronize flags for server according to `gnus-agent-synchronize-flags'." + (when (or (and gnus-agent-synchronize-flags + (not (eq gnus-agent-synchronize-flags 'ask))) + (and (eq gnus-agent-synchronize-flags 'ask) + (gnus-y-or-n-p (format "Synchronize flags on server `%s'? " + (cadr method))))) + (gnus-agent-synchronize-flags-server method))) ;;; ;;; Server mode commands @@ -864,29 +937,13 @@ the actual number of articles toggled is returned." (insert "\n")) (pop gnus-agent-group-alist)))) -(if (fboundp 'union) - (defalias 'gnus-agent-union 'union) - (defun gnus-agent-union (l1 l2) - "Set union of lists L1 and L2." - (cond ((null l1) l2) - ((null l2) l1) - ((equal l1 l2) l1) - (t - (or (>= (length l1) (length l2)) - (setq l1 (prog1 l2 (setq l2 l1)))) - (while l2 - (or (memq (car l2) l1) - (push (car l2) l1)) - (pop l2)) - l1)))) - (defun gnus-agent-fetch-headers (group &optional force) (let ((articles (gnus-list-of-unread-articles group)) (gnus-decode-encoded-word-function 'identity) (file (gnus-agent-article-name ".overview" group))) ;; Add article with marks to list of article headers we want to fetch. (dolist (arts (gnus-info-marks (gnus-get-info group))) - (setq articles (gnus-agent-union (gnus-uncompress-sequence (cdr arts)) + (setq articles (gnus-union (gnus-uncompress-sequence (cdr arts)) articles))) (setq articles (sort articles '<)) ;; Remove known articles. @@ -973,14 +1030,14 @@ the actual number of articles toggled is returned." (setq gnus-agent-article-alist (gnus-agent-read-file (if dir - (concat dir ".agentview") + (expand-file-name ".agentview" dir) (gnus-agent-article-name ".agentview" group))))) (defun gnus-agent-save-alist (group &optional articles state dir) "Save the article-state alist for GROUP." (let ((file-name-coding-system nnmail-pathname-coding-system)) (with-temp-file (if dir - (concat dir ".agentview") + (expand-file-name ".agentview" dir) (gnus-agent-article-name ".agentview" group)) (princ (setq gnus-agent-article-alist (nconc gnus-agent-article-alist @@ -990,8 +1047,10 @@ the actual number of articles toggled is returned." (insert "\n")))) (defun gnus-agent-article-name (article group) - (concat (gnus-agent-directory) (gnus-agent-group-path group) "/" - (if (stringp article) article (string-to-number article)))) + (expand-file-name (if (stringp article) article (string-to-number article)) + (file-name-as-directory + (expand-file-name (gnus-agent-group-path group) + (gnus-agent-directory))))) (defun gnus-agent-batch-confirmation (msg) "Show error message and return t." @@ -1031,7 +1090,11 @@ the actual number of articles toggled is returned." (error (unless (funcall gnus-agent-confirmation-function (format "Error (%s). Continue? " err)) - (error "Cannot fetch articles into the Gnus agent.")))) + (error "Cannot fetch articles into the Gnus agent."))) + (quit + (unless (funcall gnus-agent-confirmation-function + (format "Quit (%s). Continue? " err)) + (signal 'quit "Cannot fetch articles into the Gnus agent.")))) (pop methods)) (gnus-message 6 "Finished fetching articles into the Gnus agent")))) @@ -1054,7 +1117,7 @@ the actual number of articles toggled is returned." ;; Fetch headers. (when (and (or (gnus-active group) (gnus-activate-group group)) (setq articles (gnus-agent-fetch-headers group)) - (progn + (let ((nntp-server-buffer gnus-agent-overview-buffer)) ;; Parse them and see which articles we want to fetch. (setq gnus-newsgroup-dependencies (make-vector (length articles) 0)) @@ -1069,20 +1132,32 @@ the actual number of articles toggled is returned." (gnus-get-predicate (or (gnus-group-find-parameter group 'agent-predicate t) (cadr category)))) - (setq score-param - (or (gnus-group-get-parameter group 'agent-score) - (caddr category))) - (when score-param - (gnus-score-headers (list (list score-param)))) - (setq arts nil) - (while (setq gnus-headers (pop gnus-newsgroup-headers)) - (setq gnus-score - (or (cdr (assq (mail-header-number gnus-headers) - gnus-newsgroup-scored)) - gnus-summary-default-score)) - (when (funcall predicate) - (push (mail-header-number gnus-headers) - arts))) + (if (memq (caaddr predicate) '(gnus-agent-true gnus-agent-false)) + ;; Simple implementation + (setq arts + (and (eq (caaddr predicate) 'gnus-agent-true) articles)) + (setq arts nil) + (setq score-param + (or (gnus-group-get-parameter group 'agent-score t) + (caddr category))) + ;; Translate score-param into real one + (cond + ((not score-param)) + ((eq score-param 'file) + (setq score-param (gnus-all-score-files group))) + ((stringp (car score-param))) + (t + (setq score-param (list (list score-param))))) + (when score-param + (gnus-score-headers score-param)) + (while (setq gnus-headers (pop gnus-newsgroup-headers)) + (setq gnus-score + (or (cdr (assq (mail-header-number gnus-headers) + gnus-newsgroup-scored)) + gnus-summary-default-score)) + (when (funcall predicate) + (push (mail-header-number gnus-headers) + arts)))) ;; Fetch the articles. (when arts (gnus-agent-fetch-articles group arts))) @@ -1455,7 +1530,17 @@ The following commands are available: (goto-char (point-min)) (while (not (eobp)) (skip-chars-forward "^\t") - (if (> (read (current-buffer)) day) + (if (let ((fetch-date (read (current-buffer)))) + (if (numberp fetch-date) + (> fetch-date day) + ;; History file is corrupted. + (gnus-message + 5 + (format "File %s is corrupted!" + (gnus-agent-lib-file "history"))) + (sit-for 1) + ;; Ignore it + t)) ;; New article; we don't expire it. (forward-line 1) ;; Old article. Schedule it for possible nuking.