-;;; gnus-agent.el --- unplugged support for Gnus
-;; Copyright (C) 1997,98,99 Free Software Foundation, Inc.
+;;; gnus-agent.el --- unplugged support for Semi-gnus
+;; Copyright (C) 1997, 1998, 1999, 2000 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Tatsuya Ichikawa <t-ichi@po.shiojiri.ne.jp>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;;; Code:
+(eval-when-compile (require 'cl))
+(eval-when-compile (require 'gnus-clfns))
+
(require 'gnus)
(require 'gnus-cache)
(require 'nnvirtual)
(require 'gnus-sum)
-(eval-when-compile
- (require 'cl)
- (require 'gnus-score))
+(eval-when-compile (require 'gnus-score) (require 'gnus-group))
(defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/")
"Where the Gnus agent will store its files."
:group 'gnus-agent
:type 'hook)
+(defcustom gnus-agent-confirmation-function 'y-or-n-p
+ "Function to confirm when error happens."
+ :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")))
+
;;; Internal variables
(defvar gnus-agent-history-buffers nil)
(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)
(setq gnus-plugged plugged)
(gnus-run-hooks 'gnus-agent-unplugged-hook)
(setcar (cdr gnus-agent-mode-status) " Unplugged"))
- (set-buffer-modified-p t))
+ (force-mode-line-update))
(defun gnus-agent-close-connections ()
"Close all methods covered by the Gnus agent."
(funcall function nil new)
(gnus-agent-write-active file new)
(erase-buffer)
- (insert-file-contents-literally file))))
+ (insert-file-contents-as-coding-system gnus-agent-file-coding-system
+ file))))
(defun gnus-agent-write-active (file new)
(let ((orig (gnus-make-hashtable (count-lines (point-min) (point-max))))
elem osym)
(when (file-exists-p file)
(with-temp-buffer
- (insert-file-contents file)
+ (insert-file-contents-as-coding-system gnus-agent-file-coding-system
+ file)
(gnus-active-to-gnus-format nil orig))
(mapatoms
(lambda (sym)
(set (intern (symbol-name sym) orig) (symbol-value sym)))))
new))
(gnus-make-directory (file-name-directory file))
- (let ((coding-system-for-write gnus-agent-file-coding-system))
- (gnus-write-active-file file orig))))
+ ;; The hashtable contains real names of groups, no more prefix
+ ;; removing, so set `full' to `t'.
+ (gnus-write-active-file-as-coding-system gnus-agent-file-coding-system
+ file orig t)))
(defun gnus-agent-save-groups (method)
(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")))
+ (file (gnus-agent-lib-file "active"))
+ oactive)
(gnus-make-directory (file-name-directory file))
(with-temp-file file
(when (file-exists-p 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 group " " (number-to-string (cdr active)) " "
- (number-to-string (car active)) " y\n")))))
+ (insert (format "%S %d %d y\n" (intern group)
+ (cdr active)
+ (or (car oactive) (car active))))
+ (goto-char (point-max))
+ (while (search-backward "\\." nil t)
+ (delete-char 1))))))
(defun gnus-agent-group-path (group)
"Translate GROUP into a path."
(if nnmail-use-long-file-names
(gnus-group-real-name group)
- (nnheader-replace-chars-in-string
- (nnheader-translate-file-chars (gnus-group-real-name group))
- ?. ?/)))
+ (nnheader-translate-file-chars
+ (nnheader-replace-chars-in-string
+ (nnheader-replace-duplicate-chars-in-string
+ (nnheader-replace-chars-in-string
+ (gnus-group-real-name group)
+ ?/ ?_)
+ ?. ?_)
+ ?. ?/))))
\f
(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)
(save-excursion
(set-buffer gnus-agent-current-history)
(goto-char (point-max))
- (insert id "\t" (number-to-string date) "\t")
- (while group-arts
- (insert (caar group-arts) " " (number-to-string (cdr (pop group-arts)))
- " "))
- (insert "\n")))
+ (let ((p (point)))
+ (insert id "\t" (number-to-string date) "\t")
+ (while group-arts
+ (insert (format "%S" (intern (caar group-arts)))
+ " " (number-to-string (cdr (pop group-arts)))
+ " "))
+ (insert "\n")
+ (while (search-backward "\\." p t)
+ (delete-char 1)))))
(defun gnus-agent-article-in-history-p (id)
(save-excursion
;; 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))
(with-temp-buffer
(let (article)
(while (setq article (pop articles))
- (when (gnus-request-article article group)
+ (when (or
+ (gnus-backlog-request-article group article
+ nntp-server-buffer)
+ (gnus-request-article article group))
(goto-char (point-max))
(push (cons article (point)) pos)
(insert-buffer-substring nntp-server-buffer)))
(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
(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
(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)
(pop gnus-agent-group-alist))))
(defun gnus-agent-fetch-headers (group &optional force)
- (let ((articles (gnus-list-of-unread-articles group))
- (gnus-decode-encoded-word-function 'identity)
- (file (gnus-agent-article-name ".overview" group)))
- ;; add article with marks to list of article headers we want to fetch
+ (let* ((articles (gnus-list-of-unread-articles group))
+ (len (length articles))
+ (gnus-decode-encoded-word-function 'identity)
+ (file (gnus-agent-article-name ".overview" group))
+ i)
+ ;; Check the number of articles is not too large.
+ (when (and (integerp gnus-agent-large-newsgroup)
+ (< 0 gnus-agent-large-newsgroup))
+ (and (< 0 (setq i (- len gnus-agent-large-newsgroup)))
+ (setq articles (nthcdr i articles))))
+ ;; add article with marks to list of article headers we want to fetch.
(dolist (arts (gnus-info-marks (gnus-get-info group)))
(setq articles (union (gnus-uncompress-sequence (cdr arts))
- articles)))
+ articles)))
(setq articles (sort articles '<))
- ;; remove known articles
+ ;; Remove known articles.
(when (gnus-agent-load-alist group)
(setq articles (gnus-sorted-intersection
- articles
- (gnus-uncompress-range
- (cons (1+ (caar (last gnus-agent-article-alist)))
- (cdr (gnus-active group)))))))
+ articles
+ (gnus-uncompress-range
+ (cons (1+ (caar (last gnus-agent-article-alist)))
+ (cdr (gnus-active group)))))))
;; Fetch them.
(gnus-make-directory (nnheader-translate-file-chars
- (file-name-directory file)))
+ (file-name-directory file) t))
(when articles
(gnus-message 7 "Fetching headers for %s..." group)
(save-excursion
- (set-buffer nntp-server-buffer)
- (unless (eq 'nov (gnus-retrieve-headers articles group))
- (nnvirtual-convert-headers))
- ;; Save these headers for later processing.
- (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max))
+ (set-buffer nntp-server-buffer)
+ (unless (eq 'nov (gnus-retrieve-headers articles group))
+ (nnvirtual-convert-headers))
+ ;; Save these headers for later processing.
+ (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max))
(when (file-exists-p file)
(gnus-agent-braid-nov group articles file))
- (let ((coding-system-for-write
- gnus-agent-file-coding-system))
- (write-region (point-min) (point-max) file nil 'silent))
+ (write-region-as-coding-system
+ gnus-agent-file-coding-system
+ (point-min) (point-max) file nil 'silent)
(gnus-agent-save-alist group articles nil)
(gnus-agent-enter-history
"last-header-fetched-for-session"
"Start Gnus and fetch session."
(interactive)
(gnus)
- (gnus-agent-fetch-session)
+ (let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation))
+ (gnus-agent-fetch-session))
(gnus-group-exit))
(defun gnus-agent-fetch-session ()
groups group gnus-command-method)
(save-excursion
(while methods
- (setq gnus-command-method (car methods))
- (when (or (gnus-server-opened gnus-command-method)
- (gnus-open-server gnus-command-method))
- (setq groups (gnus-groups-from-server (car methods)))
- (gnus-agent-with-fetch
- (while (setq group (pop groups))
- (when (<= (gnus-group-level group) gnus-agent-handle-level)
- (gnus-agent-fetch-group-1 group gnus-command-method)))))
+ (condition-case err
+ (progn
+ (setq gnus-command-method (car methods))
+ (when (or (gnus-server-opened gnus-command-method)
+ (gnus-open-server gnus-command-method))
+ (setq groups (gnus-groups-from-server (car methods)))
+ (gnus-agent-with-fetch
+ (while (setq group (pop groups))
+ (when (<= (gnus-group-level group) gnus-agent-handle-level)
+ (gnus-agent-fetch-group-1 group gnus-command-method))))))
+ (error
+ (unless (funcall gnus-agent-confirmation-function
+ (format "Error (%s). Continue? " err))
+ (error "Cannot fetch articles into the Gnus agent."))))
(pop methods))
(gnus-message 6 "Finished fetching articles into the Gnus agent"))))
;; 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
+ (gnus-get-newsgroup-headers-xover articles nil nil
group)))
;; `gnus-agent-overview-buffer' may be killed for
- ;; timeout reason. If so, recreate it.
+ ;; timeout reason. If so, recreate it.
(gnus-agent-create-buffer)))
(setq category (gnus-group-category group))
(setq predicate
(gnus-get-predicate
- (or (gnus-group-find-parameter group 'agent-predicate t)
+ (or (gnus-group-find-parameter group 'agent-predicate t)
(cadr category))))
;; Do we want to download everything, or nothing?
(if (or (eq (caaddr predicate) 'gnus-agent-true)
(gnus-edit-form
(cadr info) (format "Editing the predicate for category %s" category)
`(lambda (predicate)
- (setf (cadr (assq ',category gnus-category-alist)) predicate)
+ (setcar (cdr (assq ',category gnus-category-alist)) predicate)
(gnus-category-write)
(gnus-category-list)))))
(caddr info)
(format "Editing the score expression for category %s" category)
`(lambda (groups)
- (setf (caddr (assq ',category gnus-category-alist)) groups)
+ (setcar (nthcdr 2 (assq ',category gnus-category-alist)) groups)
(gnus-category-write)
(gnus-category-list)))))
(gnus-edit-form
(cadddr info) (format "Editing the group list for category %s" category)
`(lambda (groups)
- (setf (cadddr (assq ',category gnus-category-alist)) groups)
+ (setcar (nthcdr 3 (assq ',category gnus-category-alist)) groups)
(gnus-category-write)
(gnus-category-list)))))
(let ((info (assq category gnus-category-alist))
(buffer-read-only nil))
(gnus-delete-line)
- (gnus-category-write)
- (setq gnus-category-alist (delq info gnus-category-alist))))
+ (setq gnus-category-alist (delq info gnus-category-alist))
+ (gnus-category-write)))
(defun gnus-category-copy (category to)
"Copy the current category."
(while (setq gnus-command-method (pop methods))
(when (file-exists-p (gnus-agent-lib-file "active"))
(with-temp-buffer
- (insert-file-contents (gnus-agent-lib-file "active"))
- (gnus-active-to-gnus-format
+ (insert-file-contents-as-coding-system
+ gnus-agent-file-coding-system (gnus-agent-lib-file "active"))
+ (gnus-active-to-gnus-format
gnus-command-method
(setq orig (gnus-make-hashtable
(count-lines (point-min) (point-max))))))
(forward-line 1)
;; Old article. Schedule it for possible nuking.
(while (not (eolp))
- (setq sym (let ((obarray expiry-hashtb))
- (read (current-buffer))))
+ (setq sym (let ((obarray expiry-hashtb) s)
+ (setq s (read (current-buffer)))
+ (if (stringp s) (intern s) s)))
(if (boundp sym)
(set sym (cons (cons (read (current-buffer)) (point))
(symbol-value sym)))
(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)
(set-buffer overview)
(erase-buffer)
(when (file-exists-p nov-file)
- (nnheader-insert-file-contents nov-file))
+ (nnheader-insert-file-contents nov-file))
(goto-char (point-min))
(setq article 0)
(while (setq elem (pop articles))
(or (not (numberp
(setq art (read (current-buffer)))))
(< art article)))
- (if (and (numberp art)
+ (if (and (numberp art)
(file-exists-p
(gnus-agent-article-name
(number-to-string art) group)))
;; 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))
(gnus-delete-line))
(gnus-agent-save-history)
(gnus-agent-close-history)
- (gnus-write-active-file
+ (gnus-write-active-file-as-coding-system
+ gnus-agent-file-coding-system
(gnus-agent-lib-file "active") orig))
(gnus-message 4 "Expiry...done")))))))
(gnus-group-send-drafts)
(gnus-agent-fetch-session))
+;;;
+;;; Advice
+;;;
+
+(defadvice gnus-group-get-new-news (after gnus-agent-advice
+ activate preactivate)
+ "Update modeline."
+ (unless (interactive-p)
+ (gnus-agent-toggle-plugged gnus-plugged)))
+
(provide 'gnus-agent)
;;; gnus-agent.el ends here
projects / elisp / gnus.git- / blobdiff