X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-agent.el;h=57f0f59ea13b4f500cabc0b786cb9771d2af7895;hb=09868cf7efbfa51562d76580eafc9a7b6b0c8d72;hp=853c0ca5b46b8e76b1fbf0eb26d119ce500ee069;hpb=97063e29f85dc31ea55a1483a6dbe97028d9a419;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index 853c0ca..57f0f59 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -1,9 +1,7 @@ ;;; gnus-agent.el --- unplugged support for Gnus -;; Copyright (C) 1997 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; Keywords: news +;; Copyright (C) 1997,98,99 Free Software Foundation, Inc. +;; Author: Lars Magne Ingebrigtsen ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify @@ -29,7 +27,9 @@ (require 'gnus-cache) (require 'nnvirtual) (require 'gnus-sum) -(eval-when-compile (require 'cl)) +(eval-when-compile + (require 'cl) + (require 'gnus-score)) (defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/") "Where the Gnus agent will store its files." @@ -46,6 +46,37 @@ :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." + :group 'gnus-agent + :type 'integer) + +(defcustom gnus-agent-expire-all nil + "If non-nil, also expire unread, ticked and dormant articles. +If nil, only read articles will be expired." + :group 'gnus-agent + :type 'boolean) + +(defcustom gnus-agent-group-mode-hook nil + "Hook run in Agent group minor modes." + :group 'gnus-agent + :type 'hook) + +(defcustom gnus-agent-summary-mode-hook nil + "Hook run in Agent summary minor modes." + :group 'gnus-agent + :type 'hook) + +(defcustom gnus-agent-server-mode-hook nil + "Hook run in Agent summary minor modes." + :group 'gnus-agent + :type 'hook) + ;;; Internal variables (defvar gnus-agent-history-buffers nil) @@ -61,7 +92,11 @@ (defvar gnus-agent-spam-hashtb nil) (defvar gnus-agent-file-name nil) (defvar gnus-agent-send-mail-function nil) -(defvar gnus-agent-article-file-coding-system 'no-conversion) +(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) @@ -76,7 +111,9 @@ (gnus-agent-read-servers) (gnus-category-read) (setq gnus-agent-overview-buffer - (get-buffer-create " *Gnus agent overview*")) + (gnus-get-buffer-create " *Gnus agent overview*")) + (with-current-buffer gnus-agent-overview-buffer + (mm-enable-multibyte)) (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)) @@ -96,9 +133,9 @@ (defun gnus-agent-read-file (file) "Load FILE and do a `read' there." - (nnheader-temp-write nil + (with-temp-buffer (ignore-errors - (insert-file-contents file) + (mm-insert-file-contents file) (goto-char (point-min)) (read (current-buffer))))) @@ -110,7 +147,8 @@ (defsubst gnus-agent-directory () "Path of the Gnus agent directory." - (nnheader-concat gnus-agent-directory (gnus-agent-method) "/")) + (nnheader-concat gnus-agent-directory + (nnheader-translate-file-chars (gnus-agent-method)) "/")) (defun gnus-agent-lib-file (file) "The full path of the Gnus agent library FILE." @@ -171,17 +209,20 @@ (push (cons mode (symbol-value (intern (format "gnus-agent-%s-mode-map" buffer)))) minor-mode-map-alist)) - (gnus-agent-toggle-plugged gnus-plugged) - (run-hooks 'gnus-agent-mode-hook))) + (when (eq major-mode 'gnus-group-mode) + (gnus-agent-toggle-plugged gnus-plugged)) + (gnus-run-hooks 'gnus-agent-mode-hook + (intern (format "gnus-agent-%s-mode-hook" buffer))))) (defvar gnus-agent-group-mode-map (make-sparse-keymap)) (gnus-define-keys gnus-agent-group-mode-map - "Ju" gnus-agent-fetch-group + "Ju" gnus-agent-fetch-groups "Jc" gnus-enter-category-buffer "Jj" gnus-agent-toggle-plugged "Js" gnus-agent-fetch-session "JS" gnus-group-send-drafts - "Ja" gnus-agent-add-group) + "Ja" gnus-agent-add-group + "Jr" gnus-agent-remove-group) (defun gnus-agent-group-make-menu-bar () (unless (boundp 'gnus-agent-group-menu) @@ -234,12 +275,13 @@ (interactive (list (not gnus-plugged))) (if plugged (progn - (run-hooks 'gnus-agent-plugged-hook) + (setq gnus-plugged plugged) + (gnus-run-hooks 'gnus-agent-plugged-hook) (setcar (cdr gnus-agent-mode-status) " Plugged")) (gnus-agent-close-connections) - (run-hooks 'gnus-agent-unplugged-hook) + (setq gnus-plugged plugged) + (gnus-run-hooks 'gnus-agent-unplugged-hook) (setcar (cdr gnus-agent-mode-status) " Unplugged")) - (setq gnus-plugged plugged) (set-buffer-modified-p t)) (defun gnus-agent-close-connections () @@ -256,6 +298,13 @@ (gnus)) ;;;###autoload +(defun gnus-plugged () + "Start Gnus plugged." + (interactive) + (setq gnus-plugged t) + (gnus)) + +;;;###autoload (defun gnus-agentize () "Allow Gnus to be an offline newsreader. The normal usage of this command is to put the following as the @@ -269,7 +318,7 @@ 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 @@ -291,15 +340,39 @@ agent minor mode in all Gnus buffers." (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n")) (replace-match "\n") - (gnus-request-accept-article "nndraft:queue"))) + (gnus-agent-insert-meta-information 'mail) + (gnus-request-accept-article "nndraft:queue" nil t t))) + +(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 +be a select method." + (save-excursion + (message-remove-header gnus-agent-meta-information-header) + (goto-char (point-min)) + (insert gnus-agent-meta-information-header ": " + (symbol-name type) " " (format "%S" method) + "\n") + (forward-char -1) + (while (search-backward "\n" nil t) + (replace-match "\\n" t t)))) ;;; ;;; Group mode commands ;;; +(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." + "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))) @@ -328,6 +401,16 @@ agent minor mode in all Gnus buffers." (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))) + ;;; ;;; Server mode commands ;;; @@ -342,7 +425,7 @@ agent minor mode in all Gnus buffers." (error "Server already in the agent program")) (push method gnus-agent-covered-methods) (gnus-agent-write-servers) - (message "Entered %s into the agent" server))) + (message "Entered %s into the Agent" server))) (defun gnus-agent-remove-server (server) "Remove SERVER from the agent program." @@ -365,7 +448,8 @@ agent minor mode in all Gnus buffers." (defun gnus-agent-write-servers () "Write the alist of covered servers." - (nnheader-temp-write (nnheader-concat gnus-agent-directory "lib/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)))) ;;; @@ -378,7 +462,6 @@ If N is negative, mark backward instead. If UNMARK is non-nil, remove the mark instead. The difference between N and the actual number of articles marked is returned." (interactive "p") - (gnus-set-global-variables) (let ((backward (< n 0)) (n (abs n))) (while (and @@ -399,7 +482,6 @@ articles marked is returned." If N is negative, unmark backward instead. The difference between N and the actual number of articles unmarked is returned." (interactive "p") - (gnus-set-global-variables) (gnus-agent-mark-article n t)) (defun gnus-agent-toggle-mark (n) @@ -407,7 +489,6 @@ the actual number of articles unmarked is returned." If N is negative, toggle backward instead. The difference between N and the actual number of articles toggled is returned." (interactive "p") - (gnus-set-global-variables) (gnus-agent-mark-article n 'toggle)) (defun gnus-summary-set-agent-mark (article &optional unmark) @@ -415,9 +496,13 @@ the actual number of articles toggled is returned." (let ((unmark (if (and (not (null unmark)) (not (eq t unmark))) (memq article gnus-newsgroup-downloadable) unmark))) - (setq gnus-newsgroup-downloadable - (delq article gnus-newsgroup-downloadable)) - (unless unmark + (if unmark + (progn + (setq gnus-newsgroup-downloadable + (delq article gnus-newsgroup-downloadable)) + (push article gnus-newsgroup-undownloaded)) + (setq gnus-newsgroup-undownloaded + (delq article gnus-newsgroup-undownloaded)) (push article gnus-newsgroup-downloadable)) (gnus-summary-update-mark (if unmark gnus-undownloaded-mark gnus-downloadable-mark) @@ -429,12 +514,23 @@ 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) - (let ((articles gnus-newsgroup-unreads) + ;; 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))))))) + (memq article gnus-newsgroup-downloadable)) + (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)))))))) (defun gnus-agent-catchup () "Mark all undownloaded articles as read." @@ -450,27 +546,62 @@ 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"))) - (gnus-make-directory (file-name-directory file)) - (let ((coding-system-for-write gnus-agent-article-file-coding-system)) - (write-region (point-min) (point-max) file nil 'silent)) - (when (file-exists-p (gnus-agent-lib-file "groups")) - (delete-file (gnus-agent-lib-file "groups")))))) + (funcall function nil new) + (gnus-agent-write-active file new) + (erase-buffer) + (insert-file-contents-literally 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) + (when (file-exists-p file) + (with-temp-buffer + (insert-file-contents file) + (gnus-active-to-gnus-format nil orig)) + (mapatoms + (lambda (sym) + (when (and sym (boundp sym)) + (if (setq elem (symbol-value (intern (symbol-name sym) orig))) + (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)) + (gnus-write-active-file file orig)))) (defun gnus-agent-save-groups (method) - (let* ((gnus-command-method method) - (file (gnus-agent-lib-file "groups"))) - (gnus-make-directory (file-name-directory file)) - (write-region (point-min) (point-max) file nil 'silent)) - (when (file-exists-p (gnus-agent-lib-file "active")) - (delete-file (gnus-agent-lib-file "active")))) + (gnus-agent-save-active-1 method 'gnus-groups-to-gnus-format)) + +(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"))) + (gnus-make-directory (file-name-directory file)) + (with-temp-file file + (when (file-exists-p file) + (mm-insert-file-contents file)) + (goto-char (point-min)) + (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"))))) (defun gnus-agent-group-path (group) "Translate GROUP into a path." - (nnheader-translate-file-chars - (nnheader-replace-chars-in-string group ?. ?/))) + (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)) + ?. ?/))) @@ -494,7 +625,7 @@ the actual number of articles toggled is returned." (defun gnus-agent-open-history () (save-excursion (push (cons (gnus-agent-method) - (set-buffer (get-buffer-create + (set-buffer (gnus-get-buffer-create (format " *Gnus agent %s history*" (gnus-agent-method))))) gnus-agent-history-buffers) @@ -509,8 +640,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)) - (write-region (1+ (point-min)) (point-max) - gnus-agent-file-name nil 'silent))) + (let ((coding-system-for-write gnus-agent-file-coding-system)) + (write-region (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) @@ -525,7 +657,7 @@ the actual number of articles toggled is returned." (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 (caar group-arts) " " (number-to-string (cdr (pop group-arts))) " ")) (insert "\n"))) @@ -551,12 +683,12 @@ the actual number of articles toggled is returned." ;;; (defun gnus-agent-fetch-articles (group articles) - "Fetch ARTICLES from GROUP and put them into the agent." + "Fetch ARTICLES from GROUP and put them into the Agent." (when articles ;; 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)) @@ -566,17 +698,16 @@ the actual number of articles toggled is returned." (let ((dir (concat (gnus-agent-directory) (gnus-agent-group-path group) "/")) - (date (gnus-time-to-day (current-time))) + (date (time-to-days (current-time))) (case-fold-search t) - pos alists crosses id elem) + pos crosses id elem) (gnus-make-directory dir) (gnus-message 7 "Fetching articles for %s..." group) ;; Fetch the articles from the backend. (if (gnus-check-backend-function 'retrieve-articles group) (setq pos (gnus-retrieve-articles articles group)) - (nnheader-temp-write nil - (let ((buf (current-buffer)) - article) + (with-temp-buffer + (let (article) (while (setq article (pop articles)) (when (gnus-request-article article group) (goto-char (point-max)) @@ -584,7 +715,7 @@ the actual number of articles toggled is returned." (insert-buffer-substring nntp-server-buffer))) (copy-to-buffer nntp-server-buffer (point-min) (point-max)) (setq pos (nreverse pos))))) - ;; Then save these articles into the agent. + ;; Then save these articles into the Agent. (save-excursion (set-buffer nntp-server-buffer) (while pos @@ -608,9 +739,11 @@ 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)))) - (write-region (point-min) (point-max) - (concat dir (number-to-string (caar pos))) - nil 'silent) + (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 @@ -634,12 +767,12 @@ the actual number of articles toggled is returned." gnus-agent-group-alist)) (setcdr alist (cons (cons (cdar crosses) t) (cdr alist))) (save-excursion - (set-buffer (get-buffer-create (format " *Gnus agent overview %s*" + (set-buffer (gnus-get-buffer-create (format " *Gnus agent overview %s*" group))) (when (= (point-max) (point-min)) (push (cons group (current-buffer)) gnus-agent-buffer-alist) (ignore-errors - (insert-file-contents + (mm-insert-file-contents (gnus-agent-article-name ".overview" group)))) (nnheader-find-nov-line (string-to-number (cdar crosses))) (insert (string-to-number (cdar crosses))) @@ -650,46 +783,57 @@ the actual number of articles toggled is returned." (save-excursion (while gnus-agent-buffer-alist (set-buffer (cdar gnus-agent-buffer-alist)) - (write-region (point-min) (point-max) - (gnus-agent-article-name ".overview" - (caar gnus-agent-buffer-alist)) - nil 'silent) + (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)) (pop gnus-agent-buffer-alist)) (while gnus-agent-group-alist - (nnheader-temp-write (caar gnus-agent-group-alist) + (with-temp-file (caar gnus-agent-group-alist) (princ (cdar gnus-agent-group-alist)) (insert "\n")) (pop gnus-agent-group-alist)))) -(defun gnus-agent-fetch-headers (group articles &optional force) - (gnus-agent-load-alist group) - ;; Find out what headers we need to retrieve. - (when articles - (while (and articles - (assq (car articles) gnus-agent-article-alist)) - (pop articles)) - (let ((arts articles)) - (while (cdr arts) - (if (assq (cadr arts) gnus-agent-article-alist) - (setcdr arts (cddr arts)) - (setq arts (cdr arts))))) +(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 (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))))))) ;; Fetch them. + (gnus-make-directory (nnheader-translate-file-chars + (file-name-directory file))) (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)) - (let (file) - (when (file-exists-p - (setq file (gnus-agent-article-name ".overview" group))) - (gnus-agent-braid-nov group articles file)) - (gnus-make-directory (file-name-directory file)) - (write-region (point-min) (point-max) file nil 'silent) - (gnus-agent-save-alist group articles nil)) - t)))) + (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)))) (defsubst gnus-agent-copy-nov-line (article) (let (b e) @@ -697,47 +841,48 @@ the actual number of articles toggled is returned." (setq b (point)) (if (eq article (read (current-buffer))) (setq e (progn (forward-line 1) (point))) - (setq e b)) + (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) - (let (beg end) - (set-buffer gnus-agent-overview-buffer) - (goto-char (point-min)) - (set-buffer nntp-server-buffer) - (erase-buffer) - (insert-file-contents file) - (goto-char (point-min)) - (if (or (= (point-min) (point-max)) - (progn - (forward-line -1) - (< (read (current-buffer)) (car articles)))) - ;; We have only headers that are after the older headers, - ;; so we just append them. - (progn - (goto-char (point-max)) - (insert-buffer-substring gnus-agent-overview-buffer)) - ;; We do it the hard way. - (nnheader-find-nov-line (car articles)) - (gnus-agent-copy-nov-line (car articles)) - (pop articles) - (while (and articles - (not (eobp))) - (while (and (not (eobp)) - (< (read (current-buffer)) (car articles))) - (forward-line 1)) - (beginning-of-line) - (unless (eobp) - (gnus-agent-copy-nov-line (car articles)) - (setq articles (cdr articles)))) - (when articles - (let (b e) - (set-buffer gnus-agent-overview-buffer) - (setq b (point) - e (point-max)) - (set-buffer nntp-server-buffer) - (insert-buffer-substring gnus-agent-overview-buffer b e)))))) + (set-buffer gnus-agent-overview-buffer) + (goto-char (point-min)) + (set-buffer nntp-server-buffer) + (erase-buffer) + (mm-insert-file-contents file) + (goto-char (point-max)) + (if (or (= (point-min) (point-max)) + (progn + (forward-line -1) + (< (read (current-buffer)) (car articles)))) + ;; We have only headers that are after the older headers, + ;; so we just append them. + (progn + (goto-char (point-max)) + (insert-buffer-substring gnus-agent-overview-buffer)) + ;; We do it the hard way. + (nnheader-find-nov-line (car articles)) + (gnus-agent-copy-nov-line (car articles)) + (pop articles) + (while (and articles + (not (eobp))) + (while (and (not (eobp)) + (< (read (current-buffer)) (car articles))) + (forward-line 1)) + (beginning-of-line) + (unless (eobp) + (gnus-agent-copy-nov-line (car articles)) + (setq articles (cdr articles)))) + (when articles + (let (b e) + (set-buffer gnus-agent-overview-buffer) + (setq b (point) + e (point-max)) + (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." @@ -748,10 +893,10 @@ the actual number of articles toggled is returned." (gnus-agent-article-name ".agentview" group))))) (defun gnus-agent-save-alist (group &optional articles state dir) - "Load the article-state alist for GROUP." - (nnheader-temp-write (if dir - (concat dir ".agentview") - (gnus-agent-article-name ".agentview" group)) + "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)) @@ -782,47 +927,89 @@ the actual number of articles toggled is returned." groups group gnus-command-method) (save-excursion (while methods - (setq gnus-command-method (car methods) - groups (gnus-groups-from-server (pop methods))) - (gnus-agent-with-fetch - (while (setq group (pop groups)) - (gnus-agent-fetch-group-1 group gnus-command-method)))) + (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 score arts + gnus-use-cache articles arts category predicate info marks score-param) ;; Fetch headers. - (when (and (setq articles (gnus-list-of-unread-articles group)) - (gnus-agent-fetch-headers group articles)) + (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)) - (setq gnus-newsgroup-headers - (gnus-get-newsgroup-headers-xover articles nil nil group)) + ;; No need to call `gnus-get-newsgroup-headers-xover' with + ;; the entire .overview for group as we still have the just + ;; downloaded headers in `gnus-agent-overview-buffer'. + (let ((nntp-server-buffer gnus-agent-overview-buffer)) + (setq gnus-newsgroup-headers + (gnus-get-newsgroup-headers-xover articles nil nil group))) (setq category (gnus-group-category group)) (setq predicate - (gnus-get-predicate - (or (gnus-group-get-parameter group 'agent-predicate) + (gnus-get-predicate + (or (gnus-group-get-parameter group 'agent-predicate t) (cadr category)))) - (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))) + ;; 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. + (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))))))) + (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) + 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))) @@ -833,7 +1020,11 @@ 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-info-set-marks info marks) + (gnus-dribble-enter + (concat "(gnus-group-set-info '" + (gnus-prin1-to-string info) + ")"))))) ;;; ;;; Agent Category Mode @@ -866,8 +1057,8 @@ the actual number of articles toggled is returned." (defvar gnus-category-buffer "*Agent Category*") (defvar gnus-category-line-format-alist - `((?c name ?s) - (?g groups ?d))) + `((?c gnus-tmp-name ?s) + (?g gnus-tmp-groups ?d))) (defvar gnus-category-mode-line-format-alist `((?u user-defined ?s))) @@ -912,7 +1103,7 @@ the actual number of articles toggled is returned." ["Edit groups" gnus-category-edit-groups t] ["Exit" gnus-category-exit t])) - (run-hooks 'gnus-category-menu-hook))) + (gnus-run-hooks 'gnus-category-menu-hook))) (defun gnus-category-mode () "Major mode for listing and editing agent categories. @@ -935,23 +1126,23 @@ The following commands are available: (gnus-set-default-directory) (setq mode-line-process nil) (use-local-map gnus-category-mode-map) - (buffer-disable-undo (current-buffer)) + (buffer-disable-undo) (setq truncate-lines t) (setq buffer-read-only t) - (run-hooks 'gnus-category-mode-hook)) + (gnus-run-hooks 'gnus-category-mode-hook)) (defalias 'gnus-category-position-point 'gnus-goto-colon) (defun gnus-category-insert-line (category) - (let* ((name (car category)) - (groups (length (cadddr category)))) + (let* ((gnus-tmp-name (car category)) + (gnus-tmp-groups (length (cadddr category)))) (beginning-of-line) (gnus-add-text-properties (point) (prog1 (1+ (point)) ;; Insert the text. (eval gnus-category-line-format-spec)) - (list 'gnus-category name)))) + (list 'gnus-category gnus-tmp-name)))) (defun gnus-enter-category-buffer () "Go to the Category buffer." @@ -963,8 +1154,7 @@ The following commands are available: (defun gnus-category-setup-buffer () (unless (get-buffer gnus-category-buffer) (save-excursion - (set-buffer (get-buffer-create gnus-category-buffer)) - (gnus-add-current-to-buffer-list) + (set-buffer (gnus-get-buffer-create gnus-category-buffer)) (gnus-category-mode)))) (defun gnus-category-prepare () @@ -987,13 +1177,14 @@ The following commands are available: (setq gnus-category-alist (or (gnus-agent-read-file (nnheader-concat gnus-agent-directory "lib/categories")) - (list (list 'default 'true nil nil))))) - + (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) - (nnheader-temp-write (nnheader-concat gnus-agent-directory "lib/categories") + (gnus-make-directory (nnheader-concat gnus-agent-directory "lib")) + (with-temp-file (nnheader-concat gnus-agent-directory "lib/categories") (prin1 gnus-category-alist (current-buffer)))) (defun gnus-category-edit-predicate (category) @@ -1006,7 +1197,7 @@ The following commands are available: (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))) @@ -1054,7 +1245,7 @@ The following commands are available: (interactive "SCategory name: ") (when (assq category gnus-category-alist) (error "Category %s already exists" category)) - (push (list category 'true nil nil) + (push (list category 'false nil nil) gnus-category-alist) (gnus-category-write) (gnus-category-list)) @@ -1108,7 +1299,7 @@ The following commands are available: (defun gnus-agent-high-scored-p () "Say whether an article has a high score or not." - (> gnus-score gnus-agent-low-score)) + (> gnus-score gnus-agent-high-score)) (defun gnus-category-make-function (cat) "Make a function from category CAT." @@ -1121,7 +1312,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 @@ -1167,88 +1358,171 @@ The following commands are available: "Expire all old articles." (interactive) (let ((methods gnus-agent-covered-methods) - (alist (cdr gnus-newsrc-alist)) - gnus-command-method ofiles info method file group) - (while (setq gnus-command-method (pop methods)) - (setq ofiles (nconc ofiles (gnus-agent-expire-directory - (gnus-agent-directory))))) - (while (setq info (pop alist)) - (when (and (gnus-agent-method-p - (setq gnus-command-method - (gnus-find-method-for-group - (setq group (gnus-info-group info))))) - (member - (setq file - (concat - (gnus-agent-directory) - (gnus-agent-group-path group) "/.overview")) - ofiles)) - (setq ofiles (delete file ofiles)) - (gnus-agent-expire-group file group))) - (while ofiles - (gnus-agent-expire-group (pop ofiles))))) - -(defun gnus-agent-expire-directory (dir) - "Expire all groups in DIR recursively." - (when (file-directory-p dir) - (let ((files (directory-files dir t)) - file ofiles) - (while (setq file (pop files)) - (cond - ((member (file-name-nondirectory file) '("." "..")) - ;; Do nothing. - ) - ((file-directory-p file) - ;; Recurse. - (setq ofiles (nconc ofiles (gnus-agent-expire-directory file)))) - ((string-match "\\.overview$" file) - ;; Expire group. - (push file ofiles)))) - ofiles))) - -(defun gnus-agent-expire-group (overview &optional group) - "Expire articles in OVERVIEW." - (gnus-message 5 "Expiring %s..." overview) - (let ((odate (- (gnus-time-to-day (current-time)) 4)) - (dir (file-name-directory overview)) - (info (when group (gnus-get-info group))) - headers article file point unreads) - (gnus-agent-load-alist nil dir) - (when info - (setq unreads - (nconc - (gnus-list-of-unread-articles group) - (gnus-uncompress-range - (cdr (assq 'tick (gnus-info-marks info)))) - (gnus-uncompress-range - (cdr (assq 'dormant (gnus-info-marks info))))))) - (nnheader-temp-write overview - (insert-file-contents overview) - (goto-char (point-min)) - (while (not (eobp)) - (setq point (point)) - (condition-case () - (setq headers (inline (nnheader-parse-nov))) - (error - (goto-char point) - (gnus-delete-line) - (setq headers nil))) - (when headers - (unless (memq (setq article (mail-header-number headers)) unreads) - (if (not (< (inline - (gnus-time-to-day - (inline (nnmail-date-to-time - (mail-header-date headers))))) - odate)) - (forward-line 1) - (gnus-delete-line) - (setq gnus-agent-article-alist - (delq (assq article gnus-agent-article-alist) - gnus-agent-article-alist)) - (when (file-exists-p - (setq file (concat dir (number-to-string article)))) - (delete-file file)))))) - (gnus-agent-save-alist nil nil nil dir)))) + (day (- (time-to-days (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) + (save-excursion + (with-temp-buffer + (insert-file-contents file) + (gnus-active-to-gnus-format + nil (setq orig (gnus-make-hashtable + (count-lines (point-min) (point-max)))))) + (setq overview (gnus-get-buffer-create " *expire overview*")) + (while (setq gnus-command-method (pop methods)) + (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) + (mm-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)) + (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")))))) + +;;;###autoload +(defun gnus-agent-batch () + (interactive) + (let ((init-file-user "") + (gnus-always-read-dribble-file t)) + (gnus)) + (gnus-group-send-drafts) + (gnus-agent-fetch-session)) (provide 'gnus-agent)