X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-srvr.el;h=2b13f39ddb0933e95b97d2a6425c33eb5b616bad;hb=e44f0590c1c1663e783b0f7b9db81263b31495cb;hp=19dc60c58444e24590a817a2a668c0f8ffec418b;hpb=babe54cf5412efcfc7159935a3fb6d766ddf21f1;p=gnus diff --git a/lisp/gnus-srvr.el b/lisp/gnus-srvr.el index 19dc60c58..2b13f39dd 100644 --- a/lisp/gnus-srvr.el +++ b/lisp/gnus-srvr.el @@ -1,16 +1,17 @@ ;;; gnus-srvr.el --- virtual server support for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 -;; Free Software Foundation, Inc. + +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, +;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; 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 @@ -18,9 +19,7 @@ ;; 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 . ;;; Commentary: @@ -29,35 +28,52 @@ (eval-when-compile (require 'cl)) (require 'gnus) +(require 'gnus-start) (require 'gnus-spec) (require 'gnus-group) (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%a\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 -%a agent covered") - -(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.") - -(defvar gnus-server-browse-in-group-buffer t - "Whether browse server in group buffer.") +%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. @@ -90,7 +106,7 @@ The following specs are understood: (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] @@ -99,6 +115,7 @@ The following specs are understood: ["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 @@ -106,6 +123,7 @@ The following specs are understood: '("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] @@ -139,6 +157,7 @@ The following specs are understood: "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 @@ -146,16 +165,76 @@ The following specs are understood: "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. \\ For more in-depth information on this mode, read the manual -(`\\[gnus-info-find-node]'). +\(`\\[gnus-info-find-node]'). The following commands are available: @@ -173,22 +252,29 @@ 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 - (member method - gnus-agent-covered-methods)) + (gnus-agent-method-p method)) " (agent)" ""))) (beginning-of-line) @@ -197,19 +283,24 @@ The following commands are available: (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))))) @@ -219,7 +310,6 @@ The following commands are available: (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) @@ -227,28 +317,33 @@ The following commands are available: (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) @@ -256,8 +351,7 @@ The following commands are available: (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) @@ -265,7 +359,7 @@ The following commands are available: (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 @@ -284,10 +378,21 @@ The following commands are available: (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)))))))) @@ -338,7 +443,7 @@ The following commands are available: (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))) @@ -347,7 +452,7 @@ The following commands are available: "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 () @@ -388,9 +493,8 @@ The following commands are available: (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." @@ -404,10 +508,24 @@ The following commands are available: (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) (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) @@ -430,6 +548,7 @@ The following commands are available: (gnus-server-list-servers)) (defun gnus-server-copy-server (from to) + "Copy a server definiton to a new name." (interactive (list (or (gnus-server-server-name) @@ -452,8 +571,9 @@ The following commands are available: (defun gnus-server-add-server (how where) (interactive - (list (intern (completing-read "Server method: " - gnus-valid-select-methods nil t)) + (list (intern (gnus-completing-read "Server method" + (mapcar 'car gnus-valid-select-methods) + t)) (read-string "Server name: "))) (when (assq where gnus-server-alist) (error "Server with that name already defined")) @@ -463,7 +583,7 @@ The following commands are available: (defun gnus-server-goto-server (server) "Jump to a server line." (interactive - (list (completing-read "Goto server: " gnus-server-alist nil t))) + (list (gnus-completing-read "Goto server" (mapcar 'car gnus-server-alist) t))) (let ((to (text-property-any (point-min) (point-max) 'gnus-server (intern server)))) (when to @@ -484,7 +604,8 @@ The following commands are available: `(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." @@ -508,8 +629,7 @@ The following commands are available: (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))))) @@ -526,6 +646,30 @@ The following commands are available: (defvar gnus-browse-menu-hook nil "*Hook run after the creation of the browse mode menu.") +(defcustom gnus-browse-subscribe-newsgroup-method + 'gnus-subscribe-alphabetically + "Function(s) called when subscribing groups in the Browse Server Buffer +A few pre-made functions are supplied: `gnus-subscribe-randomly' +inserts new groups at the beginning of the list of groups; +`gnus-subscribe-alphabetically' inserts new groups in strict +alphabetic order; `gnus-subscribe-hierarchically' inserts new groups +in hierarchical newsgroup order; `gnus-subscribe-interactively' asks +for your decision; `gnus-subscribe-killed' kills all new groups; +`gnus-subscribe-zombies' will make all new groups into zombies; +`gnus-subscribe-topics' will enter groups into the topics that +claim them." + :version "24.1" + :group 'gnus-server + :type '(radio (function-item gnus-subscribe-randomly) + (function-item gnus-subscribe-alphabetically) + (function-item gnus-subscribe-hierarchically) + (function-item gnus-subscribe-interactively) + (function-item gnus-subscribe-killed) + (function-item gnus-subscribe-zombies) + (function-item gnus-subscribe-topics) + function + (repeat function))) + (defvar gnus-browse-mode-hook nil) (defvar gnus-browse-mode-map nil) (put 'gnus-browse-mode 'mode-class 'special) @@ -552,6 +696,7 @@ The following commands are available: "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 @@ -567,6 +712,7 @@ The following commands are available: ["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-prev-group t] ["Exit" gnus-browse-exit t])) @@ -601,31 +747,48 @@ The following commands are available: 1 "Couldn't request list: %s" (gnus-status-message method)) nil) (t - (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 - (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)))) + ;; 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))))) @@ -641,7 +804,7 @@ The following commands are available: groups))) (gnus-configure-windows 'group) (funcall gnus-group-prepare-function - gnus-level-killed 'ignore 1 'ingore)) + gnus-level-killed 'ignore 1 'ignore)) (gnus-get-buffer-create gnus-browse-buffer) (when gnus-carpal (gnus-carpal-setup-buffer 'browse)) @@ -654,29 +817,36 @@ The following commands are available: (list (format "Gnus: %%b {%s:%s}" (car method) (cadr method)))) - (let ((buffer-read-only nil) charset) - (while groups - (setq group (car groups)) - (setq charset (gnus-group-name-charset method group)) + (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 - (let ((gnus-select-method orig-select-method)) + (if (string= prefix "") + (gnus-group-level (setq name (car group))) (gnus-group-level - (gnus-group-prefixed-name (car group) - method))))) - (cond - ((<= level gnus-level-subscribed) ? ) - ((<= level gnus-level-unsubscribed) ?U) - ((= level gnus-level-zombie) ?Z) - (t ?K))) + (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))) - (gnus-group-name-decode (car group) charset)))) - (list 'gnus-group (car group))) - (setq groups (cdr groups)))) + ;; 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) @@ -711,25 +881,28 @@ buffer. (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 - (gnus-group-real-name group) gnus-browse-current-method nil - (cons (current-buffer) 'browse)) + group gnus-browse-current-method nil + (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." @@ -744,7 +917,9 @@ buffer. (gnus-browse-next-group (- n))) (defun gnus-browse-unsubscribe-current-group (arg) - "(Un)subscribe to the next ARG groups." + "(Un)subscribe to the next ARG groups. +The variable `gnus-browse-subscribe-newsgroup-method' determines +how new groups will be entered into the group buffer." (interactive "p") (when (eobp) (error "No group at current line")) @@ -764,11 +939,15 @@ buffer. (save-excursion (beginning-of-line) (let ((name (get-text-property (point) 'gnus-group))) - (when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t) - (gnus-group-prefixed-name - (or name - (match-string-no-properties 1)) - gnus-browse-current-method))))) + (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." @@ -781,29 +960,32 @@ buffer. (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")) + (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) - (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-group-level group) - (and (car (nth 1 gnus-newsrc-alist)) - (gnus-gethash (car (nth 1 gnus-newsrc-alist)) - gnus-newsrc-hashtb)) - t) + (if (gnus-ephemeral-group-p group) + (gnus-kill-ephemeral-group group)) + (let ((entry (gnus-group-entry group))) + (if entry + ;; Just change the subscription level if it is an + ;; unsubscribed group. + (gnus-group-change-level entry + gnus-level-default-subscribed) + ;; If it is a killed group or a zombie, feed it to the + ;; mechanism for new group subscription. + (gnus-call-subscribe-functions + gnus-browse-subscribe-newsgroup-method + group))) (delete-char 1) - (insert ? )) + (insert (let ((lvl (gnus-group-level group))) + (cond + ((< lvl gnus-level-unsubscribed) ? ) + ((< lvl gnus-level-zombie) ?U) + ((< lvl gnus-level-killed) ?Z) + (t ?K))))) (gnus-group-change-level group gnus-level-unsubscribed gnus-level-default-subscribed) (delete-char 1) @@ -814,10 +996,9 @@ buffer. "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) @@ -826,7 +1007,7 @@ buffer. (defun gnus-browse-describe-briefly () "Give a one line description of the group mode commands." (interactive) - (gnus-message 6 + (gnus-message 6 "%s" (substitute-command-keys "\\\\[gnus-group-next-group]:Forward \\[gnus-group-prev-group]:Backward \\[gnus-browse-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-browse-describe-briefly]:This help"))) (defun gnus-server-regenerate-server () @@ -839,7 +1020,7 @@ buffer. (gnus-get-function (gnus-server-to-method server) 'request-regenerate) (error - (error "This backend doesn't support regeneration"))) + (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")) @@ -847,6 +1028,40 @@ buffer. (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