X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-srvr.el;h=68362ad4c3471421fcb1387541731303ae20e506;hb=f6fe04a6c75532e7e5f1cb2ca3980c9478d41ff3;hp=0537fc5c3535044e146f09e464953cf9a97cff6e;hpb=4dc0c478fdf39b896a5185812101be972b98d5c7;p=elisp%2Fgnus.git-

diff --git a/lisp/gnus-srvr.el b/lisp/gnus-srvr.el
index 0537fc5..68362ad 100644
--- a/lisp/gnus-srvr.el
+++ b/lisp/gnus-srvr.el
@@ -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,33 @@ 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
+;;;
+
+;; #### FIXME: this function currently fails to update the Group buffer's
+;; #### FIXME: appearance. -- dvl
+(defun gnus-server-compact-server ()
+  "Issue a command to the server to compact all its groups."
+  (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 (gnus-request-compact server)
+	(gnus-message 5 "Requesting compaction of %s...done" server)
+      (gnus-message 5 "Couldn't compact %s" server))))
+
 (provide 'gnus-srvr)
 
 ;;; gnus-srvr.el ends here