X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-agent.el;h=4950a85ca65d0eff437d85853080f7a05566bc6f;hb=9337b1d0bd77d2f999ae11a2543b79b1338f8588;hp=6595802fb9df921956307621caec0a5173fc66ae;hpb=3738187cad20787b5b99c4061256e30e19ee721a;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index 6595802..4950a85 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -1,8 +1,9 @@ -;;; gnus-agent.el --- unplugged support for Gnus +;;; gnus-agent.el --- unplugged support for Semi-gnus ;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002 ;; 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 @@ -24,16 +25,20 @@ ;;; 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 (if (featurep 'xemacs) (require 'itimer) (require 'timer)) - (require 'cl)) + (require 'gnus-group)) (eval-and-compile (autoload 'gnus-server-update-server "gnus-srvr")) @@ -53,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) @@ -102,6 +114,14 @@ If nil, only read articles will be expired." :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." @@ -111,13 +131,21 @@ If this is `ask' the hook will query the user." (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) @@ -127,6 +155,7 @@ If this is `ask' the hook will query the user." (defvar gnus-agent-file-name nil) (defvar gnus-agent-send-mail-function nil) (defvar gnus-agent-file-coding-system 'raw-text) +(defvar gnus-agent-file-loading-cache nil) ;; Dynamic variables (defvar gnus-headers) @@ -151,7 +180,7 @@ If this is `ask' the hook will query the user." (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) @@ -262,7 +291,8 @@ If this is `ask' the hook will query the user." "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) @@ -270,6 +300,7 @@ If this is `ask' the hook will query the user." 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 queue" gnus-group-send-queue gnus-plugged] ("Fetch" @@ -294,7 +325,7 @@ If this is `ask' the hook will query the user." ["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-aget-summary-fetch-group t] + ["Fetch downloadable" gnus-agent-summary-fetch-group t] ["Catchup undownloaded" gnus-agent-catchup t])))) (defvar gnus-agent-server-mode-map (make-sparse-keymap)) @@ -325,20 +356,21 @@ If this is `ask' the hook will query the user." (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) + (setcar (cdr gnus-agent-mode-status) (gnus-agent-make-mode-line-string " Plugged" 'mouse-2 - 'gnus-agent-toggle-plugged))) + '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) + (setcar (cdr gnus-agent-mode-status) (gnus-agent-make-mode-line-string " Unplugged" 'mouse-2 'gnus-agent-toggle-plugged))) - (set-buffer-modified-p t)) + (force-mode-line-update)) (defun gnus-agent-close-connections () "Close all methods covered by the Gnus agent." @@ -596,7 +628,9 @@ be a select method." "Write the alist of covered servers." (gnus-make-directory (nnheader-concat gnus-agent-directory "lib")) (let ((coding-system-for-write nnheader-file-coding-system) - (file-name-coding-system nnmail-pathname-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))))) @@ -659,16 +693,25 @@ 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. - (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))) + (let ((articles (mapcar (lambda (header) (mail-header-number header)) + gnus-newsgroup-headers)) + (agent-articles gnus-agent-article-alist) + candidates article) + (while (setq article (pop articles)) + (while (and agent-articles + (< (caar agent-articles) article)) + (setq agent-articles (cdr agent-articles))) + (when (or (not (cdar agent-articles)) + (not (= (caar agent-articles) article))) + (push article candidates))) + (dolist (article candidates) + (unless (or (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. (dolist (article gnus-newsgroup-downloadable) @@ -723,7 +766,8 @@ the actual number of articles toggled is returned." (funcall function nil new) (gnus-agent-write-active file new) (erase-buffer) - (nnheader-insert-file-contents 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)))) @@ -731,7 +775,8 @@ the actual number of articles toggled is returned." elem osym) (when (file-exists-p file) (with-temp-buffer - (nnheader-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) @@ -747,7 +792,7 @@ 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)) + (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)))) @@ -759,20 +804,20 @@ the actual number of articles toggled is returned." (when (gnus-agent-method-p method) (let* ((gnus-command-method method) (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 - ;; Emacs got problem to match non-ASCII group in multibyte buffer. - (mm-disable-multibyte) (when (file-exists-p file) (nnheader-insert-file-contents file)) (goto-char (point-min)) (when (re-search-forward (concat "^" (regexp-quote group) " ") nil t) - (save-excursion - (read (current-buffer)) ;; max + (save-excursion + (read (current-buffer)) ;; max (setq oactive-min (read (current-buffer)))) ;; min (gnus-delete-line)) (insert (format "%S %d %d y\n" (intern group) @@ -797,17 +842,11 @@ the actual number of articles toggled is returned." -(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 @@ -821,7 +860,6 @@ the actual number of articles toggled is returned." (format " *Gnus agent %s history*" (gnus-agent-method))))) gnus-agent-history-buffers) - (mm-disable-multibyte) ;; everything is binary (erase-buffer) (insert "\n") (let ((file (gnus-agent-lib-file "history"))) @@ -833,9 +871,9 @@ the actual number of articles toggled is returned." (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) @@ -921,33 +959,33 @@ the actual number of articles toggled is returned." (while pos (narrow-to-region (cdar pos) (or (cdadr pos) (point-max))) (goto-char (point-min)) - (when (search-forward "\n\n" nil t) - (when (search-backward "\nXrefs: " nil t) - ;; Handle crossposting. - (skip-chars-forward "^ ") - (skip-chars-forward " ") - (setq crosses nil) - (while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) +") - (push (cons (buffer-substring (match-beginning 1) - (match-end 1)) - (buffer-substring (match-beginning 2) - (match-end 2))) - crosses) - (goto-char (match-end 0))) - (gnus-agent-crosspost crosses (caar pos)))) - (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)))) - (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)) - (when (setq elem (assq (caar pos) gnus-agent-article-alist)) - (setcdr elem t)) - (gnus-agent-enter-history - id (or crosses (list (cons group (caar pos)))) date) + (unless (eobp) ;; Don't save empty articles. + (when (search-forward "\n\n" nil t) + (when (search-backward "\nXrefs: " nil t) + ;; Handle cross posting. + (skip-chars-forward "^ ") + (skip-chars-forward " ") + (setq crosses nil) + (while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) +") + (push (cons (buffer-substring (match-beginning 1) + (match-end 1)) + (buffer-substring (match-beginning 2) + (match-end 2))) + crosses) + (goto-char (match-end 0))) + (gnus-agent-crosspost crosses (caar pos)))) + (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)))) + (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 + id (or crosses (list (cons group (caar pos)))) date)) (widen) (pop pos))) (gnus-agent-save-alist group))))) @@ -983,12 +1021,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) @@ -997,12 +1035,20 @@ 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 (gnus-range-add articles (cdr arts)))) + (unless (memq (car arts) '(seen recent)) + (setq articles (gnus-range-add articles (cdr arts))))) (setq articles (sort (gnus-uncompress-sequence articles) '<)) ;; Remove known articles. (when (gnus-agent-load-alist group) @@ -1017,16 +1063,16 @@ the actual number of articles toggled is returned." (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" @@ -1037,14 +1083,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) @@ -1075,35 +1122,55 @@ 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))))) (defun gnus-agent-load-alist (group &optional dir) "Load the article-state alist for GROUP." - (setq gnus-agent-article-alist - (gnus-agent-read-file - (if dir - (expand-file-name ".agentview" dir) - (gnus-agent-article-name ".agentview" group))))) + (let ((file)) + (setq gnus-agent-article-alist + (gnus-cache-file-contents + (if dir + (expand-file-name ".agentview" dir) + (gnus-agent-article-name ".agentview" group)) + 'gnus-agent-file-loading-cache + 'gnus-agent-read-file)))) (defun gnus-agent-save-alist (group &optional articles state dir) "Save the article-state alist for GROUP." - (let ((file-name-coding-system nnmail-pathname-coding-system) - print-level print-length) - (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")))) + (let* ((file-name-coding-system nnmail-pathname-coding-system) + (pathname-coding-system nnmail-pathname-coding-system) + (prev (cons nil gnus-agent-article-alist)) + (all prev) + print-level print-length item article) + (while (setq article (pop articles)) + (while (and (cdr prev) + (< (caadr prev) article)) + (setq prev (cdr prev))) + (cond + ((not (cdr prev)) + (setcdr prev (list (cons article state)))) + ((> (caadr prev) article) + (setcdr prev (cons (cons article state) (cdr prev)))) + ((= (caadr prev) article) + (setcdr (cadr prev) state))) + (setq prev (cdr prev))) + (setq gnus-agent-article-alist (cdr all)) + (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) (expand-file-name (if (stringp article) article (string-to-number article)) @@ -1111,11 +1178,6 @@ the actual number of articles toggled is returned." (expand-file-name (gnus-agent-group-path group) (gnus-agent-directory))))) -(defun gnus-agent-batch-confirmation (msg) - "Show error message and return t." - (gnus-message 1 msg) - t) - ;;;###autoload (defun gnus-agent-batch-fetch () "Start Gnus and fetch session." @@ -1139,8 +1201,9 @@ the actual number of articles toggled is returned." (condition-case err (progn (setq gnus-command-method (car methods)) - (when (or (gnus-server-opened gnus-command-method) - (gnus-open-server gnus-command-method)) + (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)) @@ -1156,6 +1219,7 @@ the actual number of articles toggled is returned." 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) @@ -1243,7 +1307,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.") @@ -1378,7 +1449,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 () @@ -1415,7 +1486,7 @@ The following commands are available: (caddr info) (format "Editing the score expression for category %s" category) `(lambda (groups) - (setcar (cddr (assq ',category gnus-category-alist)) groups) + (setcar (nthcdr 2 (assq ',category gnus-category-alist)) groups) (gnus-category-write) (gnus-category-list))))) @@ -1571,16 +1642,20 @@ 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)) (when (file-exists-p (gnus-agent-lib-file "active")) (with-temp-buffer - (nnheader-insert-file-contents (gnus-agent-lib-file "active")) + (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 @@ -1597,7 +1672,19 @@ The following commands are available: (skip-chars-forward "^\t") (if (let ((fetch-date (read (current-buffer)))) (if (numberp fetch-date) - (> fetch-date day) + ;; 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 @@ -1632,8 +1719,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) @@ -1681,9 +1771,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)) @@ -1713,9 +1803,10 @@ The following commands are available: (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. + ;; 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)) @@ -1741,8 +1832,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 @@ -1751,8 +1841,310 @@ The following commands are available: (let ((init-file-user "") (gnus-always-read-dribble-file t)) (gnus)) - (gnus-group-send-queue) - (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-nov-file file (car articles))) + (nnheader-find-nov-line (car articles)) + (while (not (eobp)) + (when (looking-at "[0-9]") + (push (read (current-buffer)) cached-articles)) + (forward-line 1)) + (setq cached-articles (nreverse 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 (and (file-exists-p file) + (> (nth 7 (file-attributes file)) 0)) + (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)