X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-agent.el;h=d37bd7b16649dcc75ff5704f875df49c1c83f5d9;hb=a45dd507bf71d9e3fbfb6067896554323b02b643;hp=d5c901704fdf715c3c8c5b7d23f4d07b458ad33f;hpb=780dcfaaf2e442afee8514e1f2a247c3b97d3722;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index d5c9017..d37bd7b 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -1,6 +1,5 @@ -;;; gnus-agent.el --- unplugged support for Gnus -;; Copyright (C) 1997, 1998, 1999, 2000, 2001 -;; Free Software Foundation, Inc. +;;; gnus-agent.el --- unplugged support for Semi-gnus +;; Copyright (C) 1997,98 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; This file is part of GNU Emacs. @@ -28,15 +27,7 @@ (require 'gnus-cache) (require 'nnvirtual) (require 'gnus-sum) -(require 'gnus-score) -(eval-when-compile - (if (featurep 'xemacs) - (require 'itimer) - (require 'timer)) - (require 'cl)) - -(eval-and-compile - (autoload 'gnus-server-update-server "gnus-srvr")) +(eval-when-compile (require 'cl)) (defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/") "Where the Gnus agent will store its files." @@ -74,45 +65,20 @@ If nil, only read articles will be expired." :group 'gnus-agent :type 'hook) -;; Extracted from gnus-xmas-redefine in order to preserve user settings -(when (featurep 'xemacs) - (add-hook 'gnus-agent-group-mode-hook 'gnus-xmas-agent-group-menu-add)) - (defcustom gnus-agent-summary-mode-hook nil "Hook run in Agent summary minor modes." :group 'gnus-agent :type 'hook) -;; Extracted from gnus-xmas-redefine in order to preserve user settings -(when (featurep 'xemacs) - (add-hook 'gnus-agent-summary-mode-hook 'gnus-xmas-agent-summary-menu-add)) - (defcustom gnus-agent-server-mode-hook nil "Hook run in Agent summary minor modes." :group 'gnus-agent :type 'hook) -;; Extracted from gnus-xmas-redefine in order to preserve user settings -(when (featurep 'xemacs) - (add-hook 'gnus-agent-server-mode-hook 'gnus-xmas-agent-server-menu-add)) - -(defcustom gnus-agent-confirmation-function 'y-or-n-p - "Function to confirm when error happens." - :version "21.1" - :group 'gnus-agent - :type 'function) - -(defcustom gnus-agent-synchronize-flags 'ask - "Indicate if flags are synchronized when you plug in. -If this is `ask' the hook will query the user." - :version "21.1" - :type '(choice (const :tag "Always" t) - (const :tag "Never" nil) - (const :tag "Ask" ask)) - :group 'gnus-agent) - ;;; Internal variables +(defvar gnus-agent-meta-information-header "X-Gnus-Agent-Meta-Information") + (defvar gnus-agent-history-buffers nil) (defvar gnus-agent-buffer-alist nil) (defvar gnus-agent-article-alist nil) @@ -126,7 +92,7 @@ If this is `ask' the hook will query the user." (defvar gnus-agent-spam-hashtb nil) (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-coding-system 'no-conversion) ;; Dynamic variables (defvar gnus-headers) @@ -140,20 +106,12 @@ If this is `ask' the hook will query the user." (setq gnus-agent t) (gnus-agent-read-servers) (gnus-category-read) - (gnus-agent-create-buffer) + (setq gnus-agent-overview-buffer + (gnus-get-buffer-create " *Gnus agent overview*")) (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 - (mm-enable-multibyte)) - nil)) - (gnus-add-shutdown 'gnus-close-agent 'gnus) (defun gnus-close-agent () @@ -169,7 +127,7 @@ If this is `ask' the hook will query the user." (defun gnus-agent-read-file (file) "Load FILE and do a `read' there." - (with-temp-buffer + (nnheader-temp-write nil (ignore-errors (nnheader-insert-file-contents file) (goto-char (point-min)) @@ -188,17 +146,14 @@ If this is `ask' the hook will query the user." (defun gnus-agent-lib-file (file) "The full path of the Gnus agent library FILE." - (expand-file-name file - (file-name-as-directory - (expand-file-name "agent.lib" (gnus-agent-directory))))) + (concat (gnus-agent-directory) "agent.lib/" file)) ;;; 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)) - (gnus-agent-create-buffer)) + (setq gnus-agent-current-history (gnus-agent-history-buffer))) (defun gnus-agent-stop-fetch () "Save all data structures and clean up." @@ -212,7 +167,7 @@ If this is `ask' the hook will query the user." (defmacro gnus-agent-with-fetch (&rest forms) "Do FORMS safely." `(unwind-protect - (let ((gnus-agent-fetching t)) + (progn (gnus-agent-start-fetch) ,@forms) (gnus-agent-stop-fetch))) @@ -259,10 +214,8 @@ If this is `ask' the hook will query the user." "Jc" gnus-enter-category-buffer "Jj" gnus-agent-toggle-plugged "Js" gnus-agent-fetch-session - "JY" gnus-agent-synchronize-flags "JS" gnus-group-send-drafts - "Ja" gnus-agent-add-group - "Jr" gnus-agent-remove-group) + "Ja" gnus-agent-add-group) (defun gnus-agent-group-make-menu-bar () (unless (boundp 'gnus-agent-group-menu) @@ -316,7 +269,6 @@ 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) " Plugged")) (gnus-agent-close-connections) @@ -353,13 +305,13 @@ last form in your `.gnus.el' file: \(gnus-agentize) -This will modify the `gnus-setup-news-hook', and -`message-send-mail-function' variables, and install the Gnus agent -minor mode in all Gnus buffers." +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." (interactive) (gnus-open-agent) (add-hook 'gnus-setup-news-hook 'gnus-agent-queue-setup) - (unless gnus-agent-send-mail-function + (unless gnus-agent-send-mail-function (setq gnus-agent-send-mail-function message-send-mail-function message-send-mail-function 'gnus-agent-send-mail)) (unless gnus-agent-covered-methods @@ -382,11 +334,11 @@ minor mode in all Gnus buffers." (concat "^" (regexp-quote mail-header-separator) "\n")) (replace-match "\n") (gnus-agent-insert-meta-information 'mail) - (gnus-request-accept-article "nndraft:queue" nil t t))) + (gnus-request-accept-article "nndraft:queue"))) (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, then METHOD can +TYPE can be either `mail' or `news'. If the latter METHOD can be a select method." (save-excursion (message-remove-header gnus-agent-meta-information-header) @@ -398,43 +350,6 @@ be a select method." (while (search-backward "\n" nil t) (replace-match "\\n" t t)))) -(defun gnus-agent-restore-gcc () - "Restore GCC field from saved header." - (save-excursion - (goto-char (point-min)) - (while (re-search-forward (concat gnus-agent-gcc-header ":") nil t) - (replace-match "Gcc:" 'fixedcase)))) - -(defun gnus-agent-any-covered-gcc () - (save-restriction - (message-narrow-to-headers) - (let* ((gcc (mail-fetch-field "gcc" nil t)) - (methods (and gcc - (mapcar 'gnus-inews-group-method - (message-unquote-tokens - (message-tokenize-header - gcc " ,"))))) - covered) - (while (and (not covered) methods) - (setq covered - (member (car methods) gnus-agent-covered-methods) - methods (cdr methods))) - covered))) - -(defun gnus-agent-possibly-save-gcc () - "Save GCC if Gnus is unplugged." - (when (and (not gnus-plugged) (gnus-agent-any-covered-gcc)) - (save-excursion - (goto-char (point-min)) - (let ((case-fold-search t)) - (while (re-search-forward "^gcc:" nil t) - (replace-match (concat gnus-agent-gcc-header ":") 'fixedcase)))))) - -(defun gnus-agent-possibly-do-gcc () - "Do GCC if Gnus is plugged." - (when (or gnus-plugged (not (gnus-agent-any-covered-gcc))) - (gnus-inews-do-gcc))) - ;;; ;;; Group mode commands ;;; @@ -442,15 +357,11 @@ be a select method." (defun gnus-agent-fetch-groups (n) "Put all new articles in the current groups into the Agent." (interactive "P") - (unless gnus-plugged - (error "Groups can't be fetched when Gnus is unplugged")) (gnus-group-iterate n 'gnus-agent-fetch-group)) (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))) @@ -479,60 +390,6 @@ be a select method." (setf (cadddr cat) (nconc (cadddr cat) groups)) (gnus-category-write))) -(defun gnus-agent-remove-group (arg) - "Remove the current group from its agent category, if any." - (interactive "P") - (let (c) - (gnus-group-iterate arg - (lambda (group) - (when (cadddr (setq c (gnus-group-category group))) - (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 ;;; @@ -546,7 +403,6 @@ be a select method." (when (member method gnus-agent-covered-methods) (error "Server already in the agent program")) (push method gnus-agent-covered-methods) - (gnus-server-update-server server) (gnus-agent-write-servers) (message "Entered %s into the Agent" server))) @@ -560,7 +416,6 @@ be a select 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))) @@ -572,11 +427,8 @@ be a select method." (defun gnus-agent-write-servers () "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)) - (with-temp-file (nnheader-concat gnus-agent-directory "lib/servers") - (prin1 gnus-agent-covered-methods (current-buffer))))) + (nnheader-temp-write (nnheader-concat gnus-agent-directory "lib/servers") + (prin1 gnus-agent-covered-methods (current-buffer)))) ;;; ;;; Summary commands @@ -640,19 +492,12 @@ the actual number of articles toggled is returned." (when (and (not gnus-plugged) (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))) - ;; Then mark downloaded downloadable as not-downloadable, - ;; if you get my drift. - (dolist (article gnus-newsgroup-downloadable) - (when (cdr (assq article gnus-agent-article-alist)) - (setq gnus-newsgroup-downloadable - (delq article gnus-newsgroup-downloadable))))))) + (let ((articles gnus-newsgroup-unreads) + 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))))))) (defun gnus-agent-catchup () "Mark all undownloaded articles as read." @@ -668,86 +513,53 @@ the actual number of articles toggled is returned." ;;; (defun gnus-agent-save-active (method) - (gnus-agent-save-active-1 method 'gnus-active-to-gnus-format)) - -(defun gnus-agent-save-active-1 (method function) (when (gnus-agent-method-p method) (let* ((gnus-command-method method) - (new (gnus-make-hashtable (count-lines (point-min) (point-max)))) (file (gnus-agent-lib-file "active"))) - (funcall function nil new) - (gnus-agent-write-active file new) - (erase-buffer) - (nnheader-insert-file-contents file)))) - -(defun gnus-agent-write-active (file new) - (let ((orig (gnus-make-hashtable (count-lines (point-min) (point-max)))) - (file (gnus-agent-lib-file "active")) - elem osym) - (when (file-exists-p file) - (with-temp-buffer - (nnheader-insert-file-contents file) - (gnus-active-to-gnus-format nil orig)) - (mapatoms - (lambda (sym) - (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))) - (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)) - ;; The hashtable contains real names of groups, no more prefix - ;; removing, so set `full' to `t'. - (gnus-write-active-file file orig t)))) + (gnus-make-directory (file-name-directory file)) + (write-region-as-coding-system + gnus-agent-file-coding-system (point-min) (point-max) file nil 'silent) + (when (file-exists-p (gnus-agent-lib-file "groups")) + (delete-file (gnus-agent-lib-file "groups")))))) (defun gnus-agent-save-groups (method) - (gnus-agent-save-active-1 method 'gnus-groups-to-gnus-format)) + (let* ((gnus-command-method method) + (file (gnus-agent-lib-file "groups"))) + (gnus-make-directory (file-name-directory file)) + (write-region-as-coding-system + gnus-agent-file-coding-system (point-min) (point-max) file nil 'silent) + (when (file-exists-p (gnus-agent-lib-file "active")) + (delete-file (gnus-agent-lib-file "active"))))) (defun gnus-agent-save-group-info (method group active) (when (gnus-agent-method-p method) (let* ((gnus-command-method method) - (coding-system-for-write nnheader-file-coding-system) - (file-name-coding-system nnmail-pathname-coding-system) - (file (gnus-agent-lib-file "active")) - oactive) + (file (if nntp-server-list-active-group + (gnus-agent-lib-file "active") + (gnus-agent-lib-file "groups")))) (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) + (nnheader-temp-write file (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 - (save-restriction - (narrow-to-region (match-beginning 0) - (progn - (forward-line 1) - (point))) - (setq oactive (car (nnmail-parse-active))))) - (gnus-delete-line)) - (insert (format "%S %d %d y\n" (intern group) - (cdr active) - (or (car oactive) (car active)))) - (goto-char (point-max)) - (while (search-backward "\\." nil t) - (delete-char 1)))))) + (if nntp-server-list-active-group + (progn + (when (re-search-forward + (concat "^" (regexp-quote group) " ") nil t) + (gnus-delete-line)) + (insert group " " (number-to-string (cdr active)) " " + (number-to-string (car active)) " y\n")) + (when (re-search-forward (concat (regexp-quote group) " ") nil t) + (gnus-delete-line)) + (insert-buffer-substring nntp-server-buffer)))))) (defun gnus-agent-group-path (group) "Translate GROUP into a path." (if nnmail-use-long-file-names (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) - ?/ ?_) - ?. ?_) - ?. ?/)))) + (nnheader-replace-chars-in-string + (nnheader-translate-file-chars (gnus-group-real-name group)) + ?. ?/))) @@ -775,21 +587,20 @@ the actual number of articles toggled is returned." (format " *Gnus agent %s history*" (gnus-agent-method))))) gnus-agent-history-buffers) - (mm-disable-multibyte) ;; everything is binary (erase-buffer) (insert "\n") (let ((file (gnus-agent-lib-file "history"))) (when (file-exists-p file) - (nnheader-insert-file-contents file)) + (insert-file file)) (set (make-local-variable 'gnus-agent-file-name) file)))) (defun gnus-agent-save-history () (save-excursion (set-buffer gnus-agent-current-history) (gnus-make-directory (file-name-directory gnus-agent-file-name)) - (let ((coding-system-for-write gnus-agent-file-coding-system)) - (write-region (1+ (point-min)) (point-max) - gnus-agent-file-name nil 'silent)))) + (write-region-as-coding-system + gnus-agent-file-coding-system + (1+ (point-min)) (point-max) gnus-agent-file-name nil 'silent))) (defun gnus-agent-close-history () (when (gnus-buffer-live-p gnus-agent-current-history) @@ -802,15 +613,11 @@ the actual number of articles toggled is returned." (save-excursion (set-buffer gnus-agent-current-history) (goto-char (point-max)) - (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))))) + (insert id "\t" (number-to-string date) "\t") + (while group-arts + (insert (caar group-arts) " " (number-to-string (cdr (pop group-arts))) + " ")) + (insert "\n"))) (defun gnus-agent-article-in-history-p (id) (save-excursion @@ -849,7 +656,7 @@ the actual number of articles toggled is returned." (let ((dir (concat (gnus-agent-directory) (gnus-agent-group-path group) "/")) - (date (time-to-days (current-time))) + (date (gnus-time-to-day (current-time))) (case-fold-search t) pos crosses id elem) (gnus-make-directory dir) @@ -857,13 +664,10 @@ the actual number of articles toggled is returned." ;; Fetch the articles from the backend. (if (gnus-check-backend-function 'retrieve-articles group) (setq pos (gnus-retrieve-articles articles group)) - (with-temp-buffer + (nnheader-temp-write nil (let (article) (while (setq article (pop articles)) - (when (or - (gnus-backlog-request-article group article - nntp-server-buffer) - (gnus-request-article article group)) + (when (gnus-request-article article group) (goto-char (point-max)) (push (cons article (point)) pos) (insert-buffer-substring nntp-server-buffer))) @@ -893,11 +697,10 @@ the actual number of articles toggled is returned." (if (not (re-search-forward "^Message-ID: *<\\([^>\n]+\\)>" nil t)) (setq id "No-Message-ID-in-article") (setq id (buffer-substring (match-beginning 1) (match-end 1)))) - (let ((coding-system-for-write - gnus-agent-file-coding-system)) - (write-region (point-min) (point-max) - (concat dir (number-to-string (caar pos))) - nil 'silent)) + (write-region-as-coding-system + gnus-agent-file-coding-system + (point-min) (point-max) + (concat dir (number-to-string (caar pos))) nil 'silent) (when (setq elem (assq (caar pos) gnus-agent-article-alist)) (setcdr elem t)) (gnus-agent-enter-history @@ -922,7 +725,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 @@ -937,57 +740,51 @@ 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) + (nnheader-temp-write (caar gnus-agent-group-alist) (princ (cdar gnus-agent-group-alist)) (insert "\n")) (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. - (dolist (arts (gnus-info-marks (gnus-get-info group))) - (setq articles (gnus-union (gnus-uncompress-sequence (cdr arts)) - articles))) - (setq articles (sort articles '<)) - ;; Remove known articles. - (when (gnus-agent-load-alist group) - (setq articles (gnus-sorted-intersection - articles - (gnus-uncompress-range - (cons (1+ (caar (last gnus-agent-article-alist))) - (cdr (gnus-active group))))))) + (let ((articles (if (gnus-agent-load-alist group) + (gnus-sorted-intersection + (gnus-list-of-unread-articles group) + (gnus-uncompress-range + (cons (1+ (caar (last gnus-agent-article-alist))) + (cdr (gnus-active group))))) + (gnus-list-of-unread-articles group)))) ;; Fetch them. - (gnus-make-directory (nnheader-translate-file-chars - (file-name-directory file) t)) (when articles (gnus-message 7 "Fetching headers for %s..." group) (save-excursion - (set-buffer nntp-server-buffer) - (unless (eq 'nov (gnus-retrieve-headers articles group)) - (nnvirtual-convert-headers)) - ;; Save these headers for later processing. - (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) - (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)) - (gnus-agent-save-alist group articles nil) - (gnus-agent-enter-history - "last-header-fetched-for-session" - (list (cons group (nth (- (length articles) 1) articles))) - (time-to-days (current-time))) - articles)))) + (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)) + (let (file) + (when (file-exists-p + (setq file (gnus-agent-article-name ".overview" group))) + (gnus-agent-braid-nov group articles file)) + (gnus-make-directory (nnheader-translate-file-chars + (file-name-directory file))) + (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" + (list (cons group (nth (- (length articles) 1) articles))) + (gnus-time-to-day (current-time))) + articles))))) (defsubst gnus-agent-copy-nov-line (article) (let (b e) @@ -1043,40 +840,31 @@ the actual number of articles toggled is returned." (setq gnus-agent-article-alist (gnus-agent-read-file (if dir - (expand-file-name ".agentview" dir) + (concat dir ".agentview") (gnus-agent-article-name ".agentview" group))))) (defun gnus-agent-save-alist (group &optional articles state dir) "Save the article-state alist for GROUP." - (let ((file-name-coding-system nnmail-pathname-coding-system)) - (with-temp-file (if dir - (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")))) + (nnheader-temp-write (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"))) (defun gnus-agent-article-name (article group) - (expand-file-name (if (stringp article) article (string-to-number article)) - (file-name-as-directory - (expand-file-name (gnus-agent-group-path group) - (gnus-agent-directory))))) - -(defun gnus-agent-batch-confirmation (msg) - "Show error message and return t." - (gnus-message 1 msg) - t) + (concat (gnus-agent-directory) (gnus-agent-group-path group) "/" + (if (stringp article) article (string-to-number article)))) ;;;###autoload (defun gnus-agent-batch-fetch () "Start Gnus and fetch session." (interactive) (gnus) - (let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation)) - (gnus-agent-fetch-session)) + (gnus-agent-fetch-session) (gnus-group-exit)) (defun gnus-agent-fetch-session () @@ -1090,88 +878,51 @@ the actual number of articles toggled is returned." groups group gnus-command-method) (save-excursion (while methods - (condition-case err - (progn - (setq gnus-command-method (car methods)) - (when (or (gnus-server-opened gnus-command-method) - (gnus-open-server gnus-command-method)) - (setq groups (gnus-groups-from-server (car methods))) - (gnus-agent-with-fetch - (while (setq group (pop groups)) - (when (<= (gnus-group-level group) gnus-agent-handle-level) - (gnus-agent-fetch-group-1 group gnus-command-method)))))) - (error - (unless (funcall gnus-agent-confirmation-function - (format "Error (%s). Continue? " err)) - (error "Cannot fetch articles into the Gnus agent."))) - (quit - (unless (funcall gnus-agent-confirmation-function - (format "Quit fetching session (%s). Continue? " - err)) - (signal 'quit "Cannot fetch articles into the Gnus agent.")))) + (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))))) (pop methods)) (gnus-message 6 "Finished fetching articles into the Gnus agent")))) (defun gnus-agent-fetch-group-1 (group method) "Fetch GROUP." (let ((gnus-command-method method) - (gnus-newsgroup-name group) gnus-newsgroup-dependencies gnus-newsgroup-headers gnus-newsgroup-scored gnus-headers gnus-score gnus-use-cache articles arts - 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)) + category predicate info marks score-param) ;; Fetch headers. (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 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)) + (setq gnus-newsgroup-headers + (gnus-get-newsgroup-headers-xover articles nil nil group)) (setq category (gnus-group-category group)) (setq predicate - (gnus-get-predicate - (or (gnus-group-find-parameter group 'agent-predicate t) + (gnus-get-predicate + (or (gnus-group-get-parameter group 'agent-predicate) (cadr category)))) - (if (memq (caaddr predicate) '(gnus-agent-true gnus-agent-false)) - ;; Simple implementation - (setq arts - (and (eq (caaddr predicate) 'gnus-agent-true) articles)) - (setq arts nil) - (setq score-param - (or (gnus-group-get-parameter group 'agent-score t) - (caddr category))) - ;; Translate score-param into real one - (cond - ((not score-param)) - ((eq score-param 'file) - (setq score-param (gnus-all-score-files group))) - ((stringp (car score-param))) - (t - (setq score-param (list (list score-param))))) - (when score-param - (gnus-score-headers score-param)) - (while (setq gnus-headers (pop gnus-newsgroup-headers)) - (setq gnus-score - (or (cdr (assq (mail-header-number gnus-headers) - gnus-newsgroup-scored)) - gnus-summary-default-score)) - (when (funcall predicate) - (push (mail-header-number gnus-headers) - arts)))) + (setq score-param + (or (gnus-group-get-parameter group 'agent-score) + (caddr category))) + (when score-param + (gnus-score-headers (list (list score-param)))) + (setq arts nil) + (while (setq gnus-headers (pop gnus-newsgroup-headers)) + (setq gnus-score + (or (cdr (assq (mail-header-number gnus-headers) + gnus-newsgroup-scored)) + gnus-summary-default-score)) + (when (funcall predicate) + (push (mail-header-number gnus-headers) + arts))) ;; Fetch the articles. (when arts (gnus-agent-fetch-articles group arts))) @@ -1182,11 +933,7 @@ the actual number of articles toggled is returned." (gnus-agent-fetch-articles group (gnus-uncompress-range (cdr arts))) (setq marks (delq arts (gnus-info-marks info))) - (gnus-info-set-marks info marks) - (gnus-dribble-enter - (concat "(gnus-group-set-info '" - (gnus-prin1-to-string info) - ")"))))) + (gnus-info-set-marks info marks)))) ;;; ;;; Agent Category Mode @@ -1288,7 +1035,7 @@ The following commands are available: (gnus-set-default-directory) (setq mode-line-process nil) (use-local-map gnus-category-mode-map) - (buffer-disable-undo) + (buffer-disable-undo (current-buffer)) (setq truncate-lines t) (setq buffer-read-only t) (gnus-run-hooks 'gnus-category-mode-hook)) @@ -1340,13 +1087,12 @@ The following commands are available: (or (gnus-agent-read-file (nnheader-concat gnus-agent-directory "lib/categories")) (list (list 'default 'short nil nil))))) - + (defun gnus-category-write () "Write the category alist." (setq gnus-category-predicate-cache nil gnus-category-group-cache nil) - (gnus-make-directory (nnheader-concat gnus-agent-directory "lib")) - (with-temp-file (nnheader-concat gnus-agent-directory "lib/categories") + (nnheader-temp-write (nnheader-concat gnus-agent-directory "lib/categories") (prin1 gnus-category-alist (current-buffer)))) (defun gnus-category-edit-predicate (category) @@ -1356,10 +1102,10 @@ The following commands are available: (gnus-edit-form (cadr info) (format "Editing the predicate for category %s" category) `(lambda (predicate) - (setcar (cdr (assq ',category gnus-category-alist)) predicate) + (setf (cadr (assq ',category gnus-category-alist)) predicate) (gnus-category-write) (gnus-category-list))))) - + (defun gnus-category-edit-score (category) "Edit the score expression for CATEGORY." (interactive (list (gnus-category-name))) @@ -1368,7 +1114,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) + (setf (caddr (assq ',category gnus-category-alist)) groups) (gnus-category-write) (gnus-category-list))))) @@ -1379,7 +1125,7 @@ The following commands are available: (gnus-edit-form (cadddr info) (format "Editing the group list for category %s" category) `(lambda (groups) - (setcar (nthcdr 3 (assq ',category gnus-category-alist)) groups) + (setf (cadddr (assq ',category gnus-category-alist)) groups) (gnus-category-write) (gnus-category-list))))) @@ -1389,8 +1135,8 @@ The following commands are available: (let ((info (assq category gnus-category-alist)) (buffer-read-only nil)) (gnus-delete-line) - (setq gnus-category-alist (delq info gnus-category-alist)) - (gnus-category-write))) + (gnus-category-write) + (setq gnus-category-alist (delq info gnus-category-alist)))) (defun gnus-category-copy (category to) "Copy the current category." @@ -1407,7 +1153,7 @@ The following commands are available: (interactive "SCategory name: ") (when (assq category gnus-category-alist) (error "Category %s already exists" category)) - (push (list category 'false nil nil) + (push (list category 'true nil nil) gnus-category-alist) (gnus-category-write) (gnus-category-list)) @@ -1474,7 +1220,7 @@ The following commands are available: (defun gnus-agent-false () "Return nil." nil) - + (defun gnus-category-make-function-1 (cat) "Make a function from category CAT." (cond @@ -1520,179 +1266,143 @@ 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 (- (gnus-time-to-day (current-time)) gnus-agent-expire-days)) 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) (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")) - (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) - (> fetch-date day) - ;; History file is corrupted. - (gnus-message - 5 - (format "File %s is corrupted!" - (gnus-agent-lib-file "history"))) - (sit-for 1) - ;; Ignore it - t)) - ;; New article; we don't expire it. - (forward-line 1) - ;; Old article. Schedule it for possible nuking. - (while (not (eolp)) - (setq sym (let ((obarray expiry-hashtb) 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))))) - 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)) - (let ((coding-system-for-write - gnus-agent-file-coding-system)) - (write-region (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"))))))) + (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)) + (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)) + (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)) + ;;; 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 (car 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) + ")")))) + 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-message 4 "Expiry...done")))))) ;;;###autoload (defun gnus-agent-batch ()