lisp/ChangeLog addition:

[gnus] / lisp / gnus-srvr.el

diff --git a/lisp/gnus-srvr.el b/lisp/gnus-srvr.el
index eb44157..5a2f895 100644 (file)
--- a/lisp/gnus-srvr.el
+++ b/lisp/gnus-srvr.el
@@ -1,7 +1,7 @@
 ;;; gnus-srvr.el --- virtual server support for Gnus
+
 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005
-;;        Free Software Foundation, Inc.
+;;   2004, 2005 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: news
@@ -20,8 +20,8 @@
 
 ;; 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., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
 
 ;;; Commentary:
 
@@ -116,6 +116,7 @@ If nil, a faster, but more primitive, buffer is used instead."
        ["Copy" gnus-server-copy-server t]
        ["Edit" gnus-server-edit-server t]
        ["Regenerate" gnus-server-regenerate-server t]
+       ["Compact" gnus-server-compact-server t]
        ["Exit" gnus-server-exit t]))
 
     (easy-menu-define
@@ -165,6 +166,8 @@ If nil, a faster, but more primitive, buffer is used instead."
 
     "g" gnus-server-regenerate-server
 
+    "z" gnus-server-compact-server
+
     "\C-c\C-i" gnus-info-find-node
     "\C-c\C-b" gnus-bug))
 
@@ -1012,6 +1015,40 @@ If NUMBER, fetch this number of articles."
        (gnus-message 5 "Requesting regeneration of %s...done" server)
       (gnus-message 5 "Couldn't regenerate %s" server))))
 
+
+;;;
+;;; Server compaction. -- dvl
+;;;
+
+;; #### FIXME: this function currently fails to update the Group buffer's
+;; #### appearance.
+(defun gnus-server-compact-server ()
+  "Issue a command to the server to compact all its groups.
+
+Note: currently only implemented in nnml."
+  (interactive)
+  (let ((server (gnus-server-server-name)))
+    (unless server
+      (error "No server on the current line"))
+    (condition-case ()
+       (gnus-get-function (gnus-server-to-method server)
+                          'request-compact)
+      (error
+       (error "This back end doesn't support compaction")))
+    (gnus-message 5 "\
+Requesting compaction of %s... (this may take a long time)"
+                 server)
+    (unless (gnus-open-server server)
+      (error "Couldn't open server"))
+    (if (not (gnus-request-compact server))
+       (gnus-message 5 "Couldn't compact %s" server)
+      (gnus-message 5 "Requesting compaction of %s...done" server)
+      ;; Invalidate the original article buffer which might be out of date.
+      ;; #### NOTE: Yes, this might be a bit rude, but since compaction
+      ;; #### will not happen very often, I think this is acceptable.
+      (let ((original (get-buffer gnus-original-article-buffer)))
+       (and original (gnus-kill-buffer original))))))
+
 (provide 'gnus-srvr)
 
 ;;; arch-tag: c0117f64-27ca-475d-9406-8da6854c7a25