;;; gnus-srvr.el --- virtual server support for Gnus
-;; Copyright (C) 1995,96,97,98,99 Free Software Foundation, Inc.
+
+;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+;; 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
;; 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
;; 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., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
(require 'gnus-int)
(require 'gnus-range)
-(defvar gnus-server-mode-hook nil
- "Hook run in `gnus-server-mode' buffers.")
+(defcustom gnus-server-mode-hook nil
+ "Hook run in `gnus-server-mode' buffers."
+ :group 'gnus-server
+ :type 'hook)
+
+(defcustom gnus-server-exit-hook nil
+ "Hook run when exiting the server buffer."
+ :group 'gnus-server
+ :type 'hook)
-(defconst gnus-server-line-format " {%(%h:%w%)} %s\n"
+(defcustom gnus-server-line-format " {%(%h:%w%)} %s%a\n"
"Format of server lines.
It works along the same lines as a normal formatting string,
with some simple extensions.
The following specs are understood:
-%h backend
+%h back end
%n name
%w address
-%s status")
-
-(defvar gnus-server-mode-line-format "Gnus: %%b"
- "The format specification for the server mode line.")
-
-(defvar gnus-server-exit-hook nil
- "*Hook run when exiting the server buffer.")
+%s status
+%a agent covered
+
+General format specifiers can also be used.
+See Info node `(gnus)Formatting Variables'."
+ :link '(custom-manual "(gnus)Formatting Variables")
+ :group 'gnus-server-visual
+ :type 'string)
+
+(defcustom gnus-server-mode-line-format "Gnus: %%b"
+ "The format specification for the server mode line."
+ :group 'gnus-server-visual
+ :type 'string)
+
+(defcustom gnus-server-browse-in-group-buffer nil
+ "Whether server browsing should take place in the group buffer.
+If nil, a faster, but more primitive, buffer is used instead."
+ :version "22.1"
+ :group 'gnus-server-visual
+ :type 'boolean)
;;; Internal variables.
`((?h gnus-tmp-how ?s)
(?n gnus-tmp-name ?s)
(?w gnus-tmp-where ?s)
- (?s gnus-tmp-status ?s)))
+ (?s gnus-tmp-status ?s)
+ (?a gnus-tmp-agent ?s)))
(defvar gnus-server-mode-line-format-alist
`((?S gnus-tmp-news-server ?s)
(easy-menu-define
gnus-server-server-menu gnus-server-mode-map ""
'("Server"
- ["Add" gnus-server-add-server t]
+ ["Add..." gnus-server-add-server t]
["Browse" gnus-server-read-server t]
["Scan" gnus-server-scan-server t]
["List" gnus-server-list-servers t]
["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
'("Connections"
["Open" gnus-server-open-server t]
["Close" gnus-server-close-server t]
+ ["Offline" gnus-server-offline-server t]
["Deny" gnus-server-deny-server t]
"---"
["Open All" gnus-server-open-all-servers t]
(suppress-keymap gnus-server-mode-map)
(gnus-define-keys gnus-server-mode-map
- " " gnus-server-read-server
+ " " gnus-server-read-server-in-server-buffer
"\r" gnus-server-read-server
gnus-mouse-2 gnus-server-pick-server
"q" gnus-server-exit
"C" gnus-server-close-server
"\M-c" gnus-server-close-all-servers
"D" gnus-server-deny-server
+ "L" gnus-server-offline-server
"R" gnus-server-remove-denials
"n" next-line
"p" previous-line
-
+
"g" gnus-server-regenerate-server
+ "z" gnus-server-compact-server
+
"\C-c\C-i" gnus-info-find-node
"\C-c\C-b" gnus-bug))
+(defface gnus-server-agent
+ '((((class color) (background light)) (:foreground "PaleTurquoise" :bold t))
+ (((class color) (background dark)) (:foreground "PaleTurquoise" :bold t))
+ (t (:bold t)))
+ "Face used for displaying AGENTIZED servers"
+ :group 'gnus-server-visual)
+;; backward-compatibility alias
+(put 'gnus-server-agent-face 'face-alias 'gnus-server-agent)
+(put 'gnus-server-agent-face 'obsolete-face "22.1")
+
+(defface gnus-server-opened
+ '((((class color) (background light)) (:foreground "Green3" :bold t))
+ (((class color) (background dark)) (:foreground "Green1" :bold t))
+ (t (:bold t)))
+ "Face used for displaying OPENED servers"
+ :group 'gnus-server-visual)
+;; backward-compatibility alias
+(put 'gnus-server-opened-face 'face-alias 'gnus-server-opened)
+(put 'gnus-server-opened-face 'obsolete-face "22.1")
+
+(defface gnus-server-closed
+ '((((class color) (background light)) (:foreground "Steel Blue" :italic t))
+ (((class color) (background dark))
+ (:foreground "LightBlue" :italic t))
+ (t (:italic t)))
+ "Face used for displaying CLOSED servers"
+ :group 'gnus-server-visual)
+;; backward-compatibility alias
+(put 'gnus-server-closed-face 'face-alias 'gnus-server-closed)
+(put 'gnus-server-closed-face 'obsolete-face "22.1")
+
+(defface gnus-server-denied
+ '((((class color) (background light)) (:foreground "Red" :bold t))
+ (((class color) (background dark)) (:foreground "Pink" :bold t))
+ (t (:inverse-video t :bold t)))
+ "Face used for displaying DENIED servers"
+ :group 'gnus-server-visual)
+;; backward-compatibility alias
+(put 'gnus-server-denied-face 'face-alias 'gnus-server-denied)
+(put 'gnus-server-denied-face 'obsolete-face "22.1")
+
+(defface gnus-server-offline
+ '((((class color) (background light)) (:foreground "Orange" :bold t))
+ (((class color) (background dark)) (:foreground "Yellow" :bold t))
+ (t (:inverse-video t :bold t)))
+ "Face used for displaying OFFLINE servers"
+ :group 'gnus-server-visual)
+;; backward-compatibility alias
+(put 'gnus-server-offline-face 'face-alias 'gnus-server-offline)
+(put 'gnus-server-offline-face 'obsolete-face "22.1")
+
+(defvar gnus-server-font-lock-keywords
+ '(("(\\(agent\\))" 1 'gnus-server-agent)
+ ("(\\(opened\\))" 1 'gnus-server-opened)
+ ("(\\(closed\\))" 1 'gnus-server-closed)
+ ("(\\(offline\\))" 1 'gnus-server-offline)
+ ("(\\(denied\\))" 1 'gnus-server-denied)))
+
(defun gnus-server-mode ()
"Major mode for listing and editing servers.
All normal editing commands are switched off.
\\<gnus-server-mode-map>
For more in-depth information on this mode, read the manual
-(`\\[gnus-info-find-node]').
+\(`\\[gnus-info-find-node]').
The following commands are available:
(buffer-disable-undo)
(setq truncate-lines t)
(setq buffer-read-only t)
- (gnus-run-hooks 'gnus-server-mode-hook))
+ (if (featurep 'xemacs)
+ (put 'gnus-server-mode 'font-lock-defaults '(gnus-server-font-lock-keywords t))
+ (set (make-local-variable 'font-lock-defaults)
+ '(gnus-server-font-lock-keywords t)))
+ (gnus-run-mode-hooks 'gnus-server-mode-hook))
(defun gnus-server-insert-server-line (gnus-tmp-name method)
(let* ((gnus-tmp-how (car method))
(gnus-tmp-where (nth 1 method))
(elem (assoc method gnus-opened-servers))
- (gnus-tmp-status (cond ((eq (nth 1 elem) 'denied)
- "(denied)")
- ((or (gnus-server-opened method)
- (eq (nth 1 elem) 'ok))
- "(opened)")
- (t
- "(closed)"))))
+ (gnus-tmp-status
+ (cond
+ ((eq (nth 1 elem) 'denied) "(denied)")
+ ((eq (nth 1 elem) 'offline) "(offline)")
+ (t
+ (condition-case nil
+ (if (or (gnus-server-opened method)
+ (eq (nth 1 elem) 'ok))
+ "(opened)"
+ "(closed)")
+ ((error) "(error)")))))
+ (gnus-tmp-agent (if (and gnus-agent
+ (gnus-agent-method-p method))
+ " (agent)"
+ "")))
(beginning-of-line)
(gnus-add-text-properties
(point)
(prog1 (1+ (point))
;; Insert the text.
(eval gnus-server-line-format-spec))
- (list 'gnus-server (intern gnus-tmp-name)))))
+ (list 'gnus-server (intern gnus-tmp-name)
+ 'gnus-named-server (intern (gnus-method-to-server method t))))))
(defun gnus-enter-server-buffer ()
"Set up the server buffer."
(gnus-server-setup-buffer)
(gnus-configure-windows 'server)
- (gnus-server-prepare))
+ ;; Usually `gnus-configure-windows' will finish with the
+ ;; `gnus-server-buffer' selected as the current buffer, but not always (I
+ ;; bumped into it when starting from a dedicated *Group* frame, and
+ ;; gnus-configure-windows opened *Server* into its own dedicated frame).
+ (with-current-buffer (get-buffer gnus-server-buffer)
+ (gnus-server-prepare)))
(defun gnus-server-setup-buffer ()
"Initialize the server buffer."
(unless (get-buffer gnus-server-buffer)
- (save-excursion
- (set-buffer (gnus-get-buffer-create gnus-server-buffer))
+ (with-current-buffer (gnus-get-buffer-create gnus-server-buffer)
(gnus-server-mode)
(when gnus-carpal
(gnus-carpal-setup-buffer 'server)))))
(gnus-set-format 'server t)
(let ((alist gnus-server-alist)
(buffer-read-only nil)
- (opened gnus-opened-servers)
done server op-ser)
(erase-buffer)
(setq gnus-inserted-opened-servers nil)
(while alist
(unless (member (cdar alist) done)
(push (cdar alist) done)
- (cdr (setq server (pop alist)))
+ (setq server (pop alist))
(when (and server (car server) (cdr server))
(gnus-server-insert-server-line (car server) (cdr server))))
(when (member (cdar alist) done)
(pop alist)))
;; Then we insert the list of servers that have been opened in
;; this session.
- (while opened
- (when (and (not (member (caar opened) done))
+ (dolist (open gnus-opened-servers)
+ (when (and (not (member (car open) done))
;; Just ignore ephemeral servers.
- (not (member (caar opened) gnus-ephemeral-servers)))
- (push (caar opened) done)
+ (not (member (car open) gnus-ephemeral-servers)))
+ (push (car open) done)
(gnus-server-insert-server-line
- (setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened))))
- (caar opened))
- (push (list op-ser (caar opened)) gnus-inserted-opened-servers))
- (setq opened (cdr opened))))
+ (setq op-ser (format "%s:%s" (caar open) (nth 1 (car open))))
+ (car open))
+ (push (list op-ser (car open)) gnus-inserted-opened-servers))))
(goto-char (point-min))
(gnus-server-position-point))
(defun gnus-server-server-name ()
- (let ((server (get-text-property (gnus-point-at-bol) 'gnus-server)))
+ (let ((server (get-text-property (point-at-bol) 'gnus-server)))
+ (and server (symbol-name server))))
+
+(defun gnus-server-named-server ()
+ "Return a server name that matches one of the names returned by
+`gnus-method-to-server'."
+ (let ((server (get-text-property (point-at-bol) 'gnus-named-server)))
(and server (symbol-name server))))
(defalias 'gnus-server-position-point 'gnus-goto-colon)
(defconst gnus-server-edit-buffer "*Gnus edit server*")
(defun gnus-server-update-server (server)
- (save-excursion
- (set-buffer gnus-server-buffer)
+ (with-current-buffer gnus-server-buffer
(let* ((buffer-read-only nil)
(entry (assoc server gnus-server-alist))
(oentry (assoc (gnus-server-to-method server)
(when entry
(gnus-dribble-enter
(concat "(gnus-server-set-info \"" server "\" '"
- (prin1-to-string (cdr entry)) ")\n")))
+ (gnus-prin1-to-string (cdr entry)) ")\n")))
(when (or entry oentry)
;; Buffer may be narrowed.
(save-restriction
(when (and server info)
(gnus-dribble-enter
(concat "(gnus-server-set-info \"" server "\" '"
- (prin1-to-string info) ")"))
+ (gnus-prin1-to-string info) ")"))
(let* ((server (nth 1 info))
- (entry (assoc server gnus-server-alist)))
- (if entry (setcdr entry info)
+ (entry (assoc server gnus-server-alist))
+ (cached (assoc server gnus-server-method-cache)))
+ (if cached
+ (setq gnus-server-method-cache
+ (delq cached gnus-server-method-cache)))
+ (if entry
+ (progn
+ ;; Remove the server from `gnus-opened-servers' since
+ ;; it has never been opened with the new `info' yet.
+ (gnus-opened-servers-remove (cdr entry))
+ ;; Don't make a new Lisp object.
+ (setcar (cdr entry) (car info))
+ (setcdr (cdr entry) (cdr info)))
(setq gnus-server-alist
(nconc gnus-server-alist (list (cons server info))))))))
(push (assoc server gnus-server-alist) gnus-server-killed-servers)
(setq gnus-server-alist (delq (car gnus-server-killed-servers)
gnus-server-alist))
+ (let ((groups (gnus-groups-from-server server)))
+ (when (and groups
+ (gnus-yes-or-no-p
+ (format "Kill all %s groups from this server? "
+ (length groups))))
+ (dolist (group groups)
+ (setq gnus-newsrc-alist
+ (delq (assoc group gnus-newsrc-alist)
+ gnus-newsrc-alist))
+ (when gnus-group-change-level-function
+ (funcall gnus-group-change-level-function
+ group gnus-level-killed 3)))))
(gnus-server-position-point))
(defun gnus-server-yank-server ()
(setq alist (cdr alist)))
(if alist
(setcdr alist (cons killed (cdr alist)))
- (setq gnus-server-alist (list killed)))))
+ (setq gnus-server-alist (list killed)))))
(gnus-server-update-server (car killed))
(setq gnus-server-killed-servers (cdr gnus-server-killed-servers))
(gnus-server-position-point)))
"Return to the group buffer."
(interactive)
(gnus-run-hooks 'gnus-server-exit-hook)
- (kill-buffer (current-buffer))
+ (gnus-kill-buffer (current-buffer))
(gnus-configure-windows 'group t))
(defun gnus-server-list-servers ()
(defun gnus-server-open-all-servers ()
"Open all servers."
(interactive)
- (let ((servers gnus-inserted-opened-servers))
- (while servers
- (gnus-server-open-server (car (pop servers))))))
+ (dolist (server gnus-inserted-opened-servers)
+ (gnus-server-open-server (car server))))
(defun gnus-server-close-server (server)
"Close SERVER."
(gnus-server-update-server server)
(gnus-server-position-point))))
+(defun gnus-server-offline-server (server)
+ "Set SERVER to offline."
+ (interactive (list (gnus-server-server-name)))
+ (let ((method (gnus-server-to-method server)))
+ (unless method
+ (error "No such server: %s" server))
+ (prog1
+ (gnus-close-server method)
+ (gnus-server-set-status method 'offline)
+ (gnus-server-update-server server)
+ (gnus-server-position-point))))
+
(defun gnus-server-close-all-servers ()
"Close all servers."
(interactive)
- (let ((servers gnus-inserted-opened-servers))
- (while servers
- (gnus-server-close-server (car (pop servers))))))
+ (dolist (server gnus-inserted-opened-servers)
+ (gnus-server-close-server (car server)))
+ (dolist (server gnus-server-alist)
+ (gnus-server-close-server (car server))))
(defun gnus-server-deny-server (server)
"Make sure SERVER will never be attempted opened."
(defun gnus-server-remove-denials ()
"Make all denied servers into closed servers."
(interactive)
- (let ((servers gnus-opened-servers))
- (while servers
- (when (eq (nth 1 (car servers)) 'denied)
- (setcar (nthcdr 1 (car servers)) 'closed))
- (setq servers (cdr servers))))
+ (dolist (server gnus-opened-servers)
+ (when (eq (nth 1 server) 'denied)
+ (setcar (nthcdr 1 server) 'closed)))
(gnus-server-list-servers))
(defun gnus-server-copy-server (from to)
`(lambda (form)
(gnus-server-set-info ,server form)
(gnus-server-list-servers)
- (gnus-server-position-point)))))
+ (gnus-server-position-point))
+ 'edit-server)))
(defun gnus-server-scan-server (server)
"Request a scan from the current server."
(gnus-request-scan nil method)
(gnus-message 3 "Scanning %s...done" server))))
+(defun gnus-server-read-server-in-server-buffer (server)
+ "Browse a server in server buffer."
+ (interactive (list (gnus-server-server-name)))
+ (let (gnus-server-browse-in-group-buffer)
+ (gnus-server-read-server server)))
+
(defun gnus-server-read-server (server)
"Browse a server."
(interactive (list (gnus-server-server-name)))
(let ((buf (current-buffer)))
(prog1
(gnus-browse-foreign-server server buf)
- (save-excursion
- (set-buffer buf)
+ (with-current-buffer buf
(gnus-server-update-server (gnus-server-server-name))
(gnus-server-position-point)))))
(suppress-keymap gnus-browse-mode-map)
(gnus-define-keys
- gnus-browse-mode-map
- " " gnus-browse-read-group
- "=" gnus-browse-select-group
- "n" gnus-browse-next-group
- "p" gnus-browse-prev-group
- "\177" gnus-browse-prev-group
- [delete] gnus-browse-prev-group
- "N" gnus-browse-next-group
- "P" gnus-browse-prev-group
- "\M-n" gnus-browse-next-group
- "\M-p" gnus-browse-prev-group
- "\r" gnus-browse-select-group
- "u" gnus-browse-unsubscribe-current-group
- "l" gnus-browse-exit
- "L" gnus-browse-exit
- "q" gnus-browse-exit
- "Q" gnus-browse-exit
- "\C-c\C-c" gnus-browse-exit
- "?" gnus-browse-describe-briefly
-
- "\C-c\C-i" gnus-info-find-node
- "\C-c\C-b" gnus-bug))
+ gnus-browse-mode-map
+ " " gnus-browse-read-group
+ "=" gnus-browse-select-group
+ "n" gnus-browse-next-group
+ "p" gnus-browse-prev-group
+ "\177" gnus-browse-prev-group
+ [delete] gnus-browse-prev-group
+ "N" gnus-browse-next-group
+ "P" gnus-browse-prev-group
+ "\M-n" gnus-browse-next-group
+ "\M-p" gnus-browse-prev-group
+ "\r" gnus-browse-select-group
+ "u" gnus-browse-unsubscribe-current-group
+ "l" gnus-browse-exit
+ "L" gnus-browse-exit
+ "q" gnus-browse-exit
+ "Q" gnus-browse-exit
+ "d" gnus-browse-describe-group
+ "\C-c\C-c" gnus-browse-exit
+ "?" gnus-browse-describe-briefly
+
+ "\C-c\C-i" gnus-info-find-node
+ "\C-c\C-b" gnus-bug))
(defun gnus-browse-make-menu-bar ()
(gnus-turn-off-edit-menu 'browse)
["Subscribe" gnus-browse-unsubscribe-current-group t]
["Read" gnus-browse-read-group t]
["Select" gnus-browse-select-group t]
+ ["Describe" gnus-browse-describe-group t]
["Next" gnus-browse-next-group t]
- ["Prev" gnus-browse-next-group t]
+ ["Prev" gnus-browse-prev-group t]
["Exit" gnus-browse-exit t]))
(gnus-run-hooks 'gnus-browse-menu-hook)))
(setq gnus-browse-current-method (gnus-server-to-method server))
(setq gnus-browse-return-buffer return-buffer)
(let* ((method gnus-browse-current-method)
+ (orig-select-method gnus-select-method)
(gnus-select-method method)
groups group)
(gnus-message 5 "Connecting to %s..." (nth 1 method))
1 "Couldn't request list: %s" (gnus-status-message method))
nil)
(t
- (gnus-get-buffer-create gnus-browse-buffer)
- (when gnus-carpal
- (gnus-carpal-setup-buffer 'browse))
- (gnus-configure-windows 'browse)
- (buffer-disable-undo)
- (let ((buffer-read-only nil))
- (erase-buffer))
- (gnus-browse-mode)
- (setq mode-line-buffer-identification
- (list
- (format
- "Gnus: %%b {%s:%s}" (car method) (cadr method))))
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(let ((cur (current-buffer)))
(goto-char (point-min))
(unless (string= gnus-ignored-newsgroups "")
(delete-matching-lines gnus-ignored-newsgroups))
- (while (not (eobp))
- (ignore-errors
- (push (cons (let ((p (point)) (name ""))
- (skip-chars-forward "^ \t\\\\")
- (setq name (buffer-substring p (point)))
- (while (eq (char-after) ?\\)
- (setq p (1+ (point)))
- (forward-char 2)
- (skip-chars-forward "^ \t\\\\")
- (setq name (concat name (buffer-substring
- p (point)))))
- name)
- (max 0 (- (1+ (read cur)) (read cur))))
- groups))
- (forward-line))))
+ ;; We treat NNTP as a special case to avoid problems with
+ ;; garbage group names like `"foo' that appear in some badly
+ ;; managed active files. -jh.
+ (if (eq (car method) 'nntp)
+ (while (not (eobp))
+ (ignore-errors
+ (push (cons
+ (mm-string-as-unibyte
+ (buffer-substring
+ (point)
+ (progn
+ (skip-chars-forward "^ \t")
+ (point))))
+ (let ((last (read cur)))
+ (cons (read cur) last)))
+ groups))
+ (forward-line))
+ (while (not (eobp))
+ (ignore-errors
+ (push (cons
+ (mm-string-as-unibyte
+ (if (eq (char-after) ?\")
+ (read cur)
+ (let ((p (point)) (name ""))
+ (skip-chars-forward "^ \t\\\\")
+ (setq name (buffer-substring p (point)))
+ (while (eq (char-after) ?\\)
+ (setq p (1+ (point)))
+ (forward-char 2)
+ (skip-chars-forward "^ \t\\\\")
+ (setq name (concat name (buffer-substring
+ p (point)))))
+ name)))
+ (let ((last (read cur)))
+ (cons (read cur) last)))
+ groups))
+ (forward-line)))))
(setq groups (sort groups
(lambda (l1 l2)
(string< (car l1) (car l2)))))
- (let ((buffer-read-only nil))
- (while groups
- (setq group (car groups))
- (insert
- (format "K%7d: %s\n" (cdr group) (car group)))
- (setq groups (cdr groups))))
- (switch-to-buffer (current-buffer))
+ (if gnus-server-browse-in-group-buffer
+ (let* ((gnus-select-method orig-select-method)
+ (gnus-group-listed-groups
+ (mapcar (lambda (group)
+ (let ((name
+ (gnus-group-prefixed-name
+ (car group) method)))
+ (gnus-set-active name (cdr group))
+ name))
+ groups)))
+ (gnus-configure-windows 'group)
+ (funcall gnus-group-prepare-function
+ gnus-level-killed 'ignore 1 'ignore))
+ (gnus-get-buffer-create gnus-browse-buffer)
+ (when gnus-carpal
+ (gnus-carpal-setup-buffer 'browse))
+ (gnus-configure-windows 'browse)
+ (buffer-disable-undo)
+ (let ((buffer-read-only nil))
+ (erase-buffer))
+ (gnus-browse-mode)
+ (setq mode-line-buffer-identification
+ (list
+ (format
+ "Gnus: %%b {%s:%s}" (car method) (cadr method))))
+ (let ((buffer-read-only nil)
+ name
+ (prefix (let ((gnus-select-method orig-select-method))
+ (gnus-group-prefixed-name "" method))))
+ (while (setq group (pop groups))
+ (gnus-add-text-properties
+ (point)
+ (prog1 (1+ (point))
+ (insert
+ (format "%c%7d: %s\n"
+ (let ((level
+ (if (string= prefix "")
+ (gnus-group-level (setq name (car group)))
+ (gnus-group-level
+ (concat prefix (setq name (car group)))))))
+ (cond
+ ((<= level gnus-level-subscribed) ? )
+ ((<= level gnus-level-unsubscribed) ?U)
+ ((= level gnus-level-zombie) ?Z)
+ (t ?K)))
+ (max 0 (- (1+ (cddr group)) (cadr group)))
+ ;; Don't decode if name is ASCII
+ (if (and (fboundp 'detect-coding-string)
+ (eq (detect-coding-string name t) 'undecided))
+ name
+ (mm-decode-coding-string
+ name
+ (inline (gnus-group-name-charset method name)))))))
+ (list 'gnus-group name)
+ )))
+ (switch-to-buffer (current-buffer)))
(goto-char (point-min))
(gnus-group-position-point)
(gnus-message 5 "Connecting to %s...done" (nth 1 method))
(setq truncate-lines t)
(gnus-set-default-directory)
(setq buffer-read-only t)
- (gnus-run-hooks 'gnus-browse-mode-hook))
+ (gnus-run-mode-hooks 'gnus-browse-mode-hook))
-(defun gnus-browse-read-group (&optional no-article)
- "Enter the group at the current line."
- (interactive)
+(defun gnus-browse-read-group (&optional no-article number)
+ "Enter the group at the current line.
+If NUMBER, fetch this number of articles."
+ (interactive "P")
(let ((group (gnus-browse-group-name)))
(if (or (not (gnus-get-info group))
(gnus-ephemeral-group-p group))
(unless (gnus-group-read-ephemeral-group
group gnus-browse-current-method nil
- (cons (current-buffer) 'browse))
+ (cons (current-buffer) 'browse)
+ nil nil nil number)
(error "Couldn't enter %s" group))
(unless (gnus-group-read-group nil no-article group)
(error "Couldn't enter %s" group)))))
-(defun gnus-browse-select-group ()
- "Select the current group."
- (interactive)
- (gnus-browse-read-group 'no))
+(defun gnus-browse-select-group (&optional number)
+ "Select the current group.
+If NUMBER, fetch this number of articles."
+ (interactive "P")
+ (gnus-browse-read-group 'no number))
(defun gnus-browse-next-group (n)
"Go to the next group."
(defun gnus-browse-group-name ()
(save-excursion
(beginning-of-line)
- (when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t)
- (gnus-group-prefixed-name
- ;; Remove text props.
- (format "%s" (match-string 1))
- gnus-browse-current-method))))
+ (let ((name (get-text-property (point) 'gnus-group)))
+ (when (re-search-forward ": \\(.*\\)$" (point-at-eol) t)
+ (concat (gnus-method-to-server-name gnus-browse-current-method) ":"
+ (or name
+ (match-string-no-properties 1)))))))
+
+(defun gnus-browse-describe-group (group)
+ "Describe the current group."
+ (interactive (list (gnus-browse-group-name)))
+ (gnus-group-describe-group nil group))
(defun gnus-browse-unsubscribe-group ()
"Toggle subscription of the current group in the browse buffer."
(save-excursion
(beginning-of-line)
;; If this group it killed, then we want to subscribe it.
- (when (eq (char-after) ?K)
+ (unless (eq (char-after) ? )
(setq sub t))
(setq group (gnus-browse-group-name))
- (when (and sub
- (cadr (gnus-gethash group gnus-newsrc-hashtb)))
- (error "Group already subscribed"))
- (delete-char 1)
+ (when (gnus-server-equal gnus-browse-current-method "native")
+ (setq group (gnus-group-real-name group)))
(if sub
(progn
;; Make sure the group has been properly removed before we
;; subscribe to it.
- (gnus-kill-ephemeral-group group)
+ (if (gnus-ephemeral-group-p group)
+ (gnus-kill-ephemeral-group group))
+ ;; We need to discern between killed/zombie groups and
+ ;; just unsubscribed ones.
(gnus-group-change-level
- (list t group gnus-level-default-subscribed
- nil nil (if (gnus-server-equal
- gnus-browse-current-method "native")
- nil
- (gnus-method-simplify
- gnus-browse-current-method)))
- gnus-level-default-subscribed gnus-level-killed
+ (or (gnus-group-entry group)
+ (list t group gnus-level-default-subscribed
+ nil nil (if (gnus-server-equal
+ gnus-browse-current-method "native")
+ nil
+ (gnus-method-simplify
+ gnus-browse-current-method))))
+ gnus-level-default-subscribed (gnus-group-level group)
(and (car (nth 1 gnus-newsrc-alist))
- (gnus-gethash (car (nth 1 gnus-newsrc-alist))
- gnus-newsrc-hashtb))
- t)
+ (gnus-group-entry (car (nth 1 gnus-newsrc-alist))))
+ (null (gnus-group-entry group)))
+ (delete-char 1)
(insert ? ))
(gnus-group-change-level
- group gnus-level-killed gnus-level-default-subscribed)
- (insert ?K)))
+ group gnus-level-unsubscribed gnus-level-default-subscribed)
+ (delete-char 1)
+ (insert ?U)))
t))
(defun gnus-browse-exit ()
"Quit browsing and return to the group buffer."
(interactive)
(when (eq major-mode 'gnus-browse-mode)
- (kill-buffer (current-buffer)))
+ (gnus-kill-buffer (current-buffer)))
;; Insert the newly subscribed groups in the group buffer.
- (save-excursion
- (set-buffer gnus-group-buffer)
+ (with-current-buffer gnus-group-buffer
(gnus-group-list-groups nil))
(if gnus-browse-return-buffer
(gnus-configure-windows 'server 'force)
(let ((server (gnus-server-server-name)))
(unless server
(error "No server on the current line"))
- (if (not (gnus-check-backend-function
- 'request-regenerate (car (gnus-server-to-method server))))
- (error "This backend doesn't support regeneration")
- (gnus-message 5 "Requesting regeneration of %s..." server)
- (unless (gnus-open-server server)
- (error "Couldn't open server"))
- (if (gnus-request-regenerate server)
- (gnus-message 5 "Requesting regeneration of %s...done" server)
- (gnus-message 5 "Couldn't regenerate %s" server)))))
+ (condition-case ()
+ (gnus-get-function (gnus-server-to-method server)
+ 'request-regenerate)
+ (error
+ (error "This back end doesn't support regeneration")))
+ (gnus-message 5 "Requesting regeneration of %s..." server)
+ (unless (gnus-open-server server)
+ (error "Couldn't open server"))
+ (if (gnus-request-regenerate server)
+ (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)
-;;; gnus-srvr.el ends here.
+;; arch-tag: c0117f64-27ca-475d-9406-8da6854c7a25
+;;; gnus-srvr.el ends here