X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-agent.el;h=e9d3f5357b5427def7c1d413087886b3523a0d04;hb=f9e54240fc63f1ead8962e2afbc9b75e53994cd5;hp=76dfca3abdf82402649bbe591358fa42a255bf48;hpb=22d67eb69d38558636bccda449388713db84b44d;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index 76dfca3..e9d3f53 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -1,7 +1,9 @@ -;;; gnus-agent.el --- unplugged support for Gnus -;; Copyright (C) 1997,98,99 Free Software Foundation, Inc. +;;; gnus-agent.el --- unplugged support for Semi-gnus +;; Copyright (C) 1997, 1998, 1999, 2000, 2001 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen +;; Tatsuya Ichikawa ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify @@ -23,13 +25,22 @@ ;;; Code: +(eval-when-compile (require 'cl)) +(eval-when-compile (require 'gnus-clfns)) + (require 'gnus) (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 'gnus-group)) + +(eval-and-compile + (autoload 'gnus-server-update-server "gnus-srvr")) (defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/") "Where the Gnus agent will store its files." @@ -67,16 +78,51 @@ 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-large-newsgroup nil + "*The number of articles which indicates a large newsgroup. +If the number of unread articles exceeds it, The number of articles to be +fetched will be limited to it. If not a positive integer, never consider it." + :group 'gnus-agent + :type '(choice (const nil) + (integer :tag "Number"))) + +(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) @@ -94,10 +140,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) @@ -121,7 +163,7 @@ If nil, only read articles will be expired." (setq gnus-agent-overview-buffer (gnus-get-buffer-create " *Gnus agent overview*")) (with-current-buffer gnus-agent-overview-buffer - (mm-enable-multibyte)) + (set-buffer-multibyte t)) nil)) (gnus-add-shutdown 'gnus-close-agent 'gnus) @@ -158,7 +200,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. @@ -180,7 +224,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))) @@ -227,7 +271,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) @@ -284,13 +328,14 @@ 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) (setq gnus-plugged plugged) (gnus-run-hooks 'gnus-agent-unplugged-hook) (setcar (cdr gnus-agent-mode-status) " Unplugged")) - (set-buffer-modified-p t)) + (force-mode-line-update)) (defun gnus-agent-close-connections () "Close all methods covered by the Gnus agent." @@ -320,9 +365,9 @@ last form in your `.gnus.el' file: \(gnus-agentize) -This will modify the `gnus-before-startup-hook', `gnus-post-method', -and `message-send-mail-function' variables, and install the Gnus -agent minor mode in all Gnus buffers." +This will modify the `gnus-setup-news-hook', and +`message-send-mail-function' variables, and install the Gnus agent +minor mode in all Gnus buffers." (interactive) (gnus-open-agent) (add-hook 'gnus-setup-news-hook 'gnus-agent-queue-setup) @@ -353,7 +398,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) @@ -365,6 +410,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 ;;; @@ -419,26 +501,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) - (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 @@ -453,6 +558,7 @@ Currently sends flag setting requests, if any." (when (member method gnus-agent-covered-methods) (error "Server already in the agent program")) (push method gnus-agent-covered-methods) + (gnus-server-update-server server) (gnus-agent-write-servers) (message "Entered %s into the Agent" server))) @@ -466,6 +572,7 @@ Currently sends flag setting requests, if any." (error "Server not in the agent program")) (setq gnus-agent-covered-methods (delete method gnus-agent-covered-methods)) + (gnus-server-update-server server) (gnus-agent-write-servers) (message "Removed %s from the agent" server))) @@ -478,8 +585,12 @@ Currently sends flag setting requests, if any." (defun gnus-agent-write-servers () "Write the alist of covered servers." (gnus-make-directory (nnheader-concat gnus-agent-directory "lib")) - (with-temp-file (nnheader-concat gnus-agent-directory "lib/servers") - (prin1 gnus-agent-covered-methods (current-buffer)))) + (let ((coding-system-for-write nnheader-file-coding-system) + (output-coding-system nnheader-file-coding-system) + (file-name-coding-system nnmail-pathname-coding-system) + (pathname-coding-system nnmail-pathname-coding-system)) + (with-temp-file (nnheader-concat gnus-agent-directory "lib/servers") + (prin1 gnus-agent-covered-methods (current-buffer))))) ;;; ;;; Summary commands @@ -544,23 +655,18 @@ the actual number of articles toggled is returned." (gnus-agent-method-p gnus-command-method)) (gnus-agent-load-alist gnus-newsgroup-name) ;; First mark all undownloaded articles as undownloaded. - (let ((articles (append gnus-newsgroup-unreads - gnus-newsgroup-marked - gnus-newsgroup-dormant)) - article) - (while (setq article (pop articles)) - (unless (or (cdr (assq article gnus-agent-article-alist)) - (memq article gnus-newsgroup-downloadable) - (memq article gnus-newsgroup-cached)) - (push article gnus-newsgroup-undownloaded)))) + (dolist (article (mapcar (lambda (header) (mail-header-number header)) + gnus-newsgroup-headers)) + (unless (or (cdr (assq article gnus-agent-article-alist)) + (memq article gnus-newsgroup-downloadable) + (memq article gnus-newsgroup-cached)) + (push article gnus-newsgroup-undownloaded))) ;; Then mark downloaded downloadable as not-downloadable, ;; if you get my drift. - (let ((articles gnus-newsgroup-downloadable) - article) - (while (setq article (pop articles)) - (when (cdr (assq article gnus-agent-article-alist)) - (setq gnus-newsgroup-downloadable - (delq article gnus-newsgroup-downloadable)))))))) + (dolist (article gnus-newsgroup-downloadable) + (when (cdr (assq article gnus-agent-article-alist)) + (setq gnus-newsgroup-downloadable + (delq article gnus-newsgroup-downloadable))))))) (defun gnus-agent-catchup () "Mark all undownloaded articles as read." @@ -586,7 +692,8 @@ the actual number of articles toggled is returned." (funcall function nil new) (gnus-agent-write-active file new) (erase-buffer) - (insert-file-contents-literally file)))) + (insert-file-contents-as-coding-system gnus-agent-file-coding-system + file)))) (defun gnus-agent-write-active (file new) (let ((orig (gnus-make-hashtable (count-lines (point-min) (point-max)))) @@ -594,7 +701,8 @@ the actual number of articles toggled is returned." elem osym) (when (file-exists-p file) (with-temp-buffer - (insert-file-contents file) + (insert-file-contents-as-coding-system gnus-agent-file-coding-system + file) (gnus-active-to-gnus-format nil orig)) (mapatoms (lambda (sym) @@ -605,8 +713,9 @@ the actual number of articles toggled is returned." (set (intern (symbol-name sym) orig) (symbol-value sym))))) new)) (gnus-make-directory (file-name-directory file)) - (let ((coding-system-for-write gnus-agent-file-coding-system)) - (gnus-write-active-file file orig)))) + ;; The hashtable contains real names of groups, no more prefix + ;; removing, so set `full' to `t'. + (gnus-write-active-file file orig t))) (defun gnus-agent-save-groups (method) (gnus-agent-save-active-1 method 'gnus-groups-to-gnus-format)) @@ -614,7 +723,12 @@ the actual number of articles toggled is returned." (defun gnus-agent-save-group-info (method group active) (when (gnus-agent-method-p method) (let* ((gnus-command-method method) - (file (gnus-agent-lib-file "active"))) + (coding-system-for-write nnheader-file-coding-system) + (output-coding-system nnheader-file-coding-system) + (file-name-coding-system nnmail-pathname-coding-system) + (pathname-coding-system nnmail-pathname-coding-system) + (file (gnus-agent-lib-file "active")) + oactive) (gnus-make-directory (file-name-directory file)) (with-temp-file file (when (file-exists-p file) @@ -622,17 +736,33 @@ the actual number of articles toggled is returned." (goto-char (point-min)) (when (re-search-forward (concat "^" (regexp-quote group) " ") nil t) + (save-excursion + (save-restriction + (narrow-to-region (match-beginning 0) + (progn + (forward-line 1) + (point))) + (setq oactive (car (nnmail-parse-active))))) (gnus-delete-line)) - (insert group " " (number-to-string (cdr active)) " " - (number-to-string (car active)) " y\n"))))) + (insert (format "%S %d %d y\n" (intern group) + (cdr active) + (or (car oactive) (car active)))) + (goto-char (point-max)) + (while (search-backward "\\." nil t) + (delete-char 1)))))) (defun gnus-agent-group-path (group) "Translate GROUP into a path." (if nnmail-use-long-file-names (gnus-group-real-name group) - (nnheader-replace-chars-in-string - (nnheader-translate-file-chars (gnus-group-real-name group)) - ?. ?/))) + (nnheader-translate-file-chars + (nnheader-replace-chars-in-string + (nnheader-replace-duplicate-chars-in-string + (nnheader-replace-chars-in-string + (gnus-group-real-name group) + ?/ ?_) + ?. ?_) + ?. ?/)))) @@ -664,16 +794,16 @@ the actual number of articles toggled is returned." (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 () (save-excursion (set-buffer gnus-agent-current-history) (gnus-make-directory (file-name-directory gnus-agent-file-name)) - (let ((coding-system-for-write gnus-agent-file-coding-system)) - (write-region (1+ (point-min)) (point-max) - gnus-agent-file-name nil 'silent)))) + (write-region-as-coding-system + gnus-agent-file-coding-system + (1+ (point-min)) (point-max) gnus-agent-file-name nil 'silent))) (defun gnus-agent-close-history () (when (gnus-buffer-live-p gnus-agent-current-history) @@ -686,11 +816,15 @@ the actual number of articles toggled is returned." (save-excursion (set-buffer gnus-agent-current-history) (goto-char (point-max)) - (insert id "\t" (number-to-string date) "\t") - (while group-arts - (insert (caar group-arts) " " (number-to-string (cdr (pop group-arts))) - " ")) - (insert "\n"))) + (let ((p (point))) + (insert id "\t" (number-to-string date) "\t") + (while group-arts + (insert (format "%S" (intern (caar group-arts))) + " " (number-to-string (cdr (pop group-arts))) + " ")) + (insert "\n") + (while (search-backward "\\." p t) + (delete-char 1))))) (defun gnus-agent-article-in-history-p (id) (save-excursion @@ -719,7 +853,7 @@ the actual number of articles toggled is returned." ;; Prune off articles that we have already fetched. (while (and articles (cdr (assq (car articles) gnus-agent-article-alist))) - (pop articles)) + (pop articles)) (let ((arts articles)) (while (cdr arts) (if (cdr (assq (cadr arts) gnus-agent-article-alist)) @@ -740,7 +874,10 @@ the actual number of articles toggled is returned." (with-temp-buffer (let (article) (while (setq article (pop articles)) - (when (gnus-request-article article group) + (when (or + (gnus-backlog-request-article group article + nntp-server-buffer) + (gnus-request-article article group)) (goto-char (point-max)) (push (cons article (point)) pos) (insert-buffer-substring nntp-server-buffer))) @@ -770,11 +907,10 @@ the actual number of articles toggled is returned." (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) - (concat dir (number-to-string (caar pos))) - nil 'silent)) + (write-region-as-coding-system + gnus-agent-file-coding-system + (point-min) (point-max) + (concat dir (number-to-string (caar pos))) nil 'silent) (when (setq elem (assq (caar pos) gnus-agent-article-alist)) (setcdr elem t)) (gnus-agent-enter-history @@ -799,7 +935,7 @@ the actual number of articles toggled is returned." (setcdr alist (cons (cons (cdar crosses) t) (cdr alist))) (save-excursion (set-buffer (gnus-get-buffer-create (format " *Gnus agent overview %s*" - group))) + group))) (when (= (point-max) (point-min)) (push (cons group (current-buffer)) gnus-agent-buffer-alist) (ignore-errors @@ -814,12 +950,12 @@ the actual number of articles toggled is returned." (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)) + (write-region-as-coding-system + gnus-agent-file-coding-system + (point-min) (point-max) + (gnus-agent-article-name ".overview" + (caar gnus-agent-buffer-alist)) + nil 'silent) (pop gnus-agent-buffer-alist)) (while gnus-agent-group-alist (with-temp-file (caar gnus-agent-group-alist) @@ -828,37 +964,44 @@ the actual number of articles toggled is returned." (pop gnus-agent-group-alist)))) (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 + (let* ((articles (gnus-list-of-unread-articles group)) + (len (length articles)) + (gnus-decode-encoded-word-function 'identity) + (file (gnus-agent-article-name ".overview" group)) + i) + ;; Check the number of articles is not too large. + (when (and (integerp gnus-agent-large-newsgroup) + (< 0 gnus-agent-large-newsgroup)) + (and (< 0 (setq i (- len gnus-agent-large-newsgroup))) + (setq articles (nthcdr i articles)))) + ;; 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)) - articles))) + (setq articles (gnus-union (gnus-uncompress-sequence (cdr arts)) + articles))) (setq articles (sort articles '<)) - ;; remove known articles + ;; Remove known articles. (when (gnus-agent-load-alist group) (setq articles (gnus-sorted-intersection - articles - (gnus-uncompress-range - (cons (1+ (caar (last gnus-agent-article-alist))) - (cdr (gnus-active group))))))) + articles + (gnus-uncompress-range + (cons (1+ (caar (last gnus-agent-article-alist))) + (cdr (gnus-active group))))))) ;; Fetch them. (gnus-make-directory (nnheader-translate-file-chars - (file-name-directory file))) + (file-name-directory file) t)) (when articles (gnus-message 7 "Fetching headers for %s..." group) (save-excursion - (set-buffer nntp-server-buffer) - (unless (eq 'nov (gnus-retrieve-headers articles group)) - (nnvirtual-convert-headers)) - ;; Save these headers for later processing. - (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) + (set-buffer nntp-server-buffer) + (unless (eq 'nov (gnus-retrieve-headers articles group)) + (nnvirtual-convert-headers)) + ;; Save these headers for later processing. + (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) (when (file-exists-p file) (gnus-agent-braid-nov group articles file)) - (let ((coding-system-for-write - gnus-agent-file-coding-system)) - (write-region (point-min) (point-max) file nil 'silent)) + (write-region-as-coding-system + gnus-agent-file-coding-system + (point-min) (point-max) file nil 'silent) (gnus-agent-save-alist group articles nil) (gnus-agent-enter-history "last-header-fetched-for-session" @@ -920,31 +1063,36 @@ 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." - (with-temp-file (if dir - (concat dir ".agentview") - (gnus-agent-article-name ".agentview" group)) - (princ (setq gnus-agent-article-alist - (nconc gnus-agent-article-alist - (mapcar (lambda (article) (cons article state)) - articles))) - (current-buffer)) - (insert "\n"))) + (let ((file-name-coding-system nnmail-pathname-coding-system) + (pathname-coding-system nnmail-pathname-coding-system)) + (with-temp-file (if dir + (expand-file-name ".agentview" dir) + (gnus-agent-article-name ".agentview" group)) + (princ (setq gnus-agent-article-alist + (nconc gnus-agent-article-alist + (mapcar (lambda (article) (cons article state)) + articles))) + (current-buffer)) + (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))))) ;;;###autoload (defun gnus-agent-batch-fetch () "Start Gnus and fetch session." (interactive) (gnus) - (gnus-agent-fetch-session) + (let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation)) + (gnus-agent-fetch-session)) (gnus-group-exit)) (defun gnus-agent-fetch-session () @@ -958,14 +1106,25 @@ the actual number of articles toggled is returned." groups group gnus-command-method) (save-excursion (while methods - (setq gnus-command-method (car methods)) - (when (or (gnus-server-opened gnus-command-method) - (gnus-open-server gnus-command-method)) - (setq groups (gnus-groups-from-server (car methods))) - (gnus-agent-with-fetch - (while (setq group (pop groups)) - (when (<= (gnus-group-level group) gnus-agent-handle-level) - (gnus-agent-fetch-group-1 group gnus-command-method))))) + (condition-case err + (progn + (setq gnus-command-method (car methods)) + (when (or (gnus-server-opened gnus-command-method) + (gnus-open-server gnus-command-method)) + (setq groups (gnus-groups-from-server (car methods))) + (gnus-agent-with-fetch + (while (setq group (pop groups)) + (when (<= (gnus-group-level group) gnus-agent-handle-level) + (gnus-agent-fetch-group-1 group gnus-command-method)))))) + (error + (unless (funcall gnus-agent-confirmation-function + (format "Error (%s). Continue? " err)) + (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")))) @@ -976,70 +1135,51 @@ 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. + ;; timeout reason. If so, recreate it. (gnus-agent-create-buffer))) (setq category (gnus-group-category group)) (setq predicate (gnus-get-predicate - (or (gnus-group-find-parameter group 'agent-predicate t) + (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) @@ -1232,7 +1372,7 @@ The following commands are available: (gnus-edit-form (cadr info) (format "Editing the predicate for category %s" category) `(lambda (predicate) - (setf (cadr (assq ',category gnus-category-alist)) predicate) + (setcar (cdr (assq ',category gnus-category-alist)) predicate) (gnus-category-write) (gnus-category-list))))) @@ -1244,7 +1384,7 @@ The following commands are available: (caddr info) (format "Editing the score expression for category %s" category) `(lambda (groups) - (setf (caddr (assq ',category gnus-category-alist)) groups) + (setcar (nthcdr 2 (assq ',category gnus-category-alist)) groups) (gnus-category-write) (gnus-category-list))))) @@ -1255,7 +1395,7 @@ The following commands are available: (gnus-edit-form (cadddr info) (format "Editing the group list for category %s" category) `(lambda (groups) - (setf (cadddr (assq ',category gnus-category-alist)) groups) + (setcar (nthcdr 3 (assq ',category gnus-category-alist)) groups) (gnus-category-write) (gnus-category-list))))) @@ -1265,8 +1405,8 @@ The following commands are available: (let ((info (assq category gnus-category-alist)) (buffer-read-only nil)) (gnus-delete-line) - (gnus-category-write) - (setq gnus-category-alist (delq info gnus-category-alist)))) + (setq gnus-category-alist (delq info gnus-category-alist)) + (gnus-category-write))) (defun gnus-category-copy (category to) "Copy the current category." @@ -1405,8 +1545,9 @@ The following commands are available: (while (setq gnus-command-method (pop methods)) (when (file-exists-p (gnus-agent-lib-file "active")) (with-temp-buffer - (insert-file-contents (gnus-agent-lib-file "active")) - (gnus-active-to-gnus-format + (insert-file-contents-as-coding-system + gnus-agent-file-coding-system (gnus-agent-lib-file "active")) + (gnus-active-to-gnus-format gnus-command-method (setq orig (gnus-make-hashtable (count-lines (point-min) (point-max)))))) @@ -1420,13 +1561,24 @@ 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. (while (not (eolp)) - (setq sym (let ((obarray expiry-hashtb)) - (read (current-buffer)))) + (setq sym (let ((obarray expiry-hashtb) s) + (setq s (read (current-buffer))) + (if (stringp s) (intern s) s))) (if (boundp sym) (set sym (cons (cons (read (current-buffer)) (point)) (symbol-value sym))) @@ -1446,8 +1598,11 @@ The following commands are available: (gnus-uncompress-range (cdr (assq 'tick (gnus-info-marks info)))) (gnus-uncompress-range - (cdr (assq 'dormant - (gnus-info-marks info))))) + (cdr (assq 'dormant (gnus-info-marks info)))) + (gnus-uncompress-range + (cdr (assq 'save (gnus-info-marks info)))) + (gnus-uncompress-range + (cdr (assq 'reply (gnus-info-marks info))))) nov-file (gnus-agent-article-name ".overview" group) lowest nil highest nil) @@ -1456,7 +1611,7 @@ The following commands are available: (set-buffer overview) (erase-buffer) (when (file-exists-p nov-file) - (nnheader-insert-file-contents nov-file)) + (nnheader-insert-file-contents nov-file)) (goto-char (point-min)) (setq article 0) (while (setq elem (pop articles)) @@ -1471,7 +1626,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))) @@ -1495,9 +1650,9 @@ The following commands are available: ;; Schedule the history line for nuking. (push (cdr elem) histories))) (gnus-make-directory (file-name-directory nov-file)) - (let ((coding-system-for-write - gnus-agent-file-coding-system)) - (write-region (point-min) (point-max) nov-file nil 'silent)) + (write-region-as-coding-system + gnus-agent-file-coding-system + (point-min) (point-max) nov-file nil 'silent) ;; Delete the unwanted entries in the alist. (setq gnus-agent-article-alist (sort gnus-agent-article-alist 'car-less-than-car)) @@ -1555,8 +1710,7 @@ The following commands are available: (gnus-delete-line)) (gnus-agent-save-history) (gnus-agent-close-history) - (gnus-write-active-file - (gnus-agent-lib-file "active") orig)) + (gnus-write-active-file (gnus-agent-lib-file "active") orig)) (gnus-message 4 "Expiry...done"))))))) ;;;###autoload