;;; gnus-srvr.el --- virtual server support for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
(defvar gnus-server-mode-hook nil
"Hook run in `gnus-server-mode' buffers.")
-(defconst gnus-server-line-format " {%(%h:%w%)} %s%a\n"
+(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.
%h backend
%n name
%w address
-%s status
-%a agent covered")
+%s status")
(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.")
-
;;; Internal variables.
(defvar gnus-inserted-opened-servers nil)
`((?h gnus-tmp-how ?s)
(?n gnus-tmp-name ?s)
(?w gnus-tmp-where ?s)
- (?s gnus-tmp-status ?s)
- (?a gnus-tmp-agent ?s)))
+ (?s gnus-tmp-status ?s)))
(defvar gnus-server-mode-line-format-alist
`((?S gnus-tmp-news-server ?s)
(suppress-keymap gnus-server-mode-map)
(gnus-define-keys gnus-server-mode-map
- " " gnus-server-read-server-in-server-buffer
+ " " gnus-server-read-server
"\r" gnus-server-read-server
gnus-mouse-2 gnus-server-pick-server
"q" gnus-server-exit
"D" gnus-server-deny-server
"R" gnus-server-remove-denials
- "n" next-line
- "p" previous-line
-
"g" gnus-server-regenerate-server
"\C-c\C-i" gnus-info-find-node
(gnus-set-default-directory)
(setq mode-line-process nil)
(use-local-map gnus-server-mode-map)
- (buffer-disable-undo)
+ (buffer-disable-undo (current-buffer))
(setq truncate-lines t)
(setq buffer-read-only t)
(gnus-run-hooks 'gnus-server-mode-hook))
(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-agent (if (and gnus-agent
- (member method
- gnus-agent-covered-methods))
- "(agent)"
- "")))
+ "(denied)")
+ ((or (gnus-server-opened method)
+ (eq (nth 1 elem) 'ok))
+ "(opened)")
+ (t
+ "(closed)"))))
(beginning-of-line)
(gnus-add-text-properties
(point)
(push (assoc server gnus-server-alist) gnus-server-killed-servers)
(setq gnus-server-alist (delq (car gnus-server-killed-servers)
gnus-server-alist))
- (let ((groups (gnus-groups-from-server server)))
- (when (and groups
- (gnus-yes-or-no-p
- (format "Kill all %s groups from this server? "
- (length groups))))
- (dolist (group groups)
- (setq gnus-newsrc-alist
- (delq (assoc group gnus-newsrc-alist)
- gnus-newsrc-alist))
- (when gnus-group-change-level-function
- (funcall gnus-group-change-level-function
- group gnus-level-killed 3)))))
(gnus-server-position-point))
(defun gnus-server-yank-server ()
(defun gnus-server-close-all-servers ()
"Close all servers."
(interactive)
- (dolist (server gnus-inserted-opened-servers)
- (gnus-server-close-server (car server))))
+ (let ((servers gnus-inserted-opened-servers))
+ (while servers
+ (gnus-server-close-server (car (pop servers))))))
(defun gnus-server-deny-server (server)
"Make sure SERVER will never be attempted opened."
(defun gnus-server-remove-denials ()
"Make all denied servers into closed servers."
(interactive)
- (dolist (server gnus-opened-servers)
- (when (eq (nth 1 server) 'denied)
- (setcar (nthcdr 1 server) 'closed)))
+ (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)
(gnus-request-scan nil method)
(gnus-message 3 "Scanning %s...done" server))))
-(defun gnus-server-read-server-in-server-buffer (server)
- "Browse a server in server buffer."
- (interactive (list (gnus-server-server-name)))
- (let (gnus-server-browse-in-group-buffer)
- (gnus-server-read-server server)))
-
(defun gnus-server-read-server (server)
"Browse a server."
(interactive (list (gnus-server-server-name)))
(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
- [delete] 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
- "\C-c\C-b" gnus-bug))
+ 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
+ [delete] 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
+ "\C-c\C-b" gnus-bug))
(defun gnus-browse-make-menu-bar ()
(gnus-turn-off-edit-menu 'browse)
(defun gnus-browse-foreign-server (server &optional return-buffer)
"Browse the server SERVER."
- (setq gnus-browse-current-method (gnus-server-to-method server))
+ (setq gnus-browse-current-method server)
(setq gnus-browse-return-buffer return-buffer)
- (let* ((method gnus-browse-current-method)
- (orig-select-method gnus-select-method)
+ (let* ((method (gnus-server-to-method server))
(gnus-select-method method)
groups group)
(gnus-message 5 "Connecting to %s..." (nth 1 method))
1 "Couldn't request list: %s" (gnus-status-message method))
nil)
(t
+ (gnus-get-buffer-create gnus-browse-buffer)
+ (when 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))
(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))))
+ (while (re-search-forward
+ "\\(^[^ \t]+\\)[ \t]+[0-9]+[ \t]+[0-9]+" nil t)
+ (goto-char (match-end 1))
+ (condition-case ()
+ (push (cons (match-string 1)
+ (max 0 (- (1+ (read cur)) (read cur))))
+ groups)
+ (error nil)))))
(setq groups (sort groups
(lambda (l1 l2)
(string< (car l1) (car l2)))))
- (if gnus-server-browse-in-group-buffer
- (let* ((gnus-select-method orig-select-method)
- (gnus-group-listed-groups
- (mapcar (lambda (group)
- (let ((name
- (gnus-group-prefixed-name
- (car group) method)))
- (gnus-set-active name (cdr group))
- name))
- groups)))
- (gnus-configure-windows 'group)
- (funcall gnus-group-prepare-function
- gnus-level-killed 'ignore 1 'ingore))
- (gnus-get-buffer-create gnus-browse-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))))
- (let ((buffer-read-only nil) charset)
- (while groups
- (setq group (car groups))
- (setq charset (gnus-group-name-charset method group))
- (gnus-add-text-properties
- (point)
- (prog1 (1+ (point))
- (insert
- (format "%c%7d: %s\n"
- (let ((level
- (let ((gnus-select-method orig-select-method))
- (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)))
- (max 0 (- (1+ (cddr group)) (cadr group)))
- (gnus-group-name-decode (car group) charset))))
- (list 'gnus-group (car group)))
- (setq groups (cdr groups))))
- (switch-to-buffer (current-buffer)))
+ (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))
(setq mode-name "Browse Server")
(setq mode-line-process nil)
(use-local-map gnus-browse-mode-map)
- (buffer-disable-undo)
+ (buffer-disable-undo (current-buffer))
(setq truncate-lines t)
(gnus-set-default-directory)
(setq buffer-read-only t)
(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
+ group gnus-browse-current-method nil
(cons (current-buffer) 'browse))
(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)
(defun gnus-browse-group-name ()
(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 ": \\(.*\\)$" (gnus-point-at-eol) t)
+ (gnus-group-prefixed-name
+ ;; Remove text props.
+ (format "%s" (match-string 1))
+ gnus-browse-current-method))))
(defun gnus-browse-unsubscribe-group ()
"Toggle subscription of the current group in the browse buffer."
(save-excursion
(beginning-of-line)
;; If this group it killed, then we want to subscribe it.
- (unless (eq (char-after) ? )
+ (when (= (following-char) ?K)
(setq sub t))
(setq group (gnus-browse-group-name))
- ;;;;
- ;;(when (and sub
- ;; (cadr (gnus-gethash group gnus-newsrc-hashtb)))
- ;;(error "Group already subscribed"))
+ (when (and sub
+ (cadr (gnus-gethash group gnus-newsrc-hashtb)))
+ (error "Group already subscribed"))
+ (delete-char 1)
(if sub
(progn
;; Make sure the group has been properly removed before we
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)
+ 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)
- (delete-char 1)
(insert ? ))
(gnus-group-change-level
- group gnus-level-unsubscribed gnus-level-default-subscribed)
- (delete-char 1)
- (insert ?U)))
+ group gnus-level-killed gnus-level-default-subscribed)
+ (insert ?K)))
t))
(defun gnus-browse-exit ()
(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-regenerate)
- (error
- (error "This backend doesn't support regeneration")))
- (gnus-message 5 "Requesting regeneration of %s..." server)
- (unless (gnus-open-server server)
- (error "Couldn't open server"))
- (if (gnus-request-regenerate server)
- (gnus-message 5 "Requesting regeneration of %s...done" server)
- (gnus-message 5 "Couldn't regenerate %s" server))))
+ (if (not (gnus-check-backend-function
+ 'request-regenerate (car (gnus-server-to-method server))))
+ (error "This backend doesn't support regeneration")
+ (gnus-message 5 "Requesting regeneration of %s..." server)
+ (unless (gnus-open-server server)
+ (error "Couldn't open server"))
+ (if (gnus-request-regenerate server)
+ (gnus-message 5 "Requesting regeneration of %s...done" server)
+ (gnus-message 5 "Couldn't regenerate %s" server)))))
(provide 'gnus-srvr)
projects / elisp / gnus.git- / blobdiff