1 ;;; gnus-srvr.el --- virtual server support for Gnus
2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA.
35 (defvar gnus-server-mode-hook nil
36 "Hook run in `gnus-server-mode' buffers.")
38 (defconst gnus-server-line-format " {%(%h:%w%)} %s\n"
39 "Format of server lines.
40 It works along the same lines as a normal formatting string,
41 with some simple extensions.")
43 (defvar gnus-server-mode-line-format "Gnus List of servers"
44 "The format specification for the server mode line.")
46 (defvar gnus-server-exit-hook nil
47 "*Hook run when exiting the server buffer.")
49 ;;; Internal variables.
51 (defvar gnus-inserted-opened-servers nil)
53 (defvar gnus-server-line-format-alist
59 (defvar gnus-server-mode-line-format-alist
62 (?u user-defined ?s)))
64 (defvar gnus-server-line-format-spec nil)
65 (defvar gnus-server-mode-line-format-spec nil)
66 (defvar gnus-server-killed-servers nil)
68 (defvar gnus-server-mode-map)
70 (defvar gnus-server-menu-hook nil
71 "*Hook run after the creation of the server mode menu.")
73 (defun gnus-server-make-menu-bar ()
74 (gnus-turn-off-edit-menu 'server)
75 (unless (boundp 'gnus-server-server-menu)
77 gnus-server-server-menu gnus-server-mode-map ""
79 ["Add" gnus-server-add-server t]
80 ["Browse" gnus-server-read-server t]
81 ["List" gnus-server-list-servers t]
82 ["Kill" gnus-server-kill-server t]
83 ["Yank" gnus-server-yank-server t]
84 ["Copy" gnus-server-copy-server t]
85 ["Edit" gnus-server-edit-server t]
86 ["Exit" gnus-server-exit t]
90 gnus-server-connections-menu gnus-server-mode-map ""
92 ["Open" gnus-server-open-server t]
93 ["Close" gnus-server-close-server t]
94 ["Deny" gnus-server-deny-server t]
96 ["Open All" gnus-server-open-all-servers t]
97 ["Close All" gnus-server-close-all-servers t]
98 ["Reset All" gnus-server-remove-denials t]
101 (run-hooks 'gnus-server-menu-hook)))
103 (defvar gnus-server-mode-map nil)
104 (put 'gnus-server-mode 'mode-class 'special)
106 (unless gnus-server-mode-map
107 (setq gnus-server-mode-map (make-sparse-keymap))
108 (suppress-keymap gnus-server-mode-map)
112 " " gnus-server-read-server
113 "\r" gnus-server-read-server
114 gnus-mouse-2 gnus-server-pick-server
116 "l" gnus-server-list-servers
117 "k" gnus-server-kill-server
118 "y" gnus-server-yank-server
119 "c" gnus-server-copy-server
120 "a" gnus-server-add-server
121 "e" gnus-server-edit-server
123 "O" gnus-server-open-server
124 "\M-o" gnus-server-open-all-servers
125 "C" gnus-server-close-server
126 "\M-c" gnus-server-close-all-servers
127 "D" gnus-server-deny-server
128 "R" gnus-server-remove-denials
130 "\C-c\C-i" gnus-info-find-node))
132 (defun gnus-server-mode ()
133 "Major mode for listing and editing servers.
135 All normal editing commands are switched off.
136 \\<gnus-server-mode-map>
137 For more in-depth information on this mode, read the manual
138 (`\\[gnus-info-find-node]').
140 The following commands are available:
142 \\{gnus-server-mode-map}"
144 (when (and menu-bar-mode
145 (gnus-visual-p 'server-menu 'menu))
146 (gnus-server-make-menu-bar))
147 (kill-all-local-variables)
148 (gnus-simplify-mode-line)
149 (setq major-mode 'gnus-server-mode)
150 (setq mode-name "Server")
151 (gnus-set-default-directory)
152 (setq mode-line-process nil)
153 (use-local-map gnus-server-mode-map)
154 (buffer-disable-undo (current-buffer))
155 (setq truncate-lines t)
156 (setq buffer-read-only t)
157 (run-hooks 'gnus-server-mode-hook))
159 (defun gnus-server-insert-server-line (name method)
160 (let* ((how (car method))
161 (where (nth 1 method))
162 (elem (assoc method gnus-opened-servers))
163 (status (cond ((eq (nth 1 elem) 'denied)
165 ((or (gnus-server-opened method)
166 (eq (nth 1 elem) 'ok))
171 (gnus-add-text-properties
175 (eval gnus-server-line-format-spec))
176 (list 'gnus-server (intern name)))))
178 (defun gnus-enter-server-buffer ()
179 "Set up the server buffer."
180 (gnus-server-setup-buffer)
181 (gnus-configure-windows 'server)
182 (gnus-server-prepare))
184 (defun gnus-server-setup-buffer ()
185 "Initialize the server buffer."
186 (unless (get-buffer gnus-server-buffer)
188 (set-buffer (get-buffer-create gnus-server-buffer))
191 (gnus-carpal-setup-buffer 'server)))))
193 (defun gnus-server-prepare ()
194 (setq gnus-server-mode-line-format-spec
195 (gnus-parse-format gnus-server-mode-line-format
196 gnus-server-mode-line-format-alist))
197 (setq gnus-server-line-format-spec
198 (gnus-parse-format gnus-server-line-format
199 gnus-server-line-format-alist t))
200 (let ((alist gnus-server-alist)
201 (buffer-read-only nil)
202 (opened gnus-opened-servers)
205 (setq gnus-inserted-opened-servers nil)
206 ;; First we do the real list of servers.
208 (push (cdr (setq server (pop alist))) done)
209 (when (and server (car server) (cdr server))
210 (gnus-server-insert-server-line (car server) (cdr server))))
211 ;; Then we insert the list of servers that have been opened in
214 (unless (member (caar opened) done)
215 (gnus-server-insert-server-line
216 (setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened))))
218 (push (list op-ser (caar opened)) gnus-inserted-opened-servers))
219 (setq opened (cdr opened))))
220 (goto-char (point-min))
221 (gnus-server-position-point))
223 (defun gnus-server-server-name ()
224 (let ((server (get-text-property (gnus-point-at-bol) 'gnus-server)))
225 (and server (symbol-name server))))
227 (defalias 'gnus-server-position-point 'gnus-goto-colon)
229 (defconst gnus-server-edit-buffer "*Gnus edit server*")
231 (defun gnus-server-update-server (server)
233 (set-buffer gnus-server-buffer)
234 (let* ((buffer-read-only nil)
235 (entry (assoc server gnus-server-alist))
236 (oentry (assoc (gnus-server-to-method server)
237 gnus-opened-servers)))
240 (concat "(gnus-server-set-info \"" server "\" '"
241 (prin1-to-string (cdr entry)) ")")))
242 (when (or entry oentry)
243 ;; Buffer may be narrowed.
246 (when (gnus-server-goto-server server)
249 (gnus-server-insert-server-line (car entry) (cdr entry))
250 (gnus-server-insert-server-line
251 (format "%s:%s" (caar oentry) (nth 1 (car oentry)))
253 (gnus-server-position-point))))))
255 (defun gnus-server-set-info (server info)
256 ;; Enter a select method into the virtual server alist.
257 (when (and server info)
259 (concat "(gnus-server-set-info \"" server "\" '"
260 (prin1-to-string info) ")"))
261 (let* ((server (nth 1 info))
262 (entry (assoc server gnus-server-alist)))
263 (if entry (setcdr entry info)
264 (setq gnus-server-alist
265 (nconc gnus-server-alist (list (cons server info))))))))
267 ;;; Interactive server functions.
269 (defun gnus-server-kill-server (server)
270 "Kill the server on the current line."
271 (interactive (list (gnus-server-server-name)))
272 (unless (gnus-server-goto-server server)
273 (if server (error "No such server: %s" server)
274 (error "No server on the current line")))
275 (unless (assoc server gnus-server-alist)
276 (error "Read-only server %s" server))
277 (gnus-dribble-enter "")
278 (let ((buffer-read-only nil))
280 (setq gnus-server-killed-servers
281 (cons (assoc server gnus-server-alist) gnus-server-killed-servers))
282 (setq gnus-server-alist (delq (car gnus-server-killed-servers)
284 (gnus-server-position-point))
286 (defun gnus-server-yank-server ()
287 "Yank the previously killed server."
289 (or gnus-server-killed-servers
290 (error "No killed servers to be yanked"))
291 (let ((alist gnus-server-alist)
292 (server (gnus-server-server-name))
293 (killed (car gnus-server-killed-servers)))
295 (setq gnus-server-alist (nconc gnus-server-alist (list killed)))
296 (if (string= server (caar gnus-server-alist))
297 (setq gnus-server-alist (cons killed gnus-server-alist))
298 (while (and (cdr alist)
299 (not (string= server (caadr alist))))
300 (setq alist (cdr alist)))
302 (setcdr alist (cons killed (cdr alist)))
303 (setq gnus-server-alist (list killed)))))
304 (gnus-server-update-server (car killed))
305 (setq gnus-server-killed-servers (cdr gnus-server-killed-servers))
306 (gnus-server-position-point)))
308 (defun gnus-server-exit ()
309 "Return to the group buffer."
311 (kill-buffer (current-buffer))
312 (switch-to-buffer gnus-group-buffer)
313 (run-hooks 'gnus-server-exit-hook))
315 (defun gnus-server-list-servers ()
316 "List all available servers."
318 (let ((cur (gnus-server-server-name)))
319 (gnus-server-prepare)
320 (if cur (gnus-server-goto-server cur)
321 (goto-char (point-max))
323 (gnus-server-position-point)))
325 (defun gnus-server-set-status (method status)
326 "Make METHOD have STATUS."
327 (let ((entry (assoc method gnus-opened-servers)))
329 (setcar (cdr entry) status)
330 (push (list method status) gnus-opened-servers))))
332 (defun gnus-opened-servers-remove (method)
333 "Remove METHOD from the list of opened servers."
334 (setq gnus-opened-servers (delq (assoc method gnus-opened-servers)
335 gnus-opened-servers)))
337 (defun gnus-server-open-server (server)
338 "Force an open of SERVER."
339 (interactive (list (gnus-server-server-name)))
340 (let ((method (gnus-server-to-method server)))
341 (or method (error "No such server: %s" server))
342 (gnus-server-set-status method 'ok)
344 (or (gnus-open-server method)
345 (progn (message "Couldn't open %s" server) nil))
346 (gnus-server-update-server server)
347 (gnus-server-position-point))))
349 (defun gnus-server-open-all-servers ()
352 (let ((servers gnus-inserted-opened-servers))
354 (gnus-server-open-server (car (pop servers))))))
356 (defun gnus-server-close-server (server)
358 (interactive (list (gnus-server-server-name)))
359 (let ((method (gnus-server-to-method server)))
360 (or method (error "No such server: %s" server))
361 (gnus-server-set-status method 'closed)
363 (gnus-close-server method)
364 (gnus-server-update-server server)
365 (gnus-server-position-point))))
367 (defun gnus-server-close-all-servers ()
370 (let ((servers gnus-inserted-opened-servers))
372 (gnus-server-close-server (car (pop servers))))))
374 (defun gnus-server-deny-server (server)
375 "Make sure SERVER will never be attempted opened."
376 (interactive (list (gnus-server-server-name)))
377 (let ((method (gnus-server-to-method server)))
378 (or method (error "No such server: %s" server))
379 (gnus-server-set-status method 'denied))
380 (gnus-server-update-server server)
381 (gnus-server-position-point)
384 (defun gnus-server-remove-denials ()
385 "Make all denied servers into closed servers."
387 (let ((servers gnus-opened-servers))
389 (when (eq (nth 1 (car servers)) 'denied)
390 (setcar (nthcdr 1 (car servers)) 'closed))
391 (setq servers (cdr servers))))
392 (gnus-server-list-servers))
394 (defun gnus-server-copy-server (from to)
397 (or (gnus-server-server-name)
398 (error "No server on the current line"))
399 (read-string "Copy to: ")))
400 (or from (error "No server on current line"))
401 (or (and to (not (string= to ""))) (error "No name to copy to"))
402 (and (assoc to gnus-server-alist) (error "%s already exists" to))
403 (or (assoc from gnus-server-alist)
404 (error "%s: no such server" from))
405 (let ((to-entry (gnus-copy-sequence (assoc from gnus-server-alist))))
407 (setcar (nthcdr 2 to-entry) to)
408 (setq gnus-server-killed-servers
409 (cons to-entry gnus-server-killed-servers))
410 (gnus-server-yank-server)))
412 (defun gnus-server-add-server (how where)
414 (list (intern (completing-read "Server method: "
415 gnus-valid-select-methods nil t))
416 (read-string "Server name: ")))
417 (setq gnus-server-killed-servers
418 (cons (list where how where) gnus-server-killed-servers))
419 (gnus-server-yank-server))
421 (defun gnus-server-goto-server (server)
422 "Jump to a server line."
424 (list (completing-read "Goto server: " gnus-server-alist nil t)))
425 (let ((to (text-property-any (point-min) (point-max)
426 'gnus-server (intern server))))
430 (gnus-server-position-point)))))
432 (defun gnus-server-edit-server (server)
433 "Edit the server on the current line."
434 (interactive (list (gnus-server-server-name)))
436 (error "No server on current line"))
437 (unless (assoc server gnus-server-alist)
438 (error "This server can't be edited"))
439 (let ((info (cdr (assoc server gnus-server-alist))))
440 (gnus-close-server info)
442 info "Editing the server."
444 (gnus-server-set-info ,server form)
445 (gnus-server-list-servers)
446 (gnus-server-position-point)))))
448 (defun gnus-server-read-server (server)
450 (interactive (list (gnus-server-server-name)))
451 (let ((buf (current-buffer)))
453 (gnus-browse-foreign-server (gnus-server-to-method server) buf)
456 (gnus-server-update-server (gnus-server-server-name))
457 (gnus-server-position-point)))))
459 (defun gnus-server-pick-server (e)
462 (gnus-server-read-server (gnus-server-server-name)))
466 ;;; Browse Server Mode
469 (defvar gnus-browse-menu-hook nil
470 "*Hook run after the creation of the browse mode menu.")
472 (defvar gnus-browse-mode-hook nil)
473 (defvar gnus-browse-mode-map nil)
474 (put 'gnus-browse-mode 'mode-class 'special)
476 (unless gnus-browse-mode-map
477 (setq gnus-browse-mode-map (make-keymap))
478 (suppress-keymap gnus-browse-mode-map)
482 " " gnus-browse-read-group
483 "=" gnus-browse-select-group
484 "n" gnus-browse-next-group
485 "p" gnus-browse-prev-group
486 "\177" gnus-browse-prev-group
487 "N" gnus-browse-next-group
488 "P" gnus-browse-prev-group
489 "\M-n" gnus-browse-next-group
490 "\M-p" gnus-browse-prev-group
491 "\r" gnus-browse-select-group
492 "u" gnus-browse-unsubscribe-current-group
497 "\C-c\C-c" gnus-browse-exit
498 "?" gnus-browse-describe-briefly
500 "\C-c\C-i" gnus-info-find-node))
502 (defun gnus-browse-make-menu-bar ()
503 (gnus-turn-off-edit-menu 'browse)
504 (unless (boundp 'gnus-browse-menu)
506 gnus-browse-menu gnus-browse-mode-map ""
508 ["Subscribe" gnus-browse-unsubscribe-current-group t]
509 ["Read" gnus-browse-read-group t]
510 ["Select" gnus-browse-read-group t]
511 ["Next" gnus-browse-next-group t]
512 ["Prev" gnus-browse-next-group t]
513 ["Exit" gnus-browse-exit t]
515 (run-hooks 'gnus-browse-menu-hook)))
517 (defvar gnus-browse-current-method nil)
518 (defvar gnus-browse-return-buffer nil)
520 (defvar gnus-browse-buffer "*Gnus Browse Server*")
522 (defun gnus-browse-foreign-server (method &optional return-buffer)
523 "Browse the server METHOD."
524 (setq gnus-browse-current-method method)
525 (setq gnus-browse-return-buffer return-buffer)
526 (let ((gnus-select-method method)
528 (gnus-message 5 "Connecting to %s..." (nth 1 method))
530 ((not (gnus-check-server method))
532 1 "Unable to contact server: %s" (gnus-status-message method))
534 ((not (gnus-request-list method))
536 1 "Couldn't request list: %s" (gnus-status-message method))
539 (get-buffer-create gnus-browse-buffer)
540 (gnus-add-current-to-buffer-list)
541 (and gnus-carpal (gnus-carpal-setup-buffer 'browse))
542 (gnus-configure-windows 'browse)
543 (buffer-disable-undo (current-buffer))
544 (let ((buffer-read-only nil))
547 (setq mode-line-buffer-identification
550 "Gnus: %%b {%s:%s}" (car method) (cadr method))))
552 (set-buffer nntp-server-buffer)
553 (let ((cur (current-buffer)))
554 (goto-char (point-min))
555 (or (string= gnus-ignored-newsgroups "")
556 (delete-matching-lines gnus-ignored-newsgroups))
557 (while (re-search-forward
558 "\\(^[^ \t]+\\)[ \t]+[0-9]+[ \t]+[0-9]+" nil t)
559 (goto-char (match-end 1))
560 (setq groups (cons (cons (match-string 1)
561 (max 0 (- (1+ (read cur)) (read cur))))
563 (setq groups (sort groups
565 (string< (car l1) (car l2)))))
566 (let ((buffer-read-only nil))
568 (setq group (car groups))
570 (format "K%7d: %s\n" (cdr group) (car group)))
571 (setq groups (cdr groups))))
572 (switch-to-buffer (current-buffer))
573 (goto-char (point-min))
574 (gnus-group-position-point)
575 (gnus-message 5 "Connecting to %s...done" (nth 1 method))
578 (defun gnus-browse-mode ()
579 "Major mode for browsing a foreign server.
581 All normal editing commands are switched off.
583 \\<gnus-browse-mode-map>
584 The only things you can do in this buffer is
586 1) `\\[gnus-browse-unsubscribe-current-group]' to subscribe to a group.
587 The group will be inserted into the group buffer upon exit from this
590 2) `\\[gnus-browse-read-group]' to read a group ephemerally.
592 3) `\\[gnus-browse-exit]' to return to the group buffer."
594 (kill-all-local-variables)
595 (when (and menu-bar-mode
596 (gnus-visual-p 'browse-menu 'menu))
597 (gnus-browse-make-menu-bar))
598 (gnus-simplify-mode-line)
599 (setq major-mode 'gnus-browse-mode)
600 (setq mode-name "Browse Server")
601 (setq mode-line-process nil)
602 (use-local-map gnus-browse-mode-map)
603 (buffer-disable-undo (current-buffer))
604 (setq truncate-lines t)
605 (gnus-set-default-directory)
606 (setq buffer-read-only t)
607 (run-hooks 'gnus-browse-mode-hook))
609 (defun gnus-browse-read-group (&optional no-article)
610 "Enter the group at the current line."
612 (let ((group (gnus-browse-group-name)))
613 (unless (gnus-group-read-ephemeral-group
614 group gnus-browse-current-method nil
615 (cons (current-buffer) 'browse))
616 (error "Couldn't enter %s" group))))
618 (defun gnus-browse-select-group ()
619 "Select the current group."
621 (gnus-browse-read-group 'no))
623 (defun gnus-browse-next-group (n)
624 "Go to the next group."
628 (gnus-group-position-point)))
630 (defun gnus-browse-prev-group (n)
631 "Go to the next group."
633 (gnus-browse-next-group (- n)))
635 (defun gnus-browse-unsubscribe-current-group (arg)
636 "(Un)subscribe to the next ARG groups."
639 (error "No group at current line."))
640 (let ((ward (if (< arg 0) -1 1))
642 (while (and (> arg 0)
644 (gnus-browse-unsubscribe-group)
645 (zerop (gnus-browse-next-group ward)))
647 (gnus-group-position-point)
648 (if (/= 0 arg) (gnus-message 7 "No more newsgroups"))
651 (defun gnus-browse-group-name ()
654 (when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t)
655 (gnus-group-prefixed-name (match-string 1) gnus-browse-current-method))))
657 (defun gnus-browse-unsubscribe-group ()
658 "Toggle subscription of the current group in the browse buffer."
660 (buffer-read-only nil)
664 ;; If this group it killed, then we want to subscribe it.
665 (if (= (following-char) ?K) (setq sub t))
666 (setq group (gnus-browse-group-name))
670 (gnus-group-change-level
671 (list t group gnus-level-default-subscribed
672 nil nil gnus-browse-current-method)
673 gnus-level-default-subscribed gnus-level-killed
674 (and (car (nth 1 gnus-newsrc-alist))
675 (gnus-gethash (car (nth 1 gnus-newsrc-alist))
679 (gnus-group-change-level
680 group gnus-level-killed gnus-level-default-subscribed)
684 (defun gnus-browse-exit ()
685 "Quit browsing and return to the group buffer."
687 (when (eq major-mode 'gnus-browse-mode)
688 (kill-buffer (current-buffer)))
689 ;; Insert the newly subscribed groups in the group buffer.
691 (set-buffer gnus-group-buffer)
692 (gnus-group-list-groups nil))
693 (if gnus-browse-return-buffer
694 (gnus-configure-windows 'server 'force)
695 (gnus-configure-windows 'group 'force)))
697 (defun gnus-browse-describe-briefly ()
698 "Give a one line description of the group mode commands."
701 (substitute-command-keys "\\<gnus-browse-mode-map>\\[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")))
705 ;;; gnus-srvr.el ends here.