;;; gnus-agent.el --- unplugged support for Gnus
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
(require 'timer))
(require 'cl))
-(eval-and-compile
- (autoload 'gnus-server-update-server "gnus-srvr")
- (autoload 'gnus-agent-customize-category "gnus-cus")
-)
+(autoload 'gnus-server-update-server "gnus-srvr")
+(autoload 'gnus-agent-customize-category "gnus-cus")
(defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/")
"Where the Gnus agent will store its files."
(defcustom gnus-agent-synchronize-flags nil
"Indicate if flags are synchronized when you plug in.
If this is `ask' the hook will query the user."
+ ;; If the default switches to something else than nil, then the function
+ ;; should be fixed not be exceedingly slow. See 2005-09-20 ChangeLog entry.
:version "21.1"
:type '(choice (const :tag "Always" t)
(const :tag "Never" nil)
:group 'gnus-agent
:type '(radio (const :format "Always" always)
(const :format "Never" nil)
- (const :format "When plugged" t)))
+ (const :format "When unplugged" t)))
(defcustom gnus-agent-prompt-send-queue nil
"If non-nil, `gnus-group-send-queue' will prompt if called when
:group 'gnus-agent
:type 'boolean)
+(defcustom gnus-agent-article-alist-save-format 1
+ "Indicates whether to use compression(2), versus no
+compression(1), when writing agentview files. The compressed
+files do save space but load times are 6-7 times higher. A group
+must be opened then closed for the agentview to be updated using
+the new format."
+ ;; Wouldn't symbols instead numbers be nicer? --rsteib
+ :version "22.1"
+ :group 'gnus-agent
+ :type '(radio (const :format "Compressed" 2)
+ (const :format "Uncompressed" 1)))
+
;;; Internal variables
(defvar gnus-agent-history-buffers nil)
(defvar gnus-headers)
(defvar gnus-score)
+;; Added to support XEmacs
+(eval-and-compile
+ (unless (fboundp 'directory-files-and-attributes)
+ (defun directory-files-and-attributes (directory
+ &optional full match nosort)
+ (let (result)
+ (dolist (file (directory-files directory full match nosort))
+ (push (cons file (file-attributes file)) result))
+ (nreverse result)))))
+
;;;
;;; Setup
;;;
(defsubst gnus-agent-cat-make (name &optional default-agent-predicate)
(list name `(agent-predicate . ,(or default-agent-predicate 'false))))
+(defun gnus-agent-read-group ()
+ "Read a group name in the minibuffer, with completion."
+ (let ((def (or (gnus-group-group-name) gnus-newsgroup-name)))
+ (when def
+ (setq def (gnus-group-decoded-name def)))
+ (gnus-group-completing-read (if def
+ (concat "Group Name (" def "): ")
+ "Group Name: ")
+ nil nil t nil nil def)))
+
;;; Fetching setup functions.
(defun gnus-agent-start-fetch ()
(fboundp 'make-mode-line-mouse-map))
(propertize string 'local-map
(make-mode-line-mouse-map mouse-button mouse-func)
- 'mouse-face 'mode-line-highlight)
+ 'mouse-face
+ (cond ((and (featurep 'xemacs)
+ ;; XEmacs' `facep' only checks for a face
+ ;; object, not for a face name, so it's useless
+ ;; to check with `facep'.
+ (find-face 'modeline))
+ 'modeline)
+ ((facep 'mode-line-highlight) ;; Emacs 22
+ 'mode-line-highlight)
+ ((facep 'mode-line) ;; Emacs 21
+ 'mode-line)) )
string))
(defun gnus-agent-toggle-plugged (set-to)
(gnus-agent-make-mode-line-string " Plugged"
'mouse-2
'gnus-agent-toggle-plugged))
- (gnus-agent-go-online gnus-agent-go-online)
- (gnus-agent-possibly-synchronize-flags))
+ (gnus-agent-go-online gnus-agent-go-online))
(t
(gnus-agent-close-connections)
(setq gnus-plugged set-to)
(interactive)
(save-excursion
(dolist (gnus-command-method (gnus-agent-covered-methods))
- (when (and (file-exists-p (gnus-agent-lib-file "flags"))
- (not (eq (gnus-server-status gnus-command-method) 'offline)))
+ (when (eq (gnus-server-status gnus-command-method) 'ok)
(gnus-agent-possibly-synchronize-flags-server gnus-command-method)))))
(defun gnus-agent-synchronize-flags-server (method)
(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)))))
+ (when (and (file-exists-p (gnus-agent-lib-file "flags"))
+ (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)))
;;;###autoload
(defun gnus-agent-rename-group (old-group new-group)
- "Rename fully-qualified OLD-GROUP as NEW-GROUP. Always updates the agent, even when
-disabled, as the old agent files would corrupt gnus when the agent was
-next enabled. Depends upon the caller to determine whether group renaming is supported."
+ "Rename fully-qualified OLD-GROUP as NEW-GROUP.
+Always updates the agent, even when disabled, as the old agent
+files would corrupt gnus when the agent was next enabled.
+Depends upon the caller to determine whether group renaming is
+supported."
(let* ((old-command-method (gnus-find-method-for-group old-group))
(old-path (directory-file-name
(let (gnus-command-method old-command-method)
(new-command-method (gnus-find-method-for-group new-group))
(new-path (directory-file-name
(let (gnus-command-method new-command-method)
- (gnus-agent-group-pathname new-group)))))
+ (gnus-agent-group-pathname new-group))))
+ (file-name-coding-system nnmail-pathname-coding-system))
(gnus-rename-file old-path new-path t)
(let* ((old-real-group (gnus-group-real-name old-group))
;;;###autoload
(defun gnus-agent-delete-group (group)
- "Delete fully-qualified GROUP. Always updates the agent, even when
-disabled, as the old agent files would corrupt gnus when the agent was
-next enabled. Depends upon the caller to determine whether group deletion is supported."
+ "Delete fully-qualified GROUP.
+Always updates the agent, even when disabled, as the old agent
+files would corrupt gnus when the agent was next enabled.
+Depends upon the caller to determine whether group deletion is
+supported."
(let* ((command-method (gnus-find-method-for-group group))
(path (directory-file-name
(let (gnus-command-method command-method)
- (gnus-agent-group-pathname group)))))
+ (gnus-agent-group-pathname group))))
+ (file-name-coding-system nnmail-pathname-coding-system))
(gnus-delete-directory path)
(let* ((real-group (gnus-group-real-name group)))
;; For each article that I processed that is no longer
;; undownloaded, remove its processable mark.
- (mapc #'gnus-summary-remove-process-mark
+ (mapc #'gnus-summary-remove-process-mark
(gnus-sorted-ndifference gnus-newsgroup-processable gnus-newsgroup-undownloaded))
;; The preceeding call to (gnus-agent-summary-fetch-group)
(gnus-active-to-gnus-format nil new)
(gnus-agent-write-active file new)
(erase-buffer)
- (nnheader-insert-file-contents file))))
+ (let ((nnheader-file-coding-system gnus-agent-file-coding-system))
+ (nnheader-insert-file-contents file)))))
(defun gnus-agent-write-active (file new)
(gnus-make-directory (file-name-directory file))
oactive-min (read (current-buffer))) ;; min
(cons oactive-min oactive-max))))))))
+(defvar gnus-agent-decoded-group-names nil
+ "Alist of non-ASCII group names and decoded ones.")
+
+(defun gnus-agent-decoded-group-name (group)
+ "Return a decoded group name of GROUP."
+ (or (cdr (assoc group gnus-agent-decoded-group-names))
+ (if (string-match "[^\000-\177]" group)
+ (let ((decoded (gnus-group-decoded-name group)))
+ (push (cons group decoded) gnus-agent-decoded-group-names)
+ decoded)
+ group)))
+
(defun gnus-agent-group-path (group)
"Translate GROUP into a file name."
(nnheader-translate-file-chars
(nnheader-replace-duplicate-chars-in-string
(nnheader-replace-chars-in-string
- (gnus-group-real-name (gnus-group-decoded-name group))
+ (gnus-group-real-name (gnus-agent-decoded-group-name group))
?/ ?_)
?. ?_)))
(if (or nnmail-use-long-file-names
(file-directory-p (expand-file-name group (gnus-agent-directory))))
group
- (mm-encode-coding-string
- (nnheader-replace-chars-in-string group ?. ?/)
- nnmail-pathname-coding-system)))
+ (nnheader-replace-chars-in-string group ?. ?/)))
(defun gnus-agent-group-pathname (group)
"Translate GROUP into a file name."
;; nnagent uses nnmail-group-pathname to read articles while
;; unplugged. The agent must, therefore, use the same directory
;; while plugged.
- (let ((gnus-command-method (or gnus-command-method
- (gnus-find-method-for-group group))))
- (nnmail-group-pathname (gnus-group-real-name
- (gnus-group-decoded-name group))
- (gnus-agent-directory))))
+ (nnmail-group-pathname
+ (gnus-group-real-name (gnus-agent-decoded-group-name group))
+ (if gnus-command-method
+ (gnus-agent-directory)
+ (let ((gnus-command-method (gnus-find-method-for-group group)))
+ (gnus-agent-directory)))))
(defun gnus-agent-get-function (method)
(if (gnus-online method)
(dir (gnus-agent-group-pathname group))
(date (time-to-days (current-time)))
(case-fold-search t)
- pos crosses id)
+ pos crosses id
+ (file-name-coding-system nnmail-pathname-coding-system))
(setcar selected-sets (nreverse (car selected-sets)))
(setq selected-sets (nreverse selected-sets))
(gnus-make-directory dir)
- (gnus-message 7 "Fetching articles for %s..." group)
+ (gnus-message 7 "Fetching articles for %s..."
+ (gnus-agent-decoded-group-name group))
(unwind-protect
(while (setq articles (pop selected-sets))
(let (article)
(while (setq article (pop articles))
(gnus-message 10 "Fetching article %s for %s..."
- article group)
+ article
+ (gnus-agent-decoded-group-name group))
(when (or
(gnus-backlog-request-article group article
nntp-server-buffer)
(delete-this (pop articles)))
(while (and (cdr next-possibility) delete-this)
(let ((have-this (caar (cdr next-possibility))))
- (cond ((< delete-this have-this)
- (setq delete-this (pop articles)))
- ((= delete-this have-this)
- (let ((timestamp (cdar (cdr next-possibility))))
- (when timestamp
- (let* ((file-name (concat (gnus-agent-group-pathname group)
- (number-to-string have-this)))
- (size-file (float (or (and gnus-agent-total-fetched-hashtb
- (nth 7 (file-attributes file-name)))
- 0))))
- (delete-file file-name)
- (gnus-agent-update-files-total-fetched-for group (- size-file)))))
-
- (setcdr next-possibility (cddr next-possibility)))
- (t
- (setq next-possibility (cdr next-possibility))))))
+ (cond
+ ((< delete-this have-this)
+ (setq delete-this (pop articles)))
+ ((= delete-this have-this)
+ (let ((timestamp (cdar (cdr next-possibility))))
+ (when timestamp
+ (let* ((file-name (concat (gnus-agent-group-pathname group)
+ (number-to-string have-this)))
+ (size-file
+ (float (or (and gnus-agent-total-fetched-hashtb
+ (nth 7 (file-attributes file-name)))
+ 0)))
+ (file-name-coding-system
+ nnmail-pathname-coding-system))
+ (delete-file file-name)
+ (gnus-agent-update-files-total-fetched-for
+ group (- size-file)))))
+
+ (setcdr next-possibility (cddr next-possibility)))
+ (t
+ (setq next-possibility (cdr next-possibility))))))
(setq gnus-agent-article-alist (cdr alist))
(gnus-agent-save-alist group)))))
(when (= (point-max) (point-min))
(push (cons group (current-buffer)) gnus-agent-buffer-alist)
(ignore-errors
- (nnheader-insert-file-contents
- (gnus-agent-article-name ".overview" group))))
+ (let ((file-name-coding-system nnmail-pathname-coding-system))
+ (nnheader-insert-file-contents
+ (gnus-agent-article-name ".overview" group)))))
(nnheader-find-nov-line (string-to-number (cdar crosses)))
(insert (string-to-number (cdar crosses)))
(insert-buffer-substring gnus-agent-overview-buffer beg end)
(when gnus-newsgroup-name
(let ((root (gnus-agent-article-name ".overview" gnus-newsgroup-name))
(cnt 0)
- name)
+ name
+ (file-name-coding-system nnmail-pathname-coding-system))
(while (file-exists-p
(setq name (concat root "~"
(int-to-string (setq cnt (1+ cnt))) "~"))))
(setq prev-num cur)))
(forward-line 1)))))))
+(defun gnus-agent-flush-server (&optional server-or-method)
+ "Flush all agent index files for every subscribed group within
+ the given SERVER-OR-METHOD. When called with nil, the current
+ value of gnus-command-method identifies the server."
+ (let* ((gnus-command-method (if server-or-method
+ &nbs
projects / gnus / blobdiff