X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-agent.el;h=eacc40038b31350c7c98430e1bd02688bfda26da;hb=1de95fffbc73dec22e758c219e55aa748b376ee1;hp=e2a20a3d5bbe3add2ec1b440b482ba21d013e1b9;hpb=45f9f06457a1286b6d5819486227e2eb77c03073;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index e2a20a3..eacc400 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -1,5 +1,6 @@ ;;; gnus-agent.el --- unplugged support for Semi-gnus -;; Copyright (C) 1997,98,99 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Tatsuya Ichikawa @@ -24,13 +25,23 @@ ;;; 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) +(require 'gnus-srvr) (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." @@ -47,13 +58,20 @@ :group 'gnus-agent :type 'hook) +(defcustom gnus-agent-fetched-hook nil + "Hook run after finishing fetching articles." + :group 'gnus-agent + :type 'hook) + (defcustom gnus-agent-handle-level gnus-level-subscribed "Groups on levels higher than this variable will be ignored by the Agent." :group 'gnus-agent :type 'integer) (defcustom gnus-agent-expire-days 7 - "Read articles older than this will be expired." + "Read articles older than this will be expired. +This can also be a list of regexp/day pairs. The regexps will +be matched against group names." :group 'gnus-agent :type 'integer) @@ -68,23 +86,66 @@ 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) + +(defcustom gnus-agent-go-online 'ask + "Indicate if offline servers go online 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) (defvar gnus-agent-buffer-alist nil) (defvar gnus-agent-article-alist nil) (defvar gnus-agent-group-alist nil) -(defvar gnus-agent-covered-methods nil) (defvar gnus-category-alist nil) (defvar gnus-agent-current-history nil) (defvar gnus-agent-overview-buffer nil) @@ -95,10 +156,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) @@ -111,12 +168,20 @@ If nil, only read articles will be expired." (setq gnus-agent t) (gnus-agent-read-servers) (gnus-category-read) - (setq gnus-agent-overview-buffer - (gnus-get-buffer-create " *Gnus agent overview*")) + (gnus-agent-create-buffer) (add-hook 'gnus-group-mode-hook 'gnus-agent-mode) (add-hook 'gnus-summary-mode-hook 'gnus-agent-mode) (add-hook 'gnus-server-mode-hook 'gnus-agent-mode)) +(defun gnus-agent-create-buffer () + (if (gnus-buffer-live-p gnus-agent-overview-buffer) + t + (setq gnus-agent-overview-buffer + (gnus-get-buffer-create " *Gnus agent overview*")) + (with-current-buffer gnus-agent-overview-buffer + (set-buffer-multibyte t)) + nil)) + (gnus-add-shutdown 'gnus-close-agent 'gnus) (defun gnus-close-agent () @@ -151,14 +216,17 @@ 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. (defun gnus-agent-start-fetch () "Initialize data structures for efficient fetching." (gnus-agent-open-history) - (setq gnus-agent-current-history (gnus-agent-history-buffer))) + (setq gnus-agent-current-history (gnus-agent-history-buffer)) + (gnus-agent-create-buffer)) (defun gnus-agent-stop-fetch () "Save all data structures and clean up." @@ -172,7 +240,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))) @@ -219,9 +287,11 @@ If nil, only read articles will be expired." "Jc" gnus-enter-category-buffer "Jj" gnus-agent-toggle-plugged "Js" gnus-agent-fetch-session - "JS" gnus-group-send-drafts + "JY" gnus-agent-synchronize-flags + "JS" gnus-group-send-queue "Ja" gnus-agent-add-group - "Jr" gnus-agent-remove-group) + "Jr" gnus-agent-remove-group + "Jo" gnus-agent-toggle-group-plugged) (defun gnus-agent-group-make-menu-bar () (unless (boundp 'gnus-agent-group-menu) @@ -229,8 +299,9 @@ If nil, only read articles will be expired." gnus-agent-group-menu gnus-agent-group-mode-map "" '("Agent" ["Toggle plugged" gnus-agent-toggle-plugged t] + ["Toggle group plugged" gnus-agent-toggle-group-plugged t] ["List categories" gnus-enter-category-buffer t] - ["Send drafts" gnus-group-send-drafts gnus-plugged] + ["Send queue" gnus-group-send-queue gnus-plugged] ("Fetch" ["All" gnus-agent-fetch-session gnus-plugged] ["Group" gnus-agent-fetch-group gnus-plugged]))))) @@ -238,6 +309,7 @@ If nil, only read articles will be expired." (defvar gnus-agent-summary-mode-map (make-sparse-keymap)) (gnus-define-keys gnus-agent-summary-mode-map "Jj" gnus-agent-toggle-plugged + "Ju" gnus-agent-summary-fetch-group "J#" gnus-agent-mark-article "J\M-#" gnus-agent-unmark-article "@" gnus-agent-toggle-mark @@ -252,6 +324,7 @@ If nil, only read articles will be expired." ["Mark as downloadable" gnus-agent-mark-article t] ["Unmark as downloadable" gnus-agent-unmark-article t] ["Toggle mark" gnus-agent-toggle-mark t] + ["Fetch downloadable" gnus-agent-summary-fetch-group t] ["Catchup undownloaded" gnus-agent-catchup t])))) (defvar gnus-agent-server-mode-map (make-sparse-keymap)) @@ -269,6 +342,13 @@ If nil, only read articles will be expired." ["Add" gnus-agent-add-server t] ["Remove" gnus-agent-remove-server t])))) +(defun gnus-agent-make-mode-line-string (string mouse-button mouse-func) + (if (and (fboundp 'propertize) + (fboundp 'make-mode-line-mouse-map)) + (propertize string 'local-map + (make-mode-line-mouse-map mouse-button mouse-func)) + string)) + (defun gnus-agent-toggle-plugged (plugged) "Toggle whether Gnus is unplugged or not." (interactive (list (not gnus-plugged))) @@ -276,12 +356,20 @@ If nil, only read articles will be expired." (progn (setq gnus-plugged plugged) (gnus-run-hooks 'gnus-agent-plugged-hook) - (setcar (cdr gnus-agent-mode-status) " Plugged")) + (setcar (cdr gnus-agent-mode-status) + (gnus-agent-make-mode-line-string " Plugged" + 'mouse-2 + 'gnus-agent-toggle-plugged)) + (gnus-agent-go-online gnus-agent-go-online) + (gnus-agent-possibly-synchronize-flags)) (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)) + (setcar (cdr gnus-agent-mode-status) + (gnus-agent-make-mode-line-string " Unplugged" + 'mouse-2 + 'gnus-agent-toggle-plugged))) + (force-mode-line-update)) (defun gnus-agent-close-connections () "Close all methods covered by the Gnus agent." @@ -311,15 +399,17 @@ 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-real-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) (unless gnus-agent-send-mail-function - (setq gnus-agent-send-mail-function message-send-mail-function - message-send-mail-function 'gnus-agent-send-mail)) + (setq gnus-agent-send-mail-function (or + message-send-mail-real-function + message-send-mail-function) + message-send-mail-real-function 'gnus-agent-send-mail)) (unless gnus-agent-covered-methods (setq gnus-agent-covered-methods (list gnus-select-method)))) @@ -344,7 +434,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) @@ -356,6 +446,42 @@ 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 (gnus-agent-method-p (car 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 ;;; @@ -370,14 +496,20 @@ be a select method." (defun gnus-agent-fetch-group (group) "Put all new articles in GROUP into the Agent." (interactive (list (gnus-group-group-name))) - (unless gnus-plugged - (error "Groups can't be fetched when Gnus is unplugged")) - (unless group - (error "No group on the current line")) - (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)))) + (let ((state gnus-plugged)) + (unwind-protect + (progn + (unless group + (error "No group on the current line")) + (unless state + (gnus-agent-toggle-plugged gnus-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)))) + (when (and (not state) + gnus-plugged) + (gnus-agent-toggle-plugged gnus-plugged))))) (defun gnus-agent-add-group (category arg) "Add the current group to an agent category." @@ -410,6 +542,50 @@ be a select method." (setf (cadddr c) (delete group (cadddr c)))))) (gnus-category-write))) +(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")) + (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 ;;; @@ -420,9 +596,10 @@ be a select method." (unless server (error "No server on the current line")) (let ((method (gnus-server-get-method nil (gnus-server-server-name)))) - (when (member method gnus-agent-covered-methods) + (when (gnus-agent-method-p method) (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))) @@ -432,10 +609,11 @@ be a select method." (unless server (error "No server on the current line")) (let ((method (gnus-server-get-method nil (gnus-server-server-name)))) - (unless (member method gnus-agent-covered-methods) + (unless (gnus-agent-method-p method) (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))) @@ -448,8 +626,12 @@ be a select method." (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 @@ -510,26 +692,22 @@ the actual number of articles toggled is returned." (defun gnus-agent-get-undownloaded-list () "Mark all unfetched articles as read." (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))) - (when (and (not gnus-plugged) + (when (and (not (gnus-online gnus-command-method)) (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)) - (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." @@ -540,6 +718,29 @@ the actual number of articles toggled is returned." (pop gnus-newsgroup-undownloaded) gnus-catchup-mark))) (gnus-summary-position-point)) +(defun gnus-agent-summary-fetch-group () + "Fetch the downloadable articles in the group." + (interactive) + (let ((articles gnus-newsgroup-downloadable) + (gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name)) + (state gnus-plugged)) + (unwind-protect + (progn + (unless state + (gnus-agent-toggle-plugged t)) + (unless articles + (error "No articles to download")) + (gnus-agent-with-fetch + (gnus-agent-fetch-articles gnus-newsgroup-name articles)) + (save-excursion + (dolist (article articles) + (setq gnus-newsgroup-downloadable + (delq article gnus-newsgroup-downloadable)) + (gnus-summary-mark-article article gnus-unread-mark)))) + (when (and (not state) + gnus-plugged) + (gnus-agent-toggle-plugged nil))))) + ;;; ;;; Internal functions ;;; @@ -572,12 +773,19 @@ the actual number of articles toggled is returned." (when (and sym (boundp sym)) (if (and (boundp (setq osym (intern (symbol-name sym) orig))) (setq elem (symbol-value osym))) - (setcdr elem (cdr (symbol-value sym))) + (progn + (if (and (integerp (car (symbol-value sym))) + (> (car elem) (car (symbol-value sym)))) + (setcar elem (car (symbol-value sym)))) + (if (integerp (cdr (symbol-value sym))) + (setcdr elem (cdr (symbol-value sym))))) (set (intern (symbol-name sym) orig) (symbol-value sym))))) new)) (gnus-make-directory (file-name-directory file)) - (gnus-write-active-file-as-coding-system gnus-agent-file-coding-system - file orig))) + (let ((nnmail-active-file-coding-system gnus-agent-file-coding-system)) + ;; 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)) @@ -585,7 +793,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-min) (gnus-make-directory (file-name-directory file)) (with-temp-file file (when (file-exists-p file) @@ -593,31 +806,37 @@ the actual number of articles toggled is returned." (goto-char (point-min)) (when (re-search-forward (concat "^" (regexp-quote group) " ") nil t) + (save-excursion + (read (current-buffer)) ;; max + (setq oactive-min (read (current-buffer)))) ;; min (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 oactive-min (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) + ?/ ?_) + ?. ?_) + ?. ?/)))) -(defun gnus-agent-method-p (method) - "Say whether METHOD is covered by the agent." - (member method gnus-agent-covered-methods)) - (defun gnus-agent-get-function (method) - (if (and (not gnus-plugged) - (gnus-agent-method-p method)) - (progn - (require 'nnagent) - 'nnagent) - (car method))) + (if (gnus-online method) + (car method) + (require 'nnagent) + 'nnagent)) ;;; History functions @@ -635,7 +854,7 @@ 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 () @@ -657,11 +876,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 @@ -690,7 +913,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)) @@ -711,7 +934,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))) @@ -769,7 +995,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 @@ -798,15 +1024,21 @@ 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 gnus-agent-cache) + ;; 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 (sort articles '<)) - ;; remove known articles + (setq articles (gnus-range-add articles (cdr arts)))) + (setq articles (sort (gnus-uncompress-sequence articles) '<)) + ;; Remove known articles. (when (gnus-agent-load-alist group) (setq articles (gnus-sorted-intersection articles @@ -815,7 +1047,7 @@ the actual number of articles toggled is returned." (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 @@ -839,14 +1071,15 @@ the actual number of articles toggled is returned." (defsubst gnus-agent-copy-nov-line (article) (let (b e) (set-buffer gnus-agent-overview-buffer) - (setq b (point)) - (if (eq article (read (current-buffer))) - (setq e (progn (forward-line 1) (point))) - (progn - (beginning-of-line) - (setq e b))) - (set-buffer nntp-server-buffer) - (insert-buffer-substring gnus-agent-overview-buffer b e))) + (unless (eobp) + (setq b (point)) + (if (eq article (read (current-buffer))) + (setq e (progn (forward-line 1) (point))) + (progn + (beginning-of-line) + (setq e b))) + (set-buffer nntp-server-buffer) + (insert-buffer-substring gnus-agent-overview-buffer b e)))) (defun gnus-agent-braid-nov (group articles file) (set-buffer gnus-agent-overview-buffer) @@ -877,11 +1110,16 @@ the actual number of articles toggled is returned." (unless (eobp) (gnus-agent-copy-nov-line (car articles)) (setq articles (cdr articles)))) + (set-buffer nntp-server-buffer) (when articles (let (b e) (set-buffer gnus-agent-overview-buffer) (setq b (point) e (point-max)) + (while (and (not (eobp)) + (<= (read (current-buffer)) (car articles))) + (forward-line 1) + (setq b (point))) (set-buffer nntp-server-buffer) (insert-buffer-substring gnus-agent-overview-buffer b e))))) @@ -890,31 +1128,39 @@ 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) + print-level print-length item) + (dolist (art articles) + (if (setq item (memq art gnus-agent-article-alist)) + (setcdr item state) + (push (cons art state) gnus-agent-article-alist))) + (setq gnus-agent-article-alist + (sort gnus-agent-article-alist 'car-less-than-car)) + (with-temp-file (if dir + (expand-file-name ".agentview" dir) + (gnus-agent-article-name ".agentview" group)) + (princ gnus-agent-article-alist (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 () @@ -928,15 +1174,28 @@ 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 (and (or (gnus-server-opened gnus-command-method) + (gnus-open-server gnus-command-method)) + (gnus-online 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)) + (run-hooks 'gnus-agent-fetch-hook) (gnus-message 6 "Finished fetching articles into the Gnus agent")))) (defun gnus-agent-fetch-group-1 (group method) @@ -946,63 +1205,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))) - ;; 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))) + (when (and (or (gnus-active group) + (gnus-activate-group group)) + (setq articles (gnus-agent-fetch-headers group)) + (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)) + (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))) (setq category (gnus-group-category group)) (setq predicate (gnus-get-predicate - (or (gnus-group-get-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 predicate '(gnus-agent-true gnus-agent-false)) + ;; Simple implementation + (setq arts (and (eq predicate 'gnus-agent-true) articles)) + (setq arts nil) (setq score-param - (let ((score-method - (or - (gnus-group-get-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) @@ -1018,6 +1265,7 @@ the actual number of articles toggled is returned." (setq arts (assq 'download (gnus-info-marks (setq info (gnus-get-info group))))) (when (cdr arts) + (gnus-message 8 "Agent is downloading marked articles...") (gnus-agent-fetch-articles group (gnus-uncompress-range (cdr arts))) (setq marks (delq arts (gnus-info-marks info))) @@ -1035,7 +1283,14 @@ the actual number of articles toggled is returned." "Hook run in `gnus-category-mode' buffers.") (defvar gnus-category-line-format " %(%20c%): %g\n" - "Format of category lines.") + "Format of category lines. + +Valid specifiers include: +%c Topic name (string) +%g The number of groups in the topic (integer) + +General format specifiers can also be used. See +(gnus)Formatting Variables.") (defvar gnus-category-mode-line-format "Gnus: %%b" "The format specification for the category mode line.") @@ -1135,7 +1390,7 @@ The following commands are available: (defalias 'gnus-category-position-point 'gnus-goto-colon) (defun gnus-category-insert-line (category) - (let* ((gnus-tmp-name (car category)) + (let* ((gnus-tmp-name (format "%s" (car category))) (gnus-tmp-groups (length (cadddr category)))) (beginning-of-line) (gnus-add-text-properties @@ -1170,7 +1425,7 @@ The following commands are available: (gnus-category-position-point))) (defun gnus-category-name () - (or (get-text-property (gnus-point-at-bol) 'gnus-category) + (or (intern (get-text-property (gnus-point-at-bol) 'gnus-category)) (error "No category on the current line"))) (defun gnus-category-read () @@ -1195,7 +1450,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))))) @@ -1207,7 +1462,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))))) @@ -1218,7 +1473,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))))) @@ -1228,8 +1483,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." @@ -1304,7 +1559,11 @@ The following commands are available: (defun gnus-category-make-function (cat) "Make a function from category CAT." - `(lambda () ,(gnus-category-make-function-1 cat))) + (let ((func (gnus-category-make-function-1 cat))) + (if (and (= (length func) 1) + (symbolp (car func))) + (car func) + (gnus-byte-compile `(lambda () ,func))))) (defun gnus-agent-true () "Return t." @@ -1359,164 +1618,198 @@ The following commands are available: "Expire all old articles." (interactive) (let ((methods gnus-agent-covered-methods) - (day (- (time-to-days (current-time)) gnus-agent-expire-days)) + (day (if (numberp gnus-agent-expire-days) + (- (time-to-days (current-time)) gnus-agent-expire-days) + nil)) + (current-day (time-to-days (current-time))) gnus-command-method sym group articles history overview file histories elem art nov-file low info - unreads marked article orig lowest highest) + unreads marked article orig lowest highest found days) (save-excursion (setq overview (gnus-get-buffer-create " *expire overview*")) (while (setq gnus-command-method (pop methods)) - (with-temp-buffer - (insert-file-contents-as-coding-system - gnus-agent-file-coding-system (gnus-agent-lib-file "active")) - (gnus-active-to-gnus-format - nil (setq orig (gnus-make-hashtable - (count-lines (point-min) (point-max)))))) - (let ((expiry-hashtb (gnus-make-hashtable 1023))) - (gnus-agent-open-history) - (set-buffer - (setq gnus-agent-current-history - (setq history (gnus-agent-history-buffer)))) - (goto-char (point-min)) - (when (> (buffer-size) 1) - (goto-char (point-min)) - (while (not (eobp)) - (skip-chars-forward "^\t") - (if (> (read (current-buffer)) day) - ;; 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)))) - (if (boundp sym) - (set sym (cons (cons (read (current-buffer)) (point)) - (symbol-value sym))) - (set sym (list (cons (read (current-buffer)) (point))))) - (skip-chars-forward " ")) - (forward-line 1))) - ;; We now have all articles that can possibly be expired. - (mapatoms - (lambda (sym) - (setq group (symbol-name sym) - articles (sort (symbol-value sym) 'car-less-than-car) - low (car (gnus-active group)) - info (gnus-get-info group) - unreads (ignore-errors (gnus-list-of-unread-articles group)) - marked (nconc (gnus-uncompress-range - (cdr (assq 'tick (gnus-info-marks info)))) - (gnus-uncompress-range - (cdr (assq 'dormant - (gnus-info-marks info))))) - nov-file (gnus-agent-article-name ".overview" group) - lowest nil - highest nil) - (gnus-agent-load-alist group) - (gnus-message 5 "Expiring articles in %s" group) - (set-buffer overview) - (erase-buffer) - (when (file-exists-p nov-file) - (nnheader-insert-file-contents nov-file)) - (goto-char (point-min)) - (setq article 0) - (while (setq elem (pop articles)) - (setq article (car elem)) - (when (or (null low) - (< article low) - gnus-agent-expire-all - (and (not (memq article unreads)) - (not (memq article marked)))) - ;; Find and nuke the NOV line. - (while (and (not (eobp)) - (or (not (numberp - (setq art (read (current-buffer))))) - (< art article))) - (if (file-exists-p - (gnus-agent-article-name - (number-to-string art) group)) - (progn - (unless lowest - (setq lowest art)) - (setq highest art) - (forward-line 1)) - ;; Remove old NOV lines that have no articles. - (gnus-delete-line))) - (if (or (eobp) - (/= art article)) - (beginning-of-line) - (gnus-delete-line)) - ;; Nuke the article. - (when (file-exists-p (setq file (gnus-agent-article-name - (number-to-string article) - group))) - (delete-file file)) - ;; Schedule the history line for nuking. - (push (cdr elem) histories))) - (gnus-make-directory (file-name-directory nov-file)) - (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)) - (let* ((alist gnus-agent-article-alist) - (prev (cons nil alist)) - (first prev) - expired) - (while (and alist - (<= (caar alist) article)) - (if (or (not (cdar alist)) - (not (file-exists-p - (gnus-agent-article-name - (number-to-string - (caar alist)) - group)))) - (progn - (push (caar alist) expired) - (setcdr prev (setq alist (cdr alist)))) - (setq prev alist - alist (cdr alist)))) - (setq gnus-agent-article-alist (cdr first)) - (gnus-agent-save-alist group) - ;; Mark all articles up to the first article - ;; in `gnus-article-alist' as read. - (when (and info (caar gnus-agent-article-alist)) - (setcar (nthcdr 2 info) - (gnus-range-add - (nth 2 info) - (cons 1 (- (caar gnus-agent-article-alist) 1))))) - ;; Maybe everything has been expired from `gnus-article-alist' - ;; and so the above marking as read could not be conducted, - ;; or there are expired article within the range of the alist. - (when (and info - expired - (or (not (caar gnus-agent-article-alist)) - (> (car expired) - (caar gnus-agent-article-alist)))) - (setcar (nthcdr 2 info) - (gnus-add-to-range - (nth 2 info) - (nreverse expired)))) - (gnus-dribble-enter - (concat "(gnus-group-set-info '" - (gnus-prin1-to-string info) - ")"))) - (when lowest - (if (gnus-gethash group orig) - (setcar (gnus-gethash group orig) lowest) - (gnus-sethash group (cons lowest highest) orig)))) - expiry-hashtb) - (set-buffer history) - (setq histories (nreverse (sort histories '<))) - (while histories - (goto-char (pop histories)) - (gnus-delete-line)) - (gnus-agent-save-history) - (gnus-agent-close-history) - (gnus-write-active-file-as-coding-system - gnus-agent-file-coding-system - (gnus-agent-lib-file "active") orig)) - (gnus-message 4 "Expiry...done")))))) + (when (file-exists-p (gnus-agent-lib-file "active")) + (with-temp-buffer + (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)))))) + (let ((expiry-hashtb (gnus-make-hashtable 1023))) + (gnus-agent-open-history) + (set-buffer + (setq gnus-agent-current-history + (setq history (gnus-agent-history-buffer)))) + (goto-char (point-min)) + (when (> (buffer-size) 1) + (goto-char (point-min)) + (while (not (eobp)) + (skip-chars-forward "^\t") + (if (let ((fetch-date (read (current-buffer)))) + (if (numberp fetch-date) + ;; We now have the arrival day, so we see + ;; whether it's old enough to be expired. + (if (numberp day) + (> fetch-date day) + (skip-chars-forward "\t") + (setq found nil + days gnus-agent-expire-days) + (while (and (not found) + days) + (when (looking-at (caar days)) + (setq found (cadar days))) + (pop days)) + (> fetch-date (- current-day found))) + ;; 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) 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))) + (set sym (list (cons (read (current-buffer)) (point))))) + (skip-chars-forward " ")) + (forward-line 1))) + ;; We now have all articles that can possibly be expired. + (mapatoms + (lambda (sym) + (setq group (symbol-name sym) + articles (sort (symbol-value sym) 'car-less-than-car) + low (car (gnus-active group)) + info (gnus-get-info group) + unreads (ignore-errors + (gnus-list-of-unread-articles group)) + marked (nconc + (gnus-uncompress-range + (cdr (assq 'tick (gnus-info-marks info)))) + (gnus-uncompress-range + (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) + (gnus-agent-load-alist group) + (gnus-message 5 "Expiring articles in %s" group) + (set-buffer overview) + (erase-buffer) + (when (file-exists-p nov-file) + (nnheader-insert-file-contents nov-file)) + (goto-char (point-min)) + (setq article 0) + (while (setq elem (pop articles)) + (setq article (car elem)) + (when (or (null low) + (< article low) + gnus-agent-expire-all + (and (not (memq article unreads)) + (not (memq article marked)))) + ;; Find and nuke the NOV line. + (while (and (not (eobp)) + (or (not (numberp + (setq art (read (current-buffer))))) + (< art article))) + (if (and (numberp art) + (file-exists-p + (gnus-agent-article-name + (number-to-string art) group))) + (progn + (unless lowest + (setq lowest art)) + (setq highest art) + (forward-line 1)) + ;; Remove old NOV lines that have no articles. + (gnus-delete-line))) + (if (or (eobp) + (/= art article)) + (beginning-of-line) + (gnus-delete-line)) + ;; Nuke the article. + (when (file-exists-p + (setq file (gnus-agent-article-name + (number-to-string article) + group))) + (delete-file file)) + ;; Schedule the history line for nuking. + (push (cdr elem) histories))) + (gnus-make-directory (file-name-directory nov-file)) + (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)) + (let* ((alist gnus-agent-article-alist) + (prev (cons nil alist)) + (first prev) + expired) + (while (and alist + (<= (caar alist) article)) + (if (or (not (cdar alist)) + (not (file-exists-p + (gnus-agent-article-name + (number-to-string + (caar alist)) + group)))) + (progn + (push (caar alist) expired) + (setcdr prev (setq alist (cdr alist)))) + (setq prev alist + alist (cdr alist)))) + (setq gnus-agent-article-alist (cdr first)) + (gnus-agent-save-alist group) + ;; Mark all articles up to the first article + ;; in `gnus-article-alist' as read. + (when (and info (caar gnus-agent-article-alist)) + (setcar (nthcdr 2 info) + (gnus-range-add + (nth 2 info) + (cons 1 (- (caar gnus-agent-article-alist) 1))))) + ;; Maybe everything has been expired from + ;; `gnus-article-alist' and so the above marking as + ;; read could not be conducted, or there are + ;; expired article within the range of the alist. + (when (and info + expired + (or (not (caar gnus-agent-article-alist)) + (> (car expired) + (caar gnus-agent-article-alist)))) + (setcar (nthcdr 2 info) + (gnus-add-to-range + (nth 2 info) + (nreverse expired)))) + (gnus-dribble-enter + (concat "(gnus-group-set-info '" + (gnus-prin1-to-string info) + ")"))) + (when lowest + (if (gnus-gethash group orig) + (setcar (gnus-gethash group orig) lowest) + (gnus-sethash group (cons lowest highest) orig)))) + expiry-hashtb) + (set-buffer history) + (setq histories (nreverse (sort histories '<))) + (while histories + (goto-char (pop histories)) + (gnus-delete-line)) + (gnus-agent-save-history) + (gnus-agent-close-history) + (gnus-write-active-file (gnus-agent-lib-file "active") orig)) + (gnus-message 4 "Expiry...done"))))))) ;;;###autoload (defun gnus-agent-batch () @@ -1524,8 +1817,309 @@ The following commands are available: (let ((init-file-user "") (gnus-always-read-dribble-file t)) (gnus)) - (gnus-group-send-drafts) - (gnus-agent-fetch-session)) + (let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation)) + (gnus-group-send-queue) + (gnus-agent-fetch-session))) + +(defun gnus-agent-retrieve-headers (articles group &optional fetch-old) + (save-excursion + (gnus-agent-create-buffer) + (let ((gnus-decode-encoded-word-function 'identity) + (file (gnus-agent-article-name ".overview" group)) + cached-articles uncached-articles) + (gnus-make-directory (nnheader-translate-file-chars + (file-name-directory file) t)) + (when (file-exists-p file) + (with-current-buffer gnus-agent-overview-buffer + (erase-buffer) + (let ((nnheader-file-coding-system + gnus-agent-file-coding-system)) + (nnheader-insert-file-contents file)) + (goto-char (point-min)) + (while (not (eobp)) + (when (looking-at "[0-9]") + (push (read (current-buffer)) cached-articles)) + (forward-line 1)) + (setq cached-articles (sort cached-articles '<)))) + (if (setq uncached-articles + (gnus-set-difference articles cached-articles)) + (progn + (set-buffer nntp-server-buffer) + (erase-buffer) + (let (gnus-agent-cache) + (unless (eq 'nov + (gnus-retrieve-headers + uncached-articles group fetch-old)) + (nnvirtual-convert-headers))) + (set-buffer gnus-agent-overview-buffer) + (erase-buffer) + (set-buffer nntp-server-buffer) + (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) + (when (and uncached-articles (file-exists-p file)) + (gnus-agent-braid-nov group uncached-articles file)) + (set-buffer nntp-server-buffer) + (write-region-as-coding-system gnus-agent-file-coding-system + (point-min) (point-max) + file nil 'silent) + (gnus-agent-load-alist group) + (gnus-agent-save-alist group uncached-articles nil) + (gnus-agent-open-history) + (setq gnus-agent-current-history (gnus-agent-history-buffer)) + (gnus-agent-enter-history + "last-header-fetched-for-session" + (list (cons group (nth (- (length articles) 1) articles))) + (time-to-days (current-time))) + (gnus-agent-save-history)) + (set-buffer nntp-server-buffer) + (erase-buffer) + (insert-buffer-substring gnus-agent-overview-buffer))) + (if (and fetch-old + (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 (last articles))) + t) + 'nov)) + +(defun gnus-agent-request-article (article group) + "Retrieve ARTICLE in GROUP from the agent cache." + (let* ((gnus-command-method (gnus-find-method-for-group group)) + (file (concat + (gnus-agent-directory) + (gnus-agent-group-path group) "/" + (number-to-string article))) + (buffer-read-only nil)) + (when (file-exists-p file) + (erase-buffer) + (gnus-kill-all-overlays) + (insert-file-contents-as-coding-system gnus-cache-coding-system file) + t))) + +(defun gnus-agent-regenerate-group (group &optional clean) + "Regenerate GROUP." + (let ((dir (concat (gnus-agent-directory) + (gnus-agent-group-path group) "/")) + (file (gnus-agent-article-name ".overview" group)) + n point arts alist header new-alist changed) + (when (file-exists-p dir) + (setq arts + (sort (mapcar (lambda (name) (string-to-int name)) + (directory-files dir nil "^[0-9]+$" t)) + '<))) + (gnus-make-directory (nnheader-translate-file-chars + (file-name-directory file) t)) + (mm-with-unibyte-buffer + (if (file-exists-p file) + (let ((nnheader-file-coding-system + gnus-agent-file-coding-system)) + (nnheader-insert-file-contents file))) + (goto-char (point-min)) + (while (not (eobp)) + (while (not (or (eobp) (looking-at "[0-9]"))) + (setq point (point)) + (forward-line 1) + (delete-region point (point))) + (unless (eobp) + (setq n (read (current-buffer))) + (when (and arts (> n (car arts))) + (beginning-of-line) + (while (and arts (> n (car arts))) + (message "Regenerating NOV %s %d..." group (car arts)) + (mm-with-unibyte-buffer + (nnheader-insert-file-contents + (concat dir (number-to-string (car arts)))) + (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (delete-region (point) (point-max)) + (goto-char (point-max))) + (setq header (nnheader-parse-head t))) + (mail-header-set-number header (car arts)) + (nnheader-insert-nov header) + (setq changed t) + (push (cons (car arts) t) alist) + (pop arts))) + (if (and arts (= n (car arts))) + (progn + (push (cons n t) alist) + (pop arts)) + (push (cons n nil) alist)) + (forward-line 1))) + (if changed + (write-region-as-coding-system gnus-agent-file-coding-system + (point-min) (point-max) + file nil 'silent))) + (setq gnus-agent-article-alist nil) + (unless clean + (gnus-agent-load-alist group)) + (setq alist (sort alist 'car-less-than-car)) + (setq gnus-agent-article-alist (sort gnus-agent-article-alist + 'car-less-than-car)) + (while (and alist gnus-agent-article-alist) + (cond + ((< (caar alist) (caar gnus-agent-article-alist)) + (push (pop alist) new-alist)) + ((> (caar alist) (caar gnus-agent-article-alist)) + (push (list (car (pop gnus-agent-article-alist))) new-alist)) + (t + (pop gnus-agent-article-alist) + (while (and gnus-agent-article-alist + (= (caar alist) (caar gnus-agent-article-alist))) + (pop gnus-agent-article-alist)) + (push (pop alist) new-alist)))) + (while alist + (push (pop alist) new-alist)) + (while gnus-agent-article-alist + (push (list (car (pop gnus-agent-article-alist))) new-alist)) + (setq gnus-agent-article-alist (nreverse new-alist)) + (gnus-agent-save-alist group))) + +(defun gnus-agent-regenerate-history (group article) + (let ((file (concat (gnus-agent-directory) + (gnus-agent-group-path group) "/" + (number-to-string article))) id) + (mm-with-unibyte-buffer + (nnheader-insert-file-contents file) + (message-narrow-to-head) + (goto-char (point-min)) + (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)))) + (gnus-agent-enter-history + id (list (cons group article)) + (time-to-days (nth 5 (file-attributes file))))))) + +;;;###autoload +(defun gnus-agent-regenerate (&optional clean) + "Regenerate all agent covered files. +If CLEAN, don't read existing active and agentview files." + (interactive "P") + (message "Regenerating Gnus agent files...") + (dolist (gnus-command-method gnus-agent-covered-methods) + (let ((active-file (gnus-agent-lib-file "active")) + history-hashtb active-hashtb active-changed + history-changed point) + (gnus-make-directory (file-name-directory active-file)) + (if clean + (setq active-hashtb (gnus-make-hashtable 1000)) + (mm-with-unibyte-buffer + (if (file-exists-p active-file) + (let ((nnheader-file-coding-system + gnus-agent-file-coding-system)) + (nnheader-insert-file-contents active-file)) + (setq active-changed t)) + (gnus-active-to-gnus-format + nil (setq active-hashtb + (gnus-make-hashtable + (count-lines (point-min) (point-max))))))) + (gnus-agent-open-history) + (setq history-hashtb (gnus-make-hashtable 1000)) + (with-current-buffer + (setq gnus-agent-current-history (gnus-agent-history-buffer)) + (goto-char (point-min)) + (forward-line 1) + (while (not (eobp)) + (if (looking-at + "\\([^\t\n]+\\)\t[0-9]+\t\\([^ \n]+\\) \\([0-9]+\\)") + (progn + (unless (string= (match-string 1) + "last-header-fetched-for-session") + (gnus-sethash (match-string 2) + (cons (string-to-number (match-string 3)) + (gnus-gethash-safe (match-string 2) + history-hashtb)) + history-hashtb)) + (forward-line 1)) + (setq point (point)) + (forward-line 1) + (delete-region point (point)) + (setq history-changed t)))) + (dolist (group (gnus-groups-from-server gnus-command-method)) + (gnus-agent-regenerate-group group clean) + (let ((min (or (caar gnus-agent-article-alist) 1)) + (max (or (caar (last gnus-agent-article-alist)) 0)) + (active (gnus-gethash-safe (gnus-group-real-name group) + active-hashtb))) + (if (not active) + (progn + (setq active (cons min max) + active-changed t) + (gnus-sethash group active active-hashtb)) + (when (> (car active) min) + (setcar active min) + (setq active-changed t)) + (when (< (cdr active) max) + (setcdr active max) + (setq active-changed t)))) + (let ((arts (sort (gnus-gethash-safe group history-hashtb) '<)) + n) + (gnus-sethash group arts history-hashtb) + (while (and arts gnus-agent-article-alist) + (cond + ((> (car arts) (caar gnus-agent-article-alist)) + (when (cdar gnus-agent-article-alist) + (gnus-agent-regenerate-history + group (caar gnus-agent-article-alist)) + (setq history-changed t)) + (setq n (car (pop gnus-agent-article-alist))) + (while (and gnus-agent-article-alist + (= n (caar gnus-agent-article-alist))) + (pop gnus-agent-article-alist))) + ((< (car arts) (caar gnus-agent-article-alist)) + (setq n (pop arts)) + (while (and arts (= n (car arts))) + (pop arts))) + (t + (setq n (car (pop gnus-agent-article-alist))) + (while (and gnus-agent-article-alist + (= n (caar gnus-agent-article-alist))) + (pop gnus-agent-article-alist)) + (setq n (pop arts)) + (while (and arts (= n (car arts))) + (pop arts))))) + (while gnus-agent-article-alist + (when (cdar gnus-agent-article-alist) + (gnus-agent-regenerate-history + group (caar gnus-agent-article-alist)) + (setq history-changed t)) + (pop gnus-agent-article-alist)))) + (when history-changed + (message "Regenerate the history file of %s:%s" + (car gnus-command-method) + (cadr gnus-command-method)) + (gnus-agent-save-history)) + (gnus-agent-close-history) + (when active-changed + (message "Regenerate %s" active-file) + (let ((nnmail-active-file-coding-system gnus-agent-file-coding-system)) + (gnus-write-active-file active-file active-hashtb))))) + (message "Regenerating Gnus agent files...done")) + +(defun gnus-agent-go-online (&optional force) + "Switch servers into online status." + (interactive (list t)) + (dolist (server gnus-opened-servers) + (when (eq (nth 1 server) 'offline) + (if (if (eq force 'ask) + (gnus-y-or-n-p + (format "Switch %s:%s into online status? " + (caar server) (cadar server))) + force) + (setcar (nthcdr 1 server) 'close))))) + +(defun gnus-agent-toggle-group-plugged (group) + "Toggle the status of the server of the current group." + (interactive (list (gnus-group-group-name))) + (let* ((method (gnus-find-method-for-group group)) + (status (cadr (assoc method gnus-opened-servers)))) + (if (eq status 'offline) + (gnus-server-set-status method 'closed) + (gnus-close-server method) + (gnus-server-set-status method 'offline)) + (message "Turn %s:%s from %s to %s." (car method) (cadr method) + (if (eq status 'offline) 'offline 'online) + (if (eq status 'offline) 'online 'offline)))) (provide 'gnus-agent)