mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-12-15 09:47:20 +00:00
Code Issues Releases Activity
7c82656b08
emacs/lisp/gnus-srvr.el

709 lines
22 KiB
EmacsLisp
Raw Normal View History

Initial revision
1996-06-25 22:35:26 +00:00
;;; gnus-srvr.el --- virtual server support for Gnus
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news
;; This file is part of GNU Emacs.
;; 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.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; 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.
;;; Commentary:
;;; Code:
(require 'gnus)
(eval-when-compile (require 'cl))
(defvar gnus-server-mode-hook nil
"Hook run in `gnus-server-mode' buffers.")
(defconst gnus-server-line-format " {%(%h:%w%)} %s\n"
"Format of server lines.
It works along the same lines as a normal formatting string,
with some simple extensions.")
(defvar gnus-server-mode-line-format "Gnus List of servers"
"The format specification for the server mode line.")
(defvar gnus-server-exit-hook nil
"*Hook run when exiting the server buffer.")
;;; Internal variables.
(defvar gnus-inserted-opened-servers nil)
(defvar gnus-server-line-format-alist
`((?h how ?s)
(?n name ?s)
(?w where ?s)
(?s status ?s)))
(defvar gnus-server-mode-line-format-alist
`((?S news-server ?s)
(?M news-method ?s)
(?u user-defined ?s)))
(defvar gnus-server-line-format-spec nil)
(defvar gnus-server-mode-line-format-spec nil)
(defvar gnus-server-killed-servers nil)
(defvar gnus-server-mode-map)
(defvar gnus-server-menu-hook nil
"*Hook run after the creation of the server mode menu.")
(defun gnus-server-make-menu-bar ()
(gnus-visual-turn-off-edit-menu 'server)
(unless (boundp 'gnus-server-server-menu)
(easy-menu-define
gnus-server-server-menu gnus-server-mode-map ""
'("Server"
["Add" gnus-server-add-server t]
["Browse" gnus-server-read-server t]
["List" gnus-server-list-servers t]
["Kill" gnus-server-kill-server t]
["Yank" gnus-server-yank-server t]
["Copy" gnus-server-copy-server t]
["Edit" gnus-server-edit-server t]
["Exit" gnus-server-exit t]
))
(easy-menu-define
gnus-server-connections-menu gnus-server-mode-map ""
'("Connections"
["Open" gnus-server-open-server t]
["Close" gnus-server-close-server t]
["Deny" gnus-server-deny-server t]
["Reset" gnus-server-remove-denials t]
))
(run-hooks 'gnus-server-menu-hook)))
(defvar gnus-server-mode-map nil)
(put 'gnus-server-mode 'mode-class 'special)
(unless gnus-server-mode-map
(setq gnus-server-mode-map (make-sparse-keymap))
(suppress-keymap gnus-server-mode-map)
(gnus-define-keys
gnus-server-mode-map
" " gnus-server-read-server
"\r" gnus-server-read-server
gnus-mouse-2 gnus-server-pick-server
"q" gnus-server-exit
"l" gnus-server-list-servers
"k" gnus-server-kill-server
"y" gnus-server-yank-server
"c" gnus-server-copy-server
"a" gnus-server-add-server
"e" gnus-server-edit-server
"O" gnus-server-open-server
"C" gnus-server-close-server
"D" gnus-server-deny-server
"R" gnus-server-remove-denials
"\C-c\C-i" gnus-info-find-node))
(defun gnus-server-mode ()
"Major mode for listing and editing servers.
All normal editing commands are switched off.
\\<gnus-server-mode-map>
For more in-depth information on this mode, read the manual
(`\\[gnus-info-find-node]').
The following commands are available:
\\{gnus-server-mode-map}"
(interactive)
(when (and menu-bar-mode
(gnus-visual-p 'server-menu 'menu))
(gnus-server-make-menu-bar))
(kill-all-local-variables)
(gnus-simplify-mode-line)
(setq major-mode 'gnus-server-mode)
(setq mode-name "Server")
; (gnus-group-set-mode-line)
(setq mode-line-process nil)
(use-local-map gnus-server-mode-map)
(buffer-disable-undo (current-buffer))
(setq truncate-lines t)
(setq buffer-read-only t)
(run-hooks 'gnus-server-mode-hook))
(defun gnus-server-insert-server-line (name method)
(let* ((how (car method))
(where (nth 1 method))
(elem (assoc method gnus-opened-servers))
(status (cond ((eq (nth 1 elem) 'denied)
"(denied)")
((or (gnus-server-opened method)
(eq (nth 1 elem) 'ok))
"(opened)")
(t
"(closed)"))))
(beginning-of-line)
(gnus-add-text-properties
(point)
(prog1 (1+ (point))
;; Insert the text.
(eval gnus-server-line-format-spec))
(list 'gnus-server (intern name)))))
(defun gnus-enter-server-buffer ()
"Set up the server buffer."
(gnus-server-setup-buffer)
(gnus-configure-windows 'server)
(gnus-server-prepare))
(defun gnus-server-setup-buffer ()
"Initialize the server buffer."
(unless (get-buffer gnus-server-buffer)
(save-excursion
(set-buffer (get-buffer-create gnus-server-buffer))
(gnus-server-mode)
(when gnus-carpal
(gnus-carpal-setup-buffer 'server)))))
(defun gnus-server-prepare ()
(setq gnus-server-mode-line-format-spec
(gnus-parse-format gnus-server-mode-line-format
gnus-server-mode-line-format-alist))
(setq gnus-server-line-format-spec
(gnus-parse-format gnus-server-line-format
gnus-server-line-format-alist 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)
;; First we do the real list of servers.
(while alist
(push (cdr (setq server (pop alist))) done)
(when (and server (car server) (cdr server))
(gnus-server-insert-server-line (car server) (cdr server))))
;; Then we insert the list of servers that have been opened in
;; this session.
(while opened
(unless (member (caar opened) 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))))
(goto-char (point-min))
(gnus-server-position-point))
(defun gnus-server-server-name ()
(let ((server (get-text-property (gnus-point-at-bol) 'gnus-server)))
(and server (symbol-name server))))
(defalias 'gnus-server-position-point 'gnus-goto-colon)
(defconst gnus-server-edit-buffer "*Gnus edit server*")
(defun gnus-server-update-server (server)
(save-excursion
(set-buffer gnus-server-buffer)
(let* ((buffer-read-only nil)
(entry (assoc server gnus-server-alist))
(oentry (assoc (gnus-server-to-method server)
gnus-opened-servers)))
(when entry
(gnus-dribble-enter
(concat "(gnus-server-set-info \"" server "\" '"
(prin1-to-string (cdr entry)) ")")))
(when (or entry oentry)
;; Buffer may be narrowed.
(save-restriction
(widen)
(when (gnus-server-goto-server server)
(gnus-delete-line))
(if entry
(gnus-server-insert-server-line (car entry) (cdr entry))
(gnus-server-insert-server-line
(format "%s:%s" (caar oentry) (nth 1 (car oentry)))
(car oentry)))
(gnus-server-position-point))))))
(defun gnus-server-set-info (server info)
;; Enter a select method into the virtual server alist.
(when (and server info)
(gnus-dribble-enter
(concat "(gnus-server-set-info \"" server "\" '"
(prin1-to-string info) ")"))
(let* ((server (nth 1 info))
(entry (assoc server gnus-server-alist)))
(if entry (setcdr entry info)
(setq gnus-server-alist
(nconc gnus-server-alist (list (cons server info))))))))
;;; Interactive server functions.
(defun gnus-server-kill-server (server)
"Kill the server on the current line."
(interactive (list (gnus-server-server-name)))
(unless (gnus-server-goto-server server)
(if server (error "No such server: %s" server)
(error "No server on the current line")))
(unless (assoc server gnus-server-alist)
(error "Read-only server %s" server))
(gnus-dribble-enter "")
(let ((buffer-read-only nil))
(gnus-delete-line))
(setq gnus-server-killed-servers
(cons (assoc server gnus-server-alist) gnus-server-killed-servers))
(setq gnus-server-alist (delq (car gnus-server-killed-servers)
gnus-server-alist))
(gnus-server-position-point))
(defun gnus-server-yank-server ()
"Yank the previously killed server."
(interactive)
(or gnus-server-killed-servers
(error "No killed servers to be yanked"))
(let ((alist gnus-server-alist)
(server (gnus-server-server-name))
(killed (car gnus-server-killed-servers)))
(if (not server)
(setq gnus-server-alist (nconc gnus-server-alist (list killed)))
(if (string= server (caar gnus-server-alist))
(setq gnus-server-alist (cons killed gnus-server-alist))
(while (and (cdr alist)
(not (string= server (caadr alist))))
(setq alist (cdr alist)))
(if alist
(setcdr alist (cons killed (cdr alist)))
(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)))
(defun gnus-server-exit ()
"Return to the group buffer."
(interactive)
(kill-buffer (current-buffer))
(switch-to-buffer gnus-group-buffer)
(run-hooks 'gnus-server-exit-hook))
(defun gnus-server-list-servers ()
"List all available servers."
(interactive)
(let ((cur (gnus-server-server-name)))
(gnus-server-prepare)
(if cur (gnus-server-goto-server cur)
(goto-char (point-max))
(forward-line -1))
(gnus-server-position-point)))
(defun gnus-server-set-status (method status)
"Make METHOD have STATUS."
(let ((entry (assoc method gnus-opened-servers)))
(if entry
(setcar (cdr entry) status)
(push (list method status) gnus-opened-servers))))
(defun gnus-opened-servers-remove (method)
"Remove METHOD from the list of opened servers."
(setq gnus-opened-servers (delq (assoc method gnus-opened-servers)
gnus-opened-servers)))
(defun gnus-server-open-server (server)
"Force an open of SERVER."
(interactive (list (gnus-server-server-name)))
(let ((method (gnus-server-to-method server)))
(or method (error "No such server: %s" server))
(gnus-server-set-status method 'ok)
(prog1
(or (gnus-open-server method)
(progn (message "Couldn't open %s" server) nil))
(gnus-server-update-server server)
(gnus-server-position-point))))
(defun gnus-server-close-server (server)
"Close SERVER."
(interactive (list (gnus-server-server-name)))
(let ((method (gnus-server-to-method server)))
(or method (error "No such server: %s" server))
(gnus-server-set-status method 'closed)
(prog1
(gnus-close-server method)
(gnus-server-update-server server)
(gnus-server-position-point))))
(defun gnus-server-deny-server (server)
"Make sure SERVER will never be attempted opened."
(interactive (list (gnus-server-server-name)))
(let ((method (gnus-server-to-method server)))
(or method (error "No such server: %s" server))
(gnus-server-set-status method 'denied))
(gnus-server-update-server server)
(gnus-server-position-point)
t)
(defun gnus-server-remove-denials ()
"Make all denied servers into closed servers."
(interactive)
(let ((servers gnus-opened-servers))
(while servers
(when (eq (nth 1 (car servers)) 'denied)
(setcar (nthcdr 1 (car servers)) 'closed))
(setq servers (cdr servers))))
(gnus-server-list-servers))
(defun gnus-server-copy-server (from to)
(interactive
(list
(or (gnus-server-server-name)
(error "No server on the current line"))
(read-string "Copy to: ")))
(or from (error "No server on current line"))
(or (and to (not (string= to ""))) (error "No name to copy to"))
(and (assoc to gnus-server-alist) (error "%s already exists" to))
(or (assoc from gnus-server-alist)
(error "%s: no such server" from))
(let ((to-entry (gnus-copy-sequence (assoc from gnus-server-alist))))
(setcar to-entry to)
(setcar (nthcdr 2 to-entry) to)
(setq gnus-server-killed-servers
(cons to-entry gnus-server-killed-servers))
(gnus-server-yank-server)))
(defun gnus-server-add-server (how where)
(interactive
(list (intern (completing-read "Server method: "
gnus-valid-select-methods nil t))
(read-string "Server name: ")))
(setq gnus-server-killed-servers
(cons (list where how where) gnus-server-killed-servers))
(gnus-server-yank-server))
(defun gnus-server-goto-server (server)
"Jump to a server line."
(interactive
(list (completing-read "Goto server: " gnus-server-alist nil t)))
(let ((to (text-property-any (point-min) (point-max)
'gnus-server (intern server))))
(and to
(progn
(goto-char to)
(gnus-server-position-point)))))
(defun gnus-server-edit-server (server)
"Edit the server on the current line."
(interactive (list (gnus-server-server-name)))
(unless server
(error "No server on current line"))
(unless (assoc server gnus-server-alist)
(error "This server can't be edited"))
(let ((winconf (current-window-configuration))
(info (cdr (assoc server gnus-server-alist))))
(gnus-close-server info)
(get-buffer-create gnus-server-edit-buffer)
(gnus-configure-windows 'edit-server)
(gnus-add-current-to-buffer-list)
(emacs-lisp-mode)
(make-local-variable 'gnus-prev-winconf)
(setq gnus-prev-winconf winconf)
(use-local-map (copy-keymap (current-local-map)))
(let ((done-func '(lambda ()
"Exit editing mode and update the information."
(interactive)
(gnus-server-edit-server-done 'group))))
(setcar (cdr (nth 4 done-func)) server)
(local-set-key "\C-c\C-c" done-func))
(erase-buffer)
(insert ";; Type `C-c C-c' after you have edited the server.\n\n")
(insert (pp-to-string info))))
(defun gnus-server-edit-server-done (server)
(interactive)
(set-buffer (get-buffer-create gnus-server-edit-buffer))
(goto-char (point-min))
(let ((form (read (current-buffer)))
(winconf gnus-prev-winconf))
(gnus-server-set-info server form)
(kill-buffer (current-buffer))
(and winconf (set-window-configuration winconf))
(set-buffer gnus-server-buffer)
(gnus-server-update-server server)
(gnus-server-list-servers)
(gnus-server-position-point)))
(defun gnus-server-read-server (server)
"Browse a server."
(interactive (list (gnus-server-server-name)))
(let ((buf (current-buffer)))
(prog1
(gnus-browse-foreign-server (gnus-server-to-method server) buf)
(save-excursion
(set-buffer buf)
(gnus-server-update-server (gnus-server-server-name))
(gnus-server-position-point)))))
(defun gnus-server-pick-server (e)
(interactive "e")
(mouse-set-point e)
(gnus-server-read-server (gnus-server-server-name)))
;;;
;;; Browse Server Mode
;;;
(defvar gnus-browse-menu-hook nil
"*Hook run after the creation of the browse mode menu.")
(defvar gnus-browse-mode-hook nil)
(defvar gnus-browse-mode-map nil)
(put 'gnus-browse-mode 'mode-class 'special)
(unless gnus-browse-mode-map
(setq gnus-browse-mode-map (make-keymap))
(suppress-keymap gnus-browse-mode-map)
(gnus-define-keys
gnus-browse-mode-map
" " gnus-browse-read-group
"=" gnus-browse-select-group
"n" gnus-browse-next-group
"p" gnus-browse-prev-group
"\177" gnus-browse-prev-group
"N" gnus-browse-next-group
"P" gnus-browse-prev-group
"\M-n" gnus-browse-next-group
"\M-p" gnus-browse-prev-group
"\r" gnus-browse-select-group
"u" gnus-browse-unsubscribe-current-group
"l" gnus-browse-exit
"L" gnus-browse-exit
"q" gnus-browse-exit
"Q" gnus-browse-exit
"\C-c\C-c" gnus-browse-exit
"?" gnus-browse-describe-briefly
"\C-c\C-i" gnus-info-find-node))
(defun gnus-browse-make-menu-bar ()
(gnus-visual-turn-off-edit-menu 'browse)
(or
(boundp 'gnus-browse-menu)
(progn
(easy-menu-define
gnus-browse-menu gnus-browse-mode-map ""
'("Browse"
["Subscribe" gnus-browse-unsubscribe-current-group t]
["Read" gnus-browse-read-group t]
["Select" gnus-browse-read-group t]
["Next" gnus-browse-next-group t]
["Prev" gnus-browse-next-group t]
["Exit" gnus-browse-exit t]
))
(run-hooks 'gnus-browse-menu-hook))))
(defvar gnus-browse-current-method nil)
(defvar gnus-browse-return-buffer nil)
(defvar gnus-browse-buffer "*Gnus Browse Server*")
(defun gnus-browse-foreign-server (method &optional return-buffer)
"Browse the server METHOD."
(setq gnus-browse-current-method method)
(setq gnus-browse-return-buffer return-buffer)
(let ((gnus-select-method method)
groups group)
(gnus-message 5 "Connecting to %s..." (nth 1 method))
(cond
((not (gnus-check-server method))
(gnus-message
1 "Unable to contact server: %s" (gnus-status-message method))
nil)
((not (gnus-request-list method))
(gnus-message
1 "Couldn't request list: %s" (gnus-status-message method))
nil)
(t
(get-buffer-create gnus-browse-buffer)
(gnus-add-current-to-buffer-list)
(and gnus-carpal (gnus-carpal-setup-buffer 'browse))
(gnus-configure-windows 'browse)
(buffer-disable-undo (current-buffer))
(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)
(let ((cur (current-buffer)))
(goto-char (point-min))
(or (string= gnus-ignored-newsgroups "")
(delete-matching-lines gnus-ignored-newsgroups))
(while (re-search-forward
"\\(^[^ \t]+\\)[ \t]+[0-9]+[ \t]+[0-9]+" nil t)
(goto-char (match-end 1))
(setq groups (cons (cons (match-string 1)
(max 0 (- (1+ (read cur)) (read cur))))
groups)))))
(setq groups (sort groups
(lambda (l1 l2)
(string< (car l1) (car l2)))))
(let ((buffer-read-only nil))
(while groups
(setq group (car groups))
(insert
(format "K%7d: %s\n" (cdr group) (car group)))
(setq groups (cdr groups))))
(switch-to-buffer (current-buffer))
(goto-char (point-min))
(gnus-group-position-point)
(gnus-message 5 "Connecting to %s...done" (nth 1 method))
t))))
(defun gnus-browse-mode ()
"Major mode for browsing a foreign server.
All normal editing commands are switched off.
\\<gnus-browse-mode-map>
The only things you can do in this buffer is
1) `\\[gnus-browse-unsubscribe-current-group]' to subscribe to a group.
The group will be inserted into the group buffer upon exit from this
buffer.
2) `\\[gnus-browse-read-group]' to read a group ephemerally.
3) `\\[gnus-browse-exit]' to return to the group buffer."
(interactive)
(kill-all-local-variables)
(when (and menu-bar-mode
(gnus-visual-p 'browse-menu 'menu))
(gnus-browse-make-menu-bar))
(gnus-simplify-mode-line)
(setq major-mode 'gnus-browse-mode)
(setq mode-name "Browse Server")
(setq mode-line-process nil)
(use-local-map gnus-browse-mode-map)
(buffer-disable-undo (current-buffer))
(setq truncate-lines t)
(setq buffer-read-only t)
(run-hooks 'gnus-browse-mode-hook))
(defun gnus-browse-read-group (&optional no-article)
"Enter the group at the current line."
(interactive)
(let ((group (gnus-browse-group-name)))
(or (gnus-group-read-ephemeral-group
group gnus-browse-current-method nil
(cons (current-buffer) 'browse))
(error "Couldn't enter %s" group))))
(defun gnus-browse-select-group ()
"Select the current group."
(interactive)
(gnus-browse-read-group 'no))
(defun gnus-browse-next-group (n)
"Go to the next group."
(interactive "p")
(prog1
(forward-line n)
(gnus-group-position-point)))
(defun gnus-browse-prev-group (n)
"Go to the next group."
(interactive "p")
(gnus-browse-next-group (- n)))
(defun gnus-browse-unsubscribe-current-group (arg)
"(Un)subscribe to the next ARG groups."
(interactive "p")
(when (eobp)
(error "No group at current line."))
(let ((ward (if (< arg 0) -1 1))
(arg (abs arg)))
(while (and (> arg 0)
(not (eobp))
(gnus-browse-unsubscribe-group)
(zerop (gnus-browse-next-group ward)))
(decf arg))
(gnus-group-position-point)
(if (/= 0 arg) (gnus-message 7 "No more newsgroups"))
arg))
(defun gnus-browse-group-name ()
(save-excursion
(beginning-of-line)
(when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t)
(gnus-group-prefixed-name (match-string 1) gnus-browse-current-method))))
(defun gnus-browse-unsubscribe-group ()
"Toggle subscription of the current group in the browse buffer."
(let ((sub nil)
(buffer-read-only nil)
group)
(save-excursion
(beginning-of-line)
;; If this group it killed, then we want to subscribe it.
(if (= (following-char) ?K) (setq sub t))
(setq group (gnus-browse-group-name))
(delete-char 1)
(if sub
(progn
(gnus-group-change-level
(list t group gnus-level-default-subscribed
nil nil gnus-browse-current-method)
gnus-level-default-subscribed gnus-level-killed
(and (car (nth 1 gnus-newsrc-alist))
(gnus-gethash (car (nth 1 gnus-newsrc-alist))
gnus-newsrc-hashtb))
t)
(insert ? ))
(gnus-group-change-level
group gnus-level-killed gnus-level-default-subscribed)
(insert ?K)))
t))
(defun gnus-browse-exit ()
"Quit browsing and return to the group buffer."
(interactive)
(when (eq major-mode 'gnus-browse-mode)
(kill-buffer (current-buffer)))
;; Insert the newly subscribed groups in the group buffer.
(save-excursion
(set-buffer gnus-group-buffer)
(gnus-group-list-groups nil))
(if gnus-browse-return-buffer
(gnus-configure-windows 'server 'force)
(gnus-configure-windows 'group 'force)))
(defun gnus-browse-describe-briefly ()
"Give a one line description of the group mode commands."
(interactive)
(gnus-message 6
(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")))
(provide 'gnus-srvr)
;;; gnus-srvr.el ends here.
Reference in New Issue Copy Permalink