1 |
;;; gnus-srvr.el --- virtual server support for Gnus |
;;; gnus-srvr.el --- virtual server support for Gnus |
2 |
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 |
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 |
3 |
;; Free Software Foundation, Inc. |
;; Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
34 |
(require 'gnus-int) |
(require 'gnus-int) |
35 |
(require 'gnus-range) |
(require 'gnus-range) |
36 |
|
|
37 |
(defvar gnus-server-mode-hook nil |
(defcustom gnus-server-mode-hook nil |
38 |
"Hook run in `gnus-server-mode' buffers.") |
"Hook run in `gnus-server-mode' buffers." |
39 |
|
:group 'gnus-server |
40 |
|
:type 'hook) |
41 |
|
|
42 |
|
(defcustom gnus-server-exit-hook nil |
43 |
|
"Hook run when exiting the server buffer." |
44 |
|
:group 'gnus-server |
45 |
|
:type 'hook) |
46 |
|
|
47 |
(defconst gnus-server-line-format " {%(%h:%w%)} %s\n" |
(defcustom gnus-server-line-format " {%(%h:%w%)} %s%a\n" |
48 |
"Format of server lines. |
"Format of server lines. |
49 |
It works along the same lines as a normal formatting string, |
It works along the same lines as a normal formatting string, |
50 |
with some simple extensions. |
with some simple extensions. |
54 |
%h backend |
%h backend |
55 |
%n name |
%n name |
56 |
%w address |
%w address |
57 |
%s status") |
%s status |
58 |
|
%a agent covered |
59 |
|
|
60 |
(defvar gnus-server-mode-line-format "Gnus: %%b" |
General format specifiers can also be used. |
61 |
"The format specification for the server mode line.") |
See Info node `(gnus)Formatting Variables'." |
62 |
|
:link '(custom-manual "(gnus)Formatting Variables") |
63 |
(defvar gnus-server-exit-hook nil |
:group 'gnus-server-visual |
64 |
"*Hook run when exiting the server buffer.") |
:type 'string) |
65 |
|
|
66 |
|
(defcustom gnus-server-mode-line-format "Gnus: %%b" |
67 |
|
"The format specification for the server mode line." |
68 |
|
:group 'gnus-server-visual |
69 |
|
:type 'string) |
70 |
|
|
71 |
|
(defcustom gnus-server-browse-in-group-buffer nil |
72 |
|
"Whether server browsing should take place in the group buffer. |
73 |
|
If nil, a faster, but more primitive, buffer is used instead." |
74 |
|
:group 'gnus-server-visual |
75 |
|
:type 'boolean) |
76 |
|
|
77 |
;;; Internal variables. |
;;; Internal variables. |
78 |
|
|
82 |
`((?h gnus-tmp-how ?s) |
`((?h gnus-tmp-how ?s) |
83 |
(?n gnus-tmp-name ?s) |
(?n gnus-tmp-name ?s) |
84 |
(?w gnus-tmp-where ?s) |
(?w gnus-tmp-where ?s) |
85 |
(?s gnus-tmp-status ?s))) |
(?s gnus-tmp-status ?s) |
86 |
|
(?a gnus-tmp-agent ?s))) |
87 |
|
|
88 |
(defvar gnus-server-mode-line-format-alist |
(defvar gnus-server-mode-line-format-alist |
89 |
`((?S gnus-tmp-news-server ?s) |
`((?S gnus-tmp-news-server ?s) |
105 |
(easy-menu-define |
(easy-menu-define |
106 |
gnus-server-server-menu gnus-server-mode-map "" |
gnus-server-server-menu gnus-server-mode-map "" |
107 |
'("Server" |
'("Server" |
108 |
["Add" gnus-server-add-server t] |
["Add..." gnus-server-add-server t] |
109 |
["Browse" gnus-server-read-server t] |
["Browse" gnus-server-read-server t] |
110 |
["Scan" gnus-server-scan-server t] |
["Scan" gnus-server-scan-server t] |
111 |
["List" gnus-server-list-servers t] |
["List" gnus-server-list-servers t] |
121 |
'("Connections" |
'("Connections" |
122 |
["Open" gnus-server-open-server t] |
["Open" gnus-server-open-server t] |
123 |
["Close" gnus-server-close-server t] |
["Close" gnus-server-close-server t] |
124 |
|
["Offline" gnus-server-offline-server t] |
125 |
["Deny" gnus-server-deny-server t] |
["Deny" gnus-server-deny-server t] |
126 |
"---" |
"---" |
127 |
["Open All" gnus-server-open-all-servers t] |
["Open All" gnus-server-open-all-servers t] |
138 |
(suppress-keymap gnus-server-mode-map) |
(suppress-keymap gnus-server-mode-map) |
139 |
|
|
140 |
(gnus-define-keys gnus-server-mode-map |
(gnus-define-keys gnus-server-mode-map |
141 |
" " gnus-server-read-server |
" " gnus-server-read-server-in-server-buffer |
142 |
"\r" gnus-server-read-server |
"\r" gnus-server-read-server |
143 |
gnus-mouse-2 gnus-server-pick-server |
gnus-mouse-2 gnus-server-pick-server |
144 |
"q" gnus-server-exit |
"q" gnus-server-exit |
155 |
"C" gnus-server-close-server |
"C" gnus-server-close-server |
156 |
"\M-c" gnus-server-close-all-servers |
"\M-c" gnus-server-close-all-servers |
157 |
"D" gnus-server-deny-server |
"D" gnus-server-deny-server |
158 |
|
"L" gnus-server-offline-server |
159 |
"R" gnus-server-remove-denials |
"R" gnus-server-remove-denials |
160 |
|
|
161 |
"n" next-line |
"n" next-line |
166 |
"\C-c\C-i" gnus-info-find-node |
"\C-c\C-i" gnus-info-find-node |
167 |
"\C-c\C-b" gnus-bug)) |
"\C-c\C-b" gnus-bug)) |
168 |
|
|
169 |
|
(defface gnus-server-agent-face |
170 |
|
'((((class color) (background light)) (:foreground "PaleTurquoise" :bold t)) |
171 |
|
(((class color) (background dark)) (:foreground "PaleTurquoise" :bold t)) |
172 |
|
(t (:bold t))) |
173 |
|
"Face used for displaying AGENTIZED servers" |
174 |
|
:group 'gnus-server-visual) |
175 |
|
|
176 |
|
(defface gnus-server-opened-face |
177 |
|
'((((class color) (background light)) (:foreground "Green3" :bold t)) |
178 |
|
(((class color) (background dark)) (:foreground "Green1" :bold t)) |
179 |
|
(t (:bold t))) |
180 |
|
"Face used for displaying OPENED servers" |
181 |
|
:group 'gnus-server-visual) |
182 |
|
|
183 |
|
(defface gnus-server-closed-face |
184 |
|
'((((class color) (background light)) (:foreground "Steel Blue" :italic t)) |
185 |
|
(((class color) (background dark)) |
186 |
|
(:foreground "Light Steel Blue" :italic t)) |
187 |
|
(t (:italic t))) |
188 |
|
"Face used for displaying CLOSED servers" |
189 |
|
:group 'gnus-server-visual) |
190 |
|
|
191 |
|
(defface gnus-server-denied-face |
192 |
|
'((((class color) (background light)) (:foreground "Red" :bold t)) |
193 |
|
(((class color) (background dark)) (:foreground "Pink" :bold t)) |
194 |
|
(t (:inverse-video t :bold t))) |
195 |
|
"Face used for displaying DENIED servers" |
196 |
|
:group 'gnus-server-visual) |
197 |
|
|
198 |
|
(defface gnus-server-offline-face |
199 |
|
'((((class color) (background light)) (:foreground "Orange" :bold t)) |
200 |
|
(((class color) (background dark)) (:foreground "Yellow" :bold t)) |
201 |
|
(t (:inverse-video t :bold t))) |
202 |
|
"Face used for displaying OFFLINE servers" |
203 |
|
:group 'gnus-server-visual) |
204 |
|
|
205 |
|
(defcustom gnus-server-agent-face 'gnus-server-agent-face |
206 |
|
"Face name to use on AGENTIZED servers." |
207 |
|
:group 'gnus-server-visual |
208 |
|
:type 'face) |
209 |
|
|
210 |
|
(defcustom gnus-server-opened-face 'gnus-server-opened-face |
211 |
|
"Face name to use on OPENED servers." |
212 |
|
:group 'gnus-server-visual |
213 |
|
:type 'face) |
214 |
|
|
215 |
|
(defcustom gnus-server-closed-face 'gnus-server-closed-face |
216 |
|
"Face name to use on CLOSED servers." |
217 |
|
:group 'gnus-server-visual |
218 |
|
:type 'face) |
219 |
|
|
220 |
|
(defcustom gnus-server-denied-face 'gnus-server-denied-face |
221 |
|
"Face name to use on DENIED servers." |
222 |
|
:group 'gnus-server-visual |
223 |
|
:type 'face) |
224 |
|
|
225 |
|
(defcustom gnus-server-offline-face 'gnus-server-offline-face |
226 |
|
"Face name to use on OFFLINE servers." |
227 |
|
:group 'gnus-server-visual |
228 |
|
:type 'face) |
229 |
|
|
230 |
|
(defvar gnus-server-font-lock-keywords |
231 |
|
(list |
232 |
|
'("(\\(agent\\))" 1 gnus-server-agent-face) |
233 |
|
'("(\\(opened\\))" 1 gnus-server-opened-face) |
234 |
|
'("(\\(closed\\))" 1 gnus-server-closed-face) |
235 |
|
'("(\\(offline\\))" 1 gnus-server-offline-face) |
236 |
|
'("(\\(denied\\))" 1 gnus-server-denied-face))) |
237 |
|
|
238 |
(defun gnus-server-mode () |
(defun gnus-server-mode () |
239 |
"Major mode for listing and editing servers. |
"Major mode for listing and editing servers. |
240 |
|
|
259 |
(buffer-disable-undo) |
(buffer-disable-undo) |
260 |
(setq truncate-lines t) |
(setq truncate-lines t) |
261 |
(setq buffer-read-only t) |
(setq buffer-read-only t) |
262 |
|
(if (featurep 'xemacs) |
263 |
|
(put 'gnus-server-mode 'font-lock-defaults '(gnus-server-font-lock-keywords t)) |
264 |
|
(set (make-local-variable 'font-lock-defaults) |
265 |
|
'(gnus-server-font-lock-keywords t))) |
266 |
(gnus-run-hooks 'gnus-server-mode-hook)) |
(gnus-run-hooks 'gnus-server-mode-hook)) |
267 |
|
|
268 |
(defun gnus-server-insert-server-line (gnus-tmp-name method) |
(defun gnus-server-insert-server-line (gnus-tmp-name method) |
270 |
(gnus-tmp-where (nth 1 method)) |
(gnus-tmp-where (nth 1 method)) |
271 |
(elem (assoc method gnus-opened-servers)) |
(elem (assoc method gnus-opened-servers)) |
272 |
(gnus-tmp-status |
(gnus-tmp-status |
273 |
(if (eq (nth 1 elem) 'denied) |
(cond |
274 |
"(denied)" |
((eq (nth 1 elem) 'denied) "(denied)") |
275 |
|
((eq (nth 1 elem) 'offline) "(offline)") |
276 |
|
(t |
277 |
(condition-case nil |
(condition-case nil |
278 |
(if (or (gnus-server-opened method) |
(if (or (gnus-server-opened method) |
279 |
(eq (nth 1 elem) 'ok)) |
(eq (nth 1 elem) 'ok)) |
280 |
"(opened)" |
"(opened)" |
281 |
"(closed)") |
"(closed)") |
282 |
((error) "(error)"))))) |
((error) "(error)"))))) |
283 |
|
(gnus-tmp-agent (if (and gnus-agent |
284 |
|
(gnus-agent-method-p method)) |
285 |
|
" (agent)" |
286 |
|
""))) |
287 |
(beginning-of-line) |
(beginning-of-line) |
288 |
(gnus-add-text-properties |
(gnus-add-text-properties |
289 |
(point) |
(point) |
290 |
(prog1 (1+ (point)) |
(prog1 (1+ (point)) |
291 |
;; Insert the text. |
;; Insert the text. |
292 |
(eval gnus-server-line-format-spec)) |
(eval gnus-server-line-format-spec)) |
293 |
(list 'gnus-server (intern gnus-tmp-name))))) |
(list 'gnus-server (intern gnus-tmp-name) |
294 |
|
'gnus-named-server (intern (gnus-method-to-server method)))))) |
295 |
|
|
296 |
(defun gnus-enter-server-buffer () |
(defun gnus-enter-server-buffer () |
297 |
"Set up the server buffer." |
"Set up the server buffer." |
345 |
(let ((server (get-text-property (gnus-point-at-bol) 'gnus-server))) |
(let ((server (get-text-property (gnus-point-at-bol) 'gnus-server))) |
346 |
(and server (symbol-name server)))) |
(and server (symbol-name server)))) |
347 |
|
|
348 |
|
(defun gnus-server-named-server () |
349 |
|
"Returns a server name that matches one of the names returned by |
350 |
|
gnus-method-to-server." |
351 |
|
(let ((server (get-text-property (gnus-point-at-bol) 'gnus-named-server))) |
352 |
|
(and server (symbol-name server)))) |
353 |
|
|
354 |
(defalias 'gnus-server-position-point 'gnus-goto-colon) |
(defalias 'gnus-server-position-point 'gnus-goto-colon) |
355 |
|
|
356 |
(defconst gnus-server-edit-buffer "*Gnus edit server*") |
(defconst gnus-server-edit-buffer "*Gnus edit server*") |
365 |
(when entry |
(when entry |
366 |
(gnus-dribble-enter |
(gnus-dribble-enter |
367 |
(concat "(gnus-server-set-info \"" server "\" '" |
(concat "(gnus-server-set-info \"" server "\" '" |
368 |
(prin1-to-string (cdr entry)) ")\n"))) |
(gnus-prin1-to-string (cdr entry)) ")\n"))) |
369 |
(when (or entry oentry) |
(when (or entry oentry) |
370 |
;; Buffer may be narrowed. |
;; Buffer may be narrowed. |
371 |
(save-restriction |
(save-restriction |
384 |
(when (and server info) |
(when (and server info) |
385 |
(gnus-dribble-enter |
(gnus-dribble-enter |
386 |
(concat "(gnus-server-set-info \"" server "\" '" |
(concat "(gnus-server-set-info \"" server "\" '" |
387 |
(prin1-to-string info) ")")) |
(gnus-prin1-to-string info) ")")) |
388 |
(let* ((server (nth 1 info)) |
(let* ((server (nth 1 info)) |
389 |
(entry (assoc server gnus-server-alist))) |
(entry (assoc server gnus-server-alist)) |
390 |
|
(cached (assoc server gnus-server-method-cache))) |
391 |
|
(if cached |
392 |
|
(setq gnus-server-method-cache |
393 |
|
(delq cached gnus-server-method-cache))) |
394 |
(if entry (setcdr entry info) |
(if entry (setcdr entry info) |
395 |
(setq gnus-server-alist |
(setq gnus-server-alist |
396 |
(nconc gnus-server-alist (list (cons server info)))))))) |
(nconc gnus-server-alist (list (cons server info)))))))) |
442 |
(setq alist (cdr alist))) |
(setq alist (cdr alist))) |
443 |
(if alist |
(if alist |
444 |
(setcdr alist (cons killed (cdr alist))) |
(setcdr alist (cons killed (cdr alist))) |
445 |
(setq gnus-server-alist (list killed))))) |
(setq gnus-server-alist (list killed))))) |
446 |
(gnus-server-update-server (car killed)) |
(gnus-server-update-server (car killed)) |
447 |
(setq gnus-server-killed-servers (cdr gnus-server-killed-servers)) |
(setq gnus-server-killed-servers (cdr gnus-server-killed-servers)) |
448 |
(gnus-server-position-point))) |
(gnus-server-position-point))) |
451 |
"Return to the group buffer." |
"Return to the group buffer." |
452 |
(interactive) |
(interactive) |
453 |
(gnus-run-hooks 'gnus-server-exit-hook) |
(gnus-run-hooks 'gnus-server-exit-hook) |
454 |
(kill-buffer (current-buffer)) |
(gnus-kill-buffer (current-buffer)) |
455 |
(gnus-configure-windows 'group t)) |
(gnus-configure-windows 'group t)) |
456 |
|
|
457 |
(defun gnus-server-list-servers () |
(defun gnus-server-list-servers () |
508 |
(gnus-server-update-server server) |
(gnus-server-update-server server) |
509 |
(gnus-server-position-point)))) |
(gnus-server-position-point)))) |
510 |
|
|
511 |
|
(defun gnus-server-offline-server (server) |
512 |
|
"Set SERVER to offline." |
513 |
|
(interactive (list (gnus-server-server-name))) |
514 |
|
(let ((method (gnus-server-to-method server))) |
515 |
|
(unless method |
516 |
|
(error "No such server: %s" server)) |
517 |
|
(prog1 |
518 |
|
(gnus-close-server method) |
519 |
|
(gnus-server-set-status method 'offline) |
520 |
|
(gnus-server-update-server server) |
521 |
|
(gnus-server-position-point)))) |
522 |
|
|
523 |
(defun gnus-server-close-all-servers () |
(defun gnus-server-close-all-servers () |
524 |
"Close all servers." |
"Close all servers." |
525 |
(interactive) |
(interactive) |
526 |
(let ((servers gnus-inserted-opened-servers)) |
(dolist (server gnus-inserted-opened-servers) |
527 |
(while servers |
(gnus-server-close-server (car server)))) |
|
(gnus-server-close-server (car (pop servers)))))) |
|
528 |
|
|
529 |
(defun gnus-server-deny-server (server) |
(defun gnus-server-deny-server (server) |
530 |
"Make sure SERVER will never be attempted opened." |
"Make sure SERVER will never be attempted opened." |
540 |
(defun gnus-server-remove-denials () |
(defun gnus-server-remove-denials () |
541 |
"Make all denied servers into closed servers." |
"Make all denied servers into closed servers." |
542 |
(interactive) |
(interactive) |
543 |
(let ((servers gnus-opened-servers)) |
(dolist (server gnus-opened-servers) |
544 |
(while servers |
(when (eq (nth 1 server) 'denied) |
545 |
(when (eq (nth 1 (car servers)) 'denied) |
(setcar (nthcdr 1 server) 'closed))) |
|
(setcar (nthcdr 1 (car servers)) 'closed)) |
|
|
(setq servers (cdr servers)))) |
|
546 |
(gnus-server-list-servers)) |
(gnus-server-list-servers)) |
547 |
|
|
548 |
(defun gnus-server-copy-server (from to) |
(defun gnus-server-copy-server (from to) |
612 |
(gnus-request-scan nil method) |
(gnus-request-scan nil method) |
613 |
(gnus-message 3 "Scanning %s...done" server)))) |
(gnus-message 3 "Scanning %s...done" server)))) |
614 |
|
|
615 |
|
(defun gnus-server-read-server-in-server-buffer (server) |
616 |
|
"Browse a server in server buffer." |
617 |
|
(interactive (list (gnus-server-server-name))) |
618 |
|
(let (gnus-server-browse-in-group-buffer) |
619 |
|
(gnus-server-read-server server))) |
620 |
|
|
621 |
(defun gnus-server-read-server (server) |
(defun gnus-server-read-server (server) |
622 |
"Browse a server." |
"Browse a server." |
623 |
(interactive (list (gnus-server-server-name))) |
(interactive (list (gnus-server-server-name))) |
668 |
"L" gnus-browse-exit |
"L" gnus-browse-exit |
669 |
"q" gnus-browse-exit |
"q" gnus-browse-exit |
670 |
"Q" gnus-browse-exit |
"Q" gnus-browse-exit |
671 |
|
"d" gnus-browse-describe-group |
672 |
"\C-c\C-c" gnus-browse-exit |
"\C-c\C-c" gnus-browse-exit |
673 |
"?" gnus-browse-describe-briefly |
"?" gnus-browse-describe-briefly |
674 |
|
|
684 |
["Subscribe" gnus-browse-unsubscribe-current-group t] |
["Subscribe" gnus-browse-unsubscribe-current-group t] |
685 |
["Read" gnus-browse-read-group t] |
["Read" gnus-browse-read-group t] |
686 |
["Select" gnus-browse-select-group t] |
["Select" gnus-browse-select-group t] |
687 |
|
["Describe" gnus-browse-describe-group t] |
688 |
["Next" gnus-browse-next-group t] |
["Next" gnus-browse-next-group t] |
689 |
["Prev" gnus-browse-prev-group t] |
["Prev" gnus-browse-prev-group t] |
690 |
["Exit" gnus-browse-exit t])) |
["Exit" gnus-browse-exit t])) |
700 |
(setq gnus-browse-current-method (gnus-server-to-method server)) |
(setq gnus-browse-current-method (gnus-server-to-method server)) |
701 |
(setq gnus-browse-return-buffer return-buffer) |
(setq gnus-browse-return-buffer return-buffer) |
702 |
(let* ((method gnus-browse-current-method) |
(let* ((method gnus-browse-current-method) |
703 |
|
(orig-select-method gnus-select-method) |
704 |
(gnus-select-method method) |
(gnus-select-method method) |
705 |
groups group) |
groups group) |
706 |
(gnus-message 5 "Connecting to %s..." (nth 1 method)) |
(gnus-message 5 "Connecting to %s..." (nth 1 method)) |
719 |
1 "Couldn't request list: %s" (gnus-status-message method)) |
1 "Couldn't request list: %s" (gnus-status-message method)) |
720 |
nil) |
nil) |
721 |
(t |
(t |
722 |
(gnus-get-buffer-create gnus-browse-buffer) |
(with-current-buffer nntp-server-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) |
|
723 |
(let ((cur (current-buffer))) |
(let ((cur (current-buffer))) |
724 |
(goto-char (point-min)) |
(goto-char (point-min)) |
725 |
(unless (string= gnus-ignored-newsgroups "") |
(unless (string= gnus-ignored-newsgroups "") |
726 |
(delete-matching-lines gnus-ignored-newsgroups)) |
(delete-matching-lines gnus-ignored-newsgroups)) |
727 |
(while (not (eobp)) |
;; We treat NNTP as a special case to avoid problems with |
728 |
(ignore-errors |
;; garbage group names like `"foo' that appear in some badly |
729 |
(push (cons |
;; managed active files. -jh. |
730 |
(if (eq (char-after) ?\") |
(if (eq (car method) 'nntp) |
731 |
(read cur) |
(while (not (eobp)) |
732 |
(let ((p (point)) (name "")) |
(ignore-errors |
733 |
(skip-chars-forward "^ \t\\\\") |
(push (cons |
734 |
(setq name (buffer-substring p (point))) |
(buffer-substring |
735 |
(while (eq (char-after) ?\\) |
(point) |
736 |
(setq p (1+ (point))) |
(progn |
737 |
(forward-char 2) |
(skip-chars-forward "^ \t") |
738 |
|
(point))) |
739 |
|
(let ((last (read cur))) |
740 |
|
(cons (read cur) last))) |
741 |
|
groups)) |
742 |
|
(forward-line)) |
743 |
|
(while (not (eobp)) |
744 |
|
(ignore-errors |
745 |
|
(push (cons |
746 |
|
(if (eq (char-after) ?\") |
747 |
|
(read cur) |
748 |
|
(let ((p (point)) (name "")) |
749 |
(skip-chars-forward "^ \t\\\\") |
(skip-chars-forward "^ \t\\\\") |
750 |
(setq name (concat name (buffer-substring |
(setq name (buffer-substring p (point))) |
751 |
p (point))))) |
(while (eq (char-after) ?\\) |
752 |
name)) |
(setq p (1+ (point))) |
753 |
(max 0 (- (1+ (read cur)) (read cur)))) |
(forward-char 2) |
754 |
groups)) |
(skip-chars-forward "^ \t\\\\") |
755 |
(forward-line)))) |
(setq name (concat name (buffer-substring |
756 |
|
p (point))))) |
757 |
|
name)) |
758 |
|
(let ((last (read cur))) |
759 |
|
(cons (read cur) last))) |
760 |
|
groups)) |
761 |
|
(forward-line))))) |
762 |
(setq groups (sort groups |
(setq groups (sort groups |
763 |
(lambda (l1 l2) |
(lambda (l1 l2) |
764 |
(string< (car l1) (car l2))))) |
(string< (car l1) (car l2))))) |
765 |
(let ((buffer-read-only nil) charset) |
(if gnus-server-browse-in-group-buffer |
766 |
(while groups |
(let* ((gnus-select-method orig-select-method) |
767 |
(setq group (car groups)) |
(gnus-group-listed-groups |
768 |
(setq charset (gnus-group-name-charset method group)) |
(mapcar (lambda (group) |
769 |
(gnus-add-text-properties |
(let ((name |
770 |
(point) |
(gnus-group-prefixed-name |
771 |
(prog1 (1+ (point)) |
(car group) method))) |
772 |
(insert |
(gnus-set-active name (cdr group)) |
773 |
(format "K%7d: %s\n" (cdr group) |
name)) |
774 |
(gnus-group-name-decode (car group) charset)))) |
groups))) |
775 |
(list 'gnus-group (car group))) |
(gnus-configure-windows 'group) |
776 |
(setq groups (cdr groups)))) |
(funcall gnus-group-prepare-function |
777 |
(switch-to-buffer (current-buffer)) |
gnus-level-killed 'ignore 1 'ignore)) |
778 |
|
(gnus-get-buffer-create gnus-browse-buffer) |
779 |
|
(when gnus-carpal |
780 |
|
(gnus-carpal-setup-buffer 'browse)) |
781 |
|
(gnus-configure-windows 'browse) |
782 |
|
(buffer-disable-undo) |
783 |
|
(let ((buffer-read-only nil)) |
784 |
|
(erase-buffer)) |
785 |
|
(gnus-browse-mode) |
786 |
|
(setq mode-line-buffer-identification |
787 |
|
(list |
788 |
|
(format |
789 |
|
"Gnus: %%b {%s:%s}" (car method) (cadr method)))) |
790 |
|
(let ((buffer-read-only nil) |
791 |
|
name |
792 |
|
(prefix (let ((gnus-select-method orig-select-method)) |
793 |
|
(gnus-group-prefixed-name "" method)))) |
794 |
|
(while (setq group (pop groups)) |
795 |
|
(gnus-add-text-properties |
796 |
|
(point) |
797 |
|
(prog1 (1+ (point)) |
798 |
|
(insert |
799 |
|
(format "%c%7d: %s\n" |
800 |
|
(let ((level (gnus-group-level |
801 |
|
(concat prefix (setq name (car group)))))) |
802 |
|
(cond |
803 |
|
((<= level gnus-level-subscribed) ? ) |
804 |
|
((<= level gnus-level-unsubscribed) ?U) |
805 |
|
((= level gnus-level-zombie) ?Z) |
806 |
|
(t ?K))) |
807 |
|
(max 0 (- (1+ (cddr group)) (cadr group))) |
808 |
|
(mm-decode-coding-string |
809 |
|
name |
810 |
|
(inline (gnus-group-name-charset method name)))))) |
811 |
|
(list 'gnus-group name)))) |
812 |
|
(switch-to-buffer (current-buffer))) |
813 |
(goto-char (point-min)) |
(goto-char (point-min)) |
814 |
(gnus-group-position-point) |
(gnus-group-position-point) |
815 |
(gnus-message 5 "Connecting to %s...done" (nth 1 method)) |
(gnus-message 5 "Connecting to %s...done" (nth 1 method)) |
852 |
(if (or (not (gnus-get-info group)) |
(if (or (not (gnus-get-info group)) |
853 |
(gnus-ephemeral-group-p group)) |
(gnus-ephemeral-group-p group)) |
854 |
(unless (gnus-group-read-ephemeral-group |
(unless (gnus-group-read-ephemeral-group |
855 |
(gnus-group-real-name group) gnus-browse-current-method nil |
group gnus-browse-current-method nil |
856 |
(cons (current-buffer) 'browse)) |
(cons (current-buffer) 'browse)) |
857 |
(error "Couldn't enter %s" group)) |
(error "Couldn't enter %s" group)) |
858 |
(unless (gnus-group-read-group nil no-article group) |
(unless (gnus-group-read-group nil no-article group) |
897 |
(beginning-of-line) |
(beginning-of-line) |
898 |
(let ((name (get-text-property (point) 'gnus-group))) |
(let ((name (get-text-property (point) 'gnus-group))) |
899 |
(when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t) |
(when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t) |
900 |
(gnus-group-prefixed-name |
(concat (gnus-method-to-server-name gnus-browse-current-method) ":" |
901 |
(or name |
(or name |
902 |
(match-string-no-properties 1)) |
(match-string-no-properties 1))))))) |
903 |
gnus-browse-current-method))))) |
|
904 |
|
(defun gnus-browse-describe-group (group) |
905 |
|
"Describe the current group." |
906 |
|
(interactive (list (gnus-browse-group-name))) |
907 |
|
(gnus-group-describe-group nil group)) |
908 |
|
|
909 |
(defun gnus-browse-unsubscribe-group () |
(defun gnus-browse-unsubscribe-group () |
910 |
"Toggle subscription of the current group in the browse buffer." |
"Toggle subscription of the current group in the browse buffer." |
914 |
(save-excursion |
(save-excursion |
915 |
(beginning-of-line) |
(beginning-of-line) |
916 |
;; If this group it killed, then we want to subscribe it. |
;; If this group it killed, then we want to subscribe it. |
917 |
(when (eq (char-after) ?K) |
(unless (eq (char-after) ? ) |
918 |
(setq sub t)) |
(setq sub t)) |
919 |
(setq group (gnus-browse-group-name)) |
(setq group (gnus-browse-group-name)) |
920 |
(when (and sub |
(when (gnus-server-equal gnus-browse-current-method "native") |
921 |
(cadr (gnus-gethash group gnus-newsrc-hashtb))) |
(setq group (gnus-group-real-name group))) |
|
(error "Group already subscribed")) |
|
|
(delete-char 1) |
|
922 |
(if sub |
(if sub |
923 |
(progn |
(progn |
924 |
;; Make sure the group has been properly removed before we |
;; Make sure the group has been properly removed before we |
931 |
nil |
nil |
932 |
(gnus-method-simplify |
(gnus-method-simplify |
933 |
gnus-browse-current-method))) |
gnus-browse-current-method))) |
934 |
gnus-level-default-subscribed gnus-level-killed |
gnus-level-default-subscribed (gnus-group-level group) |
935 |
(and (car (nth 1 gnus-newsrc-alist)) |
(and (car (nth 1 gnus-newsrc-alist)) |
936 |
(gnus-gethash (car (nth 1 gnus-newsrc-alist)) |
(gnus-gethash (car (nth 1 gnus-newsrc-alist)) |
937 |
gnus-newsrc-hashtb)) |
gnus-newsrc-hashtb)) |
938 |
t) |
t) |
939 |
|
(delete-char 1) |
940 |
(insert ? )) |
(insert ? )) |
941 |
(gnus-group-change-level |
(gnus-group-change-level |
942 |
group gnus-level-killed gnus-level-default-subscribed) |
group gnus-level-unsubscribed gnus-level-default-subscribed) |
943 |
(insert ?K))) |
(delete-char 1) |
944 |
|
(insert ?U))) |
945 |
t)) |
t)) |
946 |
|
|
947 |
(defun gnus-browse-exit () |
(defun gnus-browse-exit () |
948 |
"Quit browsing and return to the group buffer." |
"Quit browsing and return to the group buffer." |
949 |
(interactive) |
(interactive) |
950 |
(when (eq major-mode 'gnus-browse-mode) |
(when (eq major-mode 'gnus-browse-mode) |
951 |
(kill-buffer (current-buffer))) |
(gnus-kill-buffer (current-buffer))) |
952 |
;; Insert the newly subscribed groups in the group buffer. |
;; Insert the newly subscribed groups in the group buffer. |
953 |
(save-excursion |
(save-excursion |
954 |
(set-buffer gnus-group-buffer) |
(set-buffer gnus-group-buffer) |
969 |
(let ((server (gnus-server-server-name))) |
(let ((server (gnus-server-server-name))) |
970 |
(unless server |
(unless server |
971 |
(error "No server on the current line")) |
(error "No server on the current line")) |
972 |
(if (not (gnus-check-backend-function |
(condition-case () |
973 |
'request-regenerate (car (gnus-server-to-method server)))) |
(gnus-get-function (gnus-server-to-method server) |
974 |
(error "This backend doesn't support regeneration") |
'request-regenerate) |
975 |
(gnus-message 5 "Requesting regeneration of %s..." server) |
(error |
976 |
(unless (gnus-open-server server) |
(error "This backend doesn't support regeneration"))) |
977 |
(error "Couldn't open server")) |
(gnus-message 5 "Requesting regeneration of %s..." server) |
978 |
(if (gnus-request-regenerate server) |
(unless (gnus-open-server server) |
979 |
(gnus-message 5 "Requesting regeneration of %s...done" server) |
(error "Couldn't open server")) |
980 |
(gnus-message 5 "Couldn't regenerate %s" server))))) |
(if (gnus-request-regenerate server) |
981 |
|
(gnus-message 5 "Requesting regeneration of %s...done" server) |
982 |
|
(gnus-message 5 "Couldn't regenerate %s" server)))) |
983 |
|
|
984 |
(provide 'gnus-srvr) |
(provide 'gnus-srvr) |
985 |
|
|