;;; 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
["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
"g" gnus-server-regenerate-server
+ "z" gnus-server-compact-server
+
"\C-c\C-i" gnus-info-find-node
"\C-c\C-b" gnus-bug))
(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