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-visual-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]
95 ["Reset" gnus-server-remove-denials t]
98 (run-hooks 'gnus-server-menu-hook)))
100 (defvar gnus-server-mode-map nil)
101 (put 'gnus-server-mode 'mode-class 'special)
103 (unless gnus-server-mode-map
104 (setq gnus-server-mode-map (make-sparse-keymap))
105 (suppress-keymap gnus-server-mode-map)
109 " " gnus-server-read-server
110 "\r" gnus-server-read-server
111 gnus-mouse-2 gnus-server-pick-server
113 "l" gnus-server-list-servers
114 "k" gnus-server-kill-server
115 "y" gnus-server-yank-server
116 "c" gnus-server-copy-server
117 "a" gnus-server-add-server
118 "e" gnus-server-edit-server
120 "O" gnus-server-open-server
121 "C" gnus-server-close-server
122 "D" gnus-server-deny-server
123 "R" gnus-server-remove-denials
125 "\C-c\C-i" gnus-info-find-node))
127 (defun gnus-server-mode ()
128 "Major mode for listing and editing servers.
130 All normal editing commands are switched off.
131 \\<gnus-server-mode-map>
132 For more in-depth information on this mode, read the manual
133 (`\\[gnus-info-find-node]').
135 The following commands are available:
137 \\{gnus-server-mode-map}"
139 (when (and menu-bar-mode
140 (gnus-visual-p 'server-menu 'menu))
141 (gnus-server-make-menu-bar))
142 (kill-all-local-variables)
143 (gnus-simplify-mode-line)
144 (setq major-mode 'gnus-server-mode)
145 (setq mode-name "Server")
146 ; (gnus-group-set-mode-line)
147 (setq mode-line-process nil)
148 (use-local-map gnus-server-mode-map)
149 (buffer-disable-undo (current-buffer))
150 (setq truncate-lines t)
151 (setq buffer-read-only t)
152 (run-hooks 'gnus-server-mode-hook))
154 (defun gnus-server-insert-server-line (name method)
155 (let* ((how (car method))
156 (where (nth 1 method))
157 (elem (assoc method gnus-opened-servers))
158 (status (cond ((eq (nth 1 elem) 'denied)
160 ((or (gnus-server-opened method)
161 (eq (nth 1 elem) 'ok))
166 (gnus-add-text-properties
170 (eval gnus-server-line-format-spec))
171 (list 'gnus-server (intern name)))))
173 (defun gnus-enter-server-buffer ()
174 "Set up the server buffer."
175 (gnus-server-setup-buffer)
176 (gnus-configure-windows 'server)
177 (gnus-server-prepare))
179 (defun gnus-server-setup-buffer ()
180 "Initialize the server buffer."
181 (unless (get-buffer gnus-server-buffer)
183 (set-buffer (get-buffer-create gnus-server-buffer))
186 (gnus-carpal-setup-buffer 'server)))))
188 (defun gnus-server-prepare ()
189 (setq gnus-server-mode-line-format-spec
190 (gnus-parse-format gnus-server-mode-line-format
191 gnus-server-mode-line-format-alist))
192 (setq gnus-server-line-format-spec
193 (gnus-parse-format gnus-server-line-format
194 gnus-server-line-format-alist t))
195 (let ((alist gnus-server-alist)
196 (buffer-read-only nil)
197 (opened gnus-opened-servers)
200 (setq gnus-inserted-opened-servers nil)
201 ;; First we do the real list of servers.
203 (push (cdr (setq server (pop alist))) done)
204 (when (and server (car server) (cdr server))
205 (gnus-server-insert-server-line (car server) (cdr server))))
206 ;; Then we insert the list of servers that have been opened in
209 (unless (member (caar opened) done)
210 (gnus-server-insert-server-line
211 (setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened))))
213 (push (list op-ser (caar opened)) gnus-inserted-opened-servers))
214 (setq opened (cdr opened))))
215 (goto-char (point-min))
216 (gnus-server-position-point))
218 (defun gnus-server-server-name ()
219 (let ((server (get-text-property (gnus-point-at-bol) 'gnus-server)))
220 (and server (symbol-name server))))
222 (defalias 'gnus-server-position-point 'gnus-goto-colon)
224 (defconst gnus-server-edit-buffer "*Gnus edit server*")
226 (defun gnus-server-update-server (server)
228 (set-buffer gnus-server-buffer)
229 (let* ((buffer-read-only nil)
230 (entry (assoc server gnus-server-alist))
231 (oentry (assoc (gnus-server-to-method server)
232 gnus-opened-servers)))
235 (concat "(gnus-server-set-info \"" server "\" '"
236 (prin1-to-string (cdr entry)) ")")))
237 (when (or entry oentry)
238 ;; Buffer may be narrowed.
241 (when (gnus-server-goto-server server)
244 (gnus-server-insert-server-line (car entry) (cdr entry))
245 (gnus-server-insert-server-line
246 (format "%s:%s" (caar oentry) (nth 1 (car oentry)))
248 (gnus-server-position-point))))))
250 (defun gnus-server-set-info (server info)
251 ;; Enter a select method into the virtual server alist.
252 (when (and server info)
254 (concat "(gnus-server-set-info \"" server "\" '"
255 (prin1-to-string info) ")"))
256 (let* ((server (nth 1 info))
257 (entry (assoc server gnus-server-alist)))
258 (if entry (setcdr entry info)
259 (setq gnus-server-alist
260 (nconc gnus-server-alist (list (cons server info))))))))
262 ;;; Interactive server functions.
264 (defun gnus-server-kill-server (server)
265 "Kill the server on the current line."
266 (interactive (list (gnus-server-server-name)))
267 (unless (gnus-server-goto-server server)
268 (if server (error "No such server: %s" server)
269 (error "No server on the current line")))
270 (unless (assoc server gnus-server-alist)
271 (error "Read-only server %s" server))
272 (gnus-dribble-enter "")
273 (let ((buffer-read-only nil))
275 (setq gnus-server-killed-servers
276 (cons (assoc server gnus-server-alist) gnus-server-killed-servers))
277 (setq gnus-server-alist (delq (car gnus-server-killed-servers)
279 (gnus-server-position-point))
281 (defun gnus-server-yank-server ()
282 "Yank the previously killed server."
284 (or gnus-server-killed-servers
285 (error "No killed servers to be yanked"))
286 (let ((alist gnus-server-alist)
287 (server (gnus-server-server-name))
288 (killed (car gnus-server-killed-servers)))
290 (setq gnus-server-alist (nconc gnus-server-alist (list killed)))
291 (if (string= server (caar gnus-server-alist))
292 (setq gnus-server-alist (cons killed gnus-server-alist))
293 (while (and (cdr alist)
294 (not (string= server (caadr alist))))
295 (setq alist (cdr alist)))
297 (setcdr alist (cons killed (cdr alist)))
298 (setq gnus-server-alist (list killed)))))
299 (gnus-server-update-server (car killed))
300 (setq gnus-server-killed-servers (cdr gnus-server-killed-servers))
301 (gnus-server-position-point)))
303 (defun gnus-server-exit ()
304 "Return to the group buffer."
306 (kill-buffer (current-buffer))
307 (switch-to-buffer gnus-group-buffer)
308 (run-hooks 'gnus-server-exit-hook))
310 (defun gnus-server-list-servers ()
311 "List all available servers."
313 (let ((cur (gnus-server-server-name)))
314 (gnus-server-prepare)
315 (if cur (gnus-server-goto-server cur)
316 (goto-char (point-max))
318 (gnus-server-position-point)))
320 (defun gnus-server-set-status (method status)
321 "Make METHOD have STATUS."
322 (let ((entry (assoc method gnus-opened-servers)))
324 (setcar (cdr entry) status)
325 (push (list method status) gnus-opened-servers))))
327 (defun gnus-opened-servers-remove (method)
328 "Remove METHOD from the list of opened servers."
329 (setq gnus-opened-servers (delq (assoc method gnus-opened-servers)
330 gnus-opened-servers)))
332 (defun gnus-server-open-server (server)
333 "Force an open of SERVER."
334 (interactive (list (gnus-server-server-name)))
335 (let ((method (gnus-server-to-method server)))
336 (or method (error "No such server: %s" server))
337 (gnus-server-set-status method 'ok)
339 (or (gnus-open-server method)
340 (progn (message "Couldn't open %s" server) nil))
341 (gnus-server-update-server server)
342 (gnus-server-position-point))))
344 (defun gnus-server-close-server (server)
346 (interactive (list (gnus-server-server-name)))
347 (let ((method (gnus-server-to-method server)))
348 (or method (error "No such server: %s" server))
349 (gnus-server-set-status method 'closed)
351 (gnus-close-server method)
352 (gnus-server-update-server server)
353 (gnus-server-position-point))))
355 (defun gnus-server-deny-server (server)
356 "Make sure SERVER will never be attempted opened."
357 (interactive (list (gnus-server-server-name)))
358 (let ((method (gnus-server-to-method server)))
359 (or method (error "No such server: %s" server))
360 (gnus-server-set-status method 'denied))
361 (gnus-server-update-server server)
362 (gnus-server-position-point)
365 (defun gnus-server-remove-denials ()
366 "Make all denied servers into closed servers."
368 (let ((servers gnus-opened-servers))
370 (when (eq (nth 1 (car servers)) 'denied)
371 (setcar (nthcdr 1 (car servers)) 'closed))
372 (setq servers (cdr servers))))
373 (gnus-server-list-servers))
375 (defun gnus-server-copy-server (from to)
378 (or (gnus-server-server-name)
379 (error "No server on the current line"))
380 (read-string "Copy to: ")))
381 (or from (error "No server on current line"))
382 (or (and to (not (string= to ""))) (error "No name to copy to"))
383 (and (assoc to gnus-server-alist) (error "%s already exists" to))
384 (or (assoc from gnus-server-alist)
385 (error "%s: no such server" from))
386 (let ((to-entry (gnus-copy-sequence (assoc from gnus-server-alist))))
388 (setcar (nthcdr 2 to-entry) to)
389 (setq gnus-server-killed-servers
390 (cons to-entry gnus-server-killed-servers))
391 (gnus-server-yank-server)))
393 (defun gnus-server-add-server (how where)
395 (list (intern (completing-read "Server method: "
396 gnus-valid-select-methods nil t))
397 (read-string "Server name: ")))
398 (setq gnus-server-killed-servers
399 (cons (list where how where) gnus-server-killed-servers))
400 (gnus-server-yank-server))
402 (defun gnus-server-goto-server (server)
403 "Jump to a server line."
405 (list (completing-read "Goto server: " gnus-server-alist nil t)))
406 (let ((to (text-property-any (point-min) (point-max)
407 'gnus-server (intern server))))
411 (gnus-server-position-point)))))
413 (defun gnus-server-edit-server (server)
414 "Edit the server on the current line."
415 (interactive (list (gnus-server-server-name)))
417 (error "No server on current line"))
418 (unless (assoc server gnus-server-alist)
419 (error "This server can't be edited"))
420 (let ((info (cdr (assoc server gnus-server-alist))))
421 (gnus-close-server info)
423 info "Editing the server."
425 (gnus-server-set-info ,server form)
426 (gnus-server-list-servers)
427 (gnus-server-position-point)))))
429 (defun gnus-server-read-server (server)
431 (interactive (list (gnus-server-server-name)))
432 (let ((buf (current-buffer)))
434 (gnus-browse-foreign-server (gnus-server-to-method server) buf)
437 (gnus-server-update-server (gnus-server-server-name))
438 (gnus-server-position-point)))))
440 (defun gnus-server-pick-server (e)
443 (gnus-server-read-server (gnus-server-server-name)))
447 ;;; Browse Server Mode
450 (defvar gnus-browse-menu-hook nil
451 "*Hook run after the creation of the browse mode menu.")
453 (defvar gnus-browse-mode-hook nil)
454 (defvar gnus-browse-mode-map nil)
455 (put 'gnus-browse-mode 'mode-class 'special)
457 (unless gnus-browse-mode-map
458 (setq gnus-browse-mode-map (make-keymap))
459 (suppress-keymap gnus-browse-mode-map)
463 " " gnus-browse-read-group
464 "=" gnus-browse-select-group
465 "n" gnus-browse-next-group
466 "p" gnus-browse-prev-group
467 "\177" gnus-browse-prev-group
468 "N" gnus-browse-next-group
469 "P" gnus-browse-prev-group
470 "\M-n" gnus-browse-next-group
471 "\M-p" gnus-browse-prev-group
472 "\r" gnus-browse-select-group
473 "u" gnus-browse-unsubscribe-current-group
478 "\C-c\C-c" gnus-browse-exit
479 "?" gnus-browse-describe-briefly
481 "\C-c\C-i" gnus-info-find-node))
483 (defun gnus-browse-make-menu-bar ()
484 (gnus-visual-turn-off-edit-menu 'browse)
486 (boundp 'gnus-browse-menu)
489 gnus-browse-menu gnus-browse-mode-map ""
491 ["Subscribe" gnus-browse-unsubscribe-current-group t]
492 ["Read" gnus-browse-read-group t]
493 ["Select" gnus-browse-read-group t]
494 ["Next" gnus-browse-next-group t]
495 ["Prev" gnus-browse-next-group t]
496 ["Exit" gnus-browse-exit t]
498 (run-hooks 'gnus-browse-menu-hook))))
500 (defvar gnus-browse-current-method nil)
501 (defvar gnus-browse-return-buffer nil)
503 (defvar gnus-browse-buffer "*Gnus Browse Server*")
505 (defun gnus-browse-foreign-server (method &optional return-buffer)
506 "Browse the server METHOD."
507 (setq gnus-browse-current-method method)
508 (setq gnus-browse-return-buffer return-buffer)
509 (let ((gnus-select-method method)
511 (gnus-message 5 "Connecting to %s..." (nth 1 method))
513 ((not (gnus-check-server method))
515 1 "Unable to contact server: %s" (gnus-status-message method))
517 ((not (gnus-request-list method))
519 1 "Couldn't request list: %s" (gnus-status-message method))
522 (get-buffer-create gnus-browse-buffer)
523 (gnus-add-current-to-buffer-list)
524 (and gnus-carpal (gnus-carpal-setup-buffer 'browse))
525 (gnus-configure-windows 'browse)
526 (buffer-disable-undo (current-buffer))
527 (let ((buffer-read-only nil))
530 (setq mode-line-buffer-identification
533 "Gnus: %%b {%s:%s}" (car method) (cadr method))))
535 (set-buffer nntp-server-buffer)
536 (let ((cur (current-buffer)))
537 (goto-char (point-min))
538 (or (string= gnus-ignored-newsgroups "")
539 (delete-matching-lines gnus-ignored-newsgroups))
540 (while (re-search-forward
541 "\\(^[^ \t]+\\)[ \t]+[0-9]+[ \t]+[0-9]+" nil t)
542 (goto-char (match-end 1))
543 (setq groups (cons (cons (match-string 1)
544 (max 0 (- (1+ (read cur)) (read cur))))
546 (setq groups (sort groups
548 (string< (car l1) (car l2)))))
549 (let ((buffer-read-only nil))
551 (setq group (car groups))
553 (format "K%7d: %s\n" (cdr group) (car group)))
554 (setq groups (cdr groups))))
555 (switch-to-buffer (current-buffer))
556 (goto-char (point-min))
557 (gnus-group-position-point)
558 (gnus-message 5 "Connecting to %s...done" (nth 1 method))
561 (defun gnus-browse-mode ()
562 "Major mode for browsing a foreign server.
564 All normal editing commands are switched off.
566 \\<gnus-browse-mode-map>
567 The only things you can do in this buffer is
569 1) `\\[gnus-browse-unsubscribe-current-group]' to subscribe to a group.
570 The group will be inserted into the group buffer upon exit from this
573 2) `\\[gnus-browse-read-group]' to read a group ephemerally.
575 3) `\\[gnus-browse-exit]' to return to the group buffer."
577 (kill-all-local-variables)
578 (when (and menu-bar-mode
579 (gnus-visual-p 'browse-menu 'menu))
580 (gnus-browse-make-menu-bar))
581 (gnus-simplify-mode-line)
582 (setq major-mode 'gnus-browse-mode)
583 (setq mode-name "Browse Server")
584 (setq mode-line-process nil)
585 (use-local-map gnus-browse-mode-map)
586 (buffer-disable-undo (current-buffer))
587 (setq truncate-lines t)
588 (setq buffer-read-only t)
589 (run-hooks 'gnus-browse-mode-hook))
591 (defun gnus-browse-read-group (&optional no-article)
592 "Enter the group at the current line."
594 (let ((group (gnus-browse-group-name)))
595 (or (gnus-group-read-ephemeral-group
596 group gnus-browse-current-method nil
597 (cons (current-buffer) 'browse))
598 (error "Couldn't enter %s" group))))
600 (defun gnus-browse-select-group ()
601 "Select the current group."
603 (gnus-browse-read-group 'no))
605 (defun gnus-browse-next-group (n)
606 "Go to the next group."
610 (gnus-group-position-point)))
612 (defun gnus-browse-prev-group (n)
613 "Go to the next group."
615 (gnus-browse-next-group (- n)))
617 (defun gnus-browse-unsubscribe-current-group (arg)
618 "(Un)subscribe to the next ARG groups."
621 (error "No group at current line."))
622 (let ((ward (if (< arg 0) -1 1))
624 (while (and (> arg 0)
626 (gnus-browse-unsubscribe-group)
627 (zerop (gnus-browse-next-group ward)))
629 (gnus-group-position-point)
630 (if (/= 0 arg) (gnus-message 7 "No more newsgroups"))
633 (defun gnus-browse-group-name ()
636 (when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t)
637 (gnus-group-prefixed-name (match-string 1) gnus-browse-current-method))))
639 (defun gnus-browse-unsubscribe-group ()
640 "Toggle subscription of the current group in the browse buffer."
642 (buffer-read-only nil)
646 ;; If this group it killed, then we want to subscribe it.
647 (if (= (following-char) ?K) (setq sub t))
648 (setq group (gnus-browse-group-name))
652 (gnus-group-change-level
653 (list t group gnus-level-default-subscribed
654 nil nil gnus-browse-current-method)
655 gnus-level-default-subscribed gnus-level-killed
656 (and (car (nth 1 gnus-newsrc-alist))
657 (gnus-gethash (car (nth 1 gnus-newsrc-alist))
661 (gnus-group-change-level
662 group gnus-level-killed gnus-level-default-subscribed)
666 (defun gnus-browse-exit ()
667 "Quit browsing and return to the group buffer."
669 (when (eq major-mode 'gnus-browse-mode)
670 (kill-buffer (current-buffer)))
671 ;; Insert the newly subscribed groups in the group buffer.
673 (set-buffer gnus-group-buffer)
674 (gnus-group-list-groups nil))
675 (if gnus-browse-return-buffer
676 (gnus-configure-windows 'server 'force)
677 (gnus-configure-windows 'group 'force)))
679 (defun gnus-browse-describe-briefly ()
680 "Give a one line description of the group mode commands."
683 (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")))
687 ;;; gnus-srvr.el ends here.