X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-agent.el;h=66a91691a8c7469f0f3fd48e9ea897a78d5fae06;hb=277cfbcdf4d715e60e84f17f3f1c70c55d26b47a;hp=9809bba955ac7d627b0750f559b56c8e4bef15cc;hpb=ae7e02f827410c9c9419bff833811ac51b7c4ab6;p=gnus diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index 9809bba95..66a91691a 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -27,9 +27,12 @@ (require 'gnus-cache) (require 'nnvirtual) (require 'gnus-sum) +(require 'gnus-score) (eval-when-compile - (require 'cl) - (require 'gnus-score)) + (if (featurep 'xemacs) + (require 'itimer) + (require 'timer)) + (require 'cl)) (defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/") "Where the Gnus agent will store its files." @@ -67,21 +70,43 @@ If nil, only read articles will be expired." :group 'gnus-agent :type 'hook) +;; Extracted from gnus-xmas-redefine in order to preserve user settings +(when (featurep 'xemacs) + (add-hook 'gnus-agent-group-mode-hook 'gnus-xmas-agent-group-menu-add)) + (defcustom gnus-agent-summary-mode-hook nil "Hook run in Agent summary minor modes." :group 'gnus-agent :type 'hook) +;; Extracted from gnus-xmas-redefine in order to preserve user settings +(when (featurep 'xemacs) + (add-hook 'gnus-agent-summary-mode-hook 'gnus-xmas-agent-summary-menu-add)) + (defcustom gnus-agent-server-mode-hook nil "Hook run in Agent summary minor modes." :group 'gnus-agent :type 'hook) +;; Extracted from gnus-xmas-redefine in order to preserve user settings +(when (featurep 'xemacs) + (add-hook 'gnus-agent-server-mode-hook 'gnus-xmas-agent-server-menu-add)) + (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) @@ -99,10 +124,6 @@ If nil, only read articles will be expired." (defvar gnus-agent-send-mail-function nil) (defvar gnus-agent-file-coding-system 'raw-text) -(defconst gnus-agent-scoreable-headers - '("subject" "from" "date" "message-id" "references" "chars" "lines" "xref") - "Headers that are considered when scoring articles for download via the Agent.") - ;; Dynamic variables (defvar gnus-headers) (defvar gnus-score) @@ -163,7 +184,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. @@ -185,7 +208,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))) @@ -232,7 +255,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) @@ -289,6 +312,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) @@ -358,7 +382,7 @@ agent minor mode in all Gnus buffers." (defun gnus-agent-insert-meta-information (type &optional method) "Insert meta-information into the message that says how it's to be posted. -TYPE can be either `mail' or `news'. If the latter METHOD can +TYPE can be either `mail' or `news'. If the latter, then METHOD can be a select method." (save-excursion (message-remove-header gnus-agent-meta-information-header) @@ -370,6 +394,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 ;;; @@ -424,26 +485,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")) - (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"))))))) + (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")) + (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 @@ -630,7 +714,7 @@ the actual number of articles toggled is returned." (gnus-make-directory (file-name-directory file)) (with-temp-file file ;; Emacs got problem to match non-ASCII group in multibyte buffer. - (mm-disable-multibyte) + (mm-disable-multibyte) (when (file-exists-p file) (nnheader-insert-file-contents file)) (goto-char (point-min)) @@ -658,7 +742,7 @@ the actual number of articles toggled is returned." (nnheader-translate-file-chars (nnheader-replace-chars-in-string (nnheader-replace-duplicate-chars-in-string - (nnheader-replace-chars-in-string + (nnheader-replace-chars-in-string (gnus-group-real-name group) ?/ ?_) ?. ?_) @@ -690,11 +774,12 @@ the actual number of articles toggled is returned." (format " *Gnus agent %s history*" (gnus-agent-method))))) gnus-agent-history-buffers) + (mm-disable-multibyte) ;; everything is binary (erase-buffer) (insert "\n") (let ((file (gnus-agent-lib-file "history"))) (when (file-exists-p file) - (insert-file file)) + (nnheader-insert-file-contents file)) (set (make-local-variable 'gnus-agent-file-name) file)))) (defun gnus-agent-save-history () @@ -774,8 +859,8 @@ the actual number of articles toggled is returned." (with-temp-buffer (let (article) (while (setq article (pop articles)) - (when (or - (gnus-backlog-request-article group article + (when (or + (gnus-backlog-request-article group article nntp-server-buffer) (gnus-request-article article group)) (goto-char (point-max)) @@ -870,7 +955,7 @@ the actual number of articles toggled is returned." (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 (union (gnus-uncompress-sequence (cdr arts)) + (setq articles (gnus-union (gnus-uncompress-sequence (cdr arts)) articles))) (setq articles (sort articles '<)) ;; Remove known articles. @@ -957,14 +1042,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 @@ -974,8 +1059,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." @@ -1012,10 +1099,15 @@ the actual number of articles toggled is returned." (while (setq group (pop groups)) (when (<= (gnus-group-level group) gnus-agent-handle-level) (gnus-agent-fetch-group-1 group gnus-command-method)))))) - (error + (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 fetching session (%s). Continue? " + err)) + (signal 'quit "Cannot fetch articles into the Gnus agent.")))) (pop methods)) (gnus-message 6 "Finished fetching articles into the Gnus agent")))) @@ -1026,23 +1118,25 @@ the actual number of articles toggled is returned." gnus-newsgroup-dependencies gnus-newsgroup-headers gnus-newsgroup-scored gnus-headers gnus-score gnus-use-cache articles arts - category predicate info marks score-param) + category predicate info marks score-param + (gnus-summary-expunge-below gnus-summary-expunge-below) + (gnus-summary-mark-below gnus-summary-mark-below) + (gnus-orphan-score gnus-orphan-score) + ;; Maybe some other gnus-summary local variables should also + ;; be put here. + ) (unless (gnus-check-group group) (error "Can't open server for %s" group)) ;; 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)) - ;; No need to call `gnus-get-newsgroup-headers-xover' with - ;; the entire .overview for group as we still have the just - ;; downloaded headers in `gnus-agent-overview-buffer'. - (let ((nntp-server-buffer gnus-agent-overview-buffer)) - (setq gnus-newsgroup-headers - (gnus-get-newsgroup-headers-xover articles nil nil - group))) + (setq gnus-newsgroup-headers + (gnus-get-newsgroup-headers-xover articles nil nil + group)) ;; `gnus-agent-overview-buffer' may be killed for ;; timeout reason. If so, recreate it. (gnus-agent-create-buffer))) @@ -1051,45 +1145,24 @@ the actual number of articles toggled is returned." (gnus-get-predicate (or (gnus-group-find-parameter group 'agent-predicate t) (cadr category)))) - ;; Do we want to download everything, or nothing? - (if (or (eq (caaddr predicate) 'gnus-agent-true) - (eq (caaddr predicate) 'gnus-agent-false)) - ;; Yes. - (setq arts (symbol-value - (cadr (assoc (caaddr predicate) - '((gnus-agent-true articles) - (gnus-agent-false nil)))))) - ;; No, we need to decide what we want. + (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 - (let ((score-method - (or - (gnus-group-find-parameter group 'agent-score t) - (caddr category)))) - (when score-method - (require 'gnus-score) - (if (eq score-method 'file) - (let ((entries - (gnus-score-load-files - (gnus-all-score-files group))) - list score-file) - (while (setq list (car entries)) - (push (car list) score-file) - (setq list (cdr list)) - (while list - (when (member (caar list) - gnus-agent-scoreable-headers) - (push (car list) score-file)) - (setq list (cdr list))) - (setq score-param - (append score-param (list (nreverse score-file))) - score-file nil entries (cdr entries))) - (list score-param)) - (if (stringp (car score-method)) - score-method - (list (list score-method))))))) + (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)) - (setq arts nil) (while (setq gnus-headers (pop gnus-newsgroup-headers)) (setq gnus-score (or (cdr (assq (mail-header-number gnus-headers) @@ -1456,7 +1529,7 @@ The following commands are available: (when (file-exists-p (gnus-agent-lib-file "active")) (with-temp-buffer (nnheader-insert-file-contents (gnus-agent-lib-file "active")) - (gnus-active-to-gnus-format + (gnus-active-to-gnus-format gnus-command-method (setq orig (gnus-make-hashtable (count-lines (point-min) (point-max)))))) @@ -1470,7 +1543,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. @@ -1522,7 +1605,7 @@ The following commands are available: (or (not (numberp (setq art (read (current-buffer))))) (< art article))) - (if (and (numberp art) + (if (and (numberp art) (file-exists-p (gnus-agent-article-name (number-to-string art) group)))