X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-srvr.el;h=6c579396f479b2d7285f4f7f6d815c9d205176c8;hb=a1508e9da2310fe49b53cc0c6a69c2f32dd1522e;hp=736d61a83e532878f6db87abb2c5f66d181562b0;hpb=1e79f51e326066b9f92a673d782668ed7a5f4f13;p=gnus diff --git a/lisp/gnus-srvr.el b/lisp/gnus-srvr.el index 736d61a83..6c579396f 100644 --- a/lisp/gnus-srvr.el +++ b/lisp/gnus-srvr.el @@ -1,5 +1,5 @@ ;;; gnus-srvr.el --- virtual server support for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen @@ -57,8 +57,8 @@ The following specs are understood: %s status %a agent covered -General format specifiers can also be used. -See (gnus)Formatting Variables." +General format specifiers can also be used. +See Info node `(gnus)Formatting Variables'." :link '(custom-manual "(gnus)Formatting Variables") :group 'gnus-server-visual :type 'string) @@ -72,7 +72,7 @@ See (gnus)Formatting Variables." "Whether server browsing should take place in the group buffer. If nil, a faster, but more primitive, buffer is used instead." :group 'gnus-server-visual - :type 'string) + :type 'boolean) ;;; Internal variables. @@ -105,7 +105,7 @@ If nil, a faster, but more primitive, buffer is used instead." (easy-menu-define gnus-server-server-menu gnus-server-mode-map "" '("Server" - ["Add" gnus-server-add-server t] + ["Add..." gnus-server-add-server t] ["Browse" gnus-server-read-server t] ["Scan" gnus-server-scan-server t] ["List" gnus-server-list-servers t] @@ -262,27 +262,26 @@ The following commands are available: (if (featurep 'xemacs) (put 'gnus-server-mode 'font-lock-defaults '(gnus-server-font-lock-keywords t)) (set (make-local-variable 'font-lock-defaults) - '(gnus-server-font-lock-keywords t))) + '(gnus-server-font-lock-keywords t))) (gnus-run-hooks 'gnus-server-mode-hook)) (defun gnus-server-insert-server-line (gnus-tmp-name method) (let* ((gnus-tmp-how (car method)) (gnus-tmp-where (nth 1 method)) (elem (assoc method gnus-opened-servers)) - (gnus-tmp-status - (cond + (gnus-tmp-status + (cond ((eq (nth 1 elem) 'denied) "(denied)") ((eq (nth 1 elem) 'offline) "(offline)") (t - (condition-case nil - (if (or (gnus-server-opened method) - (eq (nth 1 elem) 'ok)) + (condition-case nil + (if (or (gnus-server-opened method) + (eq (nth 1 elem) 'ok)) "(opened)" - "(closed)") - ((error) "(error)"))))) + "(closed)") + ((error) "(error)"))))) (gnus-tmp-agent (if (and gnus-agent - (member method - gnus-agent-covered-methods)) + (gnus-agent-method-p method)) " (agent)" ""))) (beginning-of-line) @@ -291,7 +290,8 @@ The following commands are available: (prog1 (1+ (point)) ;; Insert the text. (eval gnus-server-line-format-spec)) - (list 'gnus-server (intern gnus-tmp-name))))) + (list 'gnus-server (intern gnus-tmp-name) + 'gnus-named-server (intern (gnus-method-to-server method)))))) (defun gnus-enter-server-buffer () "Set up the server buffer." @@ -321,7 +321,7 @@ The following commands are available: (while alist (unless (member (cdar alist) done) (push (cdar alist) done) - (cdr (setq server (pop alist))) + (setq server (pop alist)) (when (and server (car server) (cdr server)) (gnus-server-insert-server-line (car server) (cdr server)))) (when (member (cdar alist) done) @@ -345,6 +345,12 @@ The following commands are available: (let ((server (get-text-property (gnus-point-at-bol) 'gnus-server))) (and server (symbol-name server)))) +(defun gnus-server-named-server () + "Returns a server name that matches one of the names returned by +gnus-method-to-server." + (let ((server (get-text-property (gnus-point-at-bol) 'gnus-named-server))) + (and server (symbol-name server)))) + (defalias 'gnus-server-position-point 'gnus-goto-colon) (defconst gnus-server-edit-buffer "*Gnus edit server*") @@ -359,7 +365,7 @@ The following commands are available: (when entry (gnus-dribble-enter (concat "(gnus-server-set-info \"" server "\" '" - (prin1-to-string (cdr entry)) ")\n"))) + (gnus-prin1-to-string (cdr entry)) ")\n"))) (when (or entry oentry) ;; Buffer may be narrowed. (save-restriction @@ -378,9 +384,13 @@ The following commands are available: (when (and server info) (gnus-dribble-enter (concat "(gnus-server-set-info \"" server "\" '" - (prin1-to-string info) ")")) + (gnus-prin1-to-string info) ")")) (let* ((server (nth 1 info)) - (entry (assoc server gnus-server-alist))) + (entry (assoc server gnus-server-alist)) + (cached (assoc server gnus-server-method-cache))) + (if cached + (setq gnus-server-method-cache + (delq cached gnus-server-method-cache))) (if entry (setcdr entry info) (setq gnus-server-alist (nconc gnus-server-alist (list (cons server info)))))))) @@ -432,7 +442,7 @@ The following commands are available: (setq alist (cdr alist))) (if alist (setcdr alist (cons killed (cdr alist))) - (setq gnus-server-alist (list killed))))) + (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))) @@ -441,7 +451,7 @@ The following commands are available: "Return to the group buffer." (interactive) (gnus-run-hooks 'gnus-server-exit-hook) - (kill-buffer (current-buffer)) + (gnus-kill-buffer (current-buffer)) (gnus-configure-windows 'group t)) (defun gnus-server-list-servers () @@ -658,6 +668,7 @@ The following commands are available: "L" gnus-browse-exit "q" gnus-browse-exit "Q" gnus-browse-exit + "d" gnus-browse-describe-group "\C-c\C-c" gnus-browse-exit "?" gnus-browse-describe-briefly @@ -673,6 +684,7 @@ The following commands are available: ["Subscribe" gnus-browse-unsubscribe-current-group t] ["Read" gnus-browse-read-group t] ["Select" gnus-browse-select-group t] + ["Describe" gnus-browse-describe-group t] ["Next" gnus-browse-next-group t] ["Prev" gnus-browse-prev-group t] ["Exit" gnus-browse-exit t])) @@ -707,31 +719,46 @@ The following commands are available: 1 "Couldn't request list: %s" (gnus-status-message method)) nil) (t - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-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) + ;; We treat NNTP as a special case to avoid problems with + ;; garbage group names like `"foo' that appear in some badly + ;; managed active files. -jh. + (if (eq (car method) 'nntp) + (while (not (eobp)) + (ignore-errors + (push (cons + (buffer-substring + (point) + (progn + (skip-chars-forward "^ \t") + (point))) + (let ((last (read cur))) + (cons (read cur) last))) + groups)) + (forward-line)) + (while (not (eobp)) + (ignore-errors + (push (cons + (if (eq (char-after) ?\") + (read cur) + (let ((p (point)) (name "")) (skip-chars-forward "^ \t\\\\") - (setq name (concat name (buffer-substring - p (point))))) - name)) - (let ((last (read cur))) - (cons (read cur) last))) - groups)) - (forward-line)))) + (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))))) (setq groups (sort groups (lambda (l1 l2) (string< (car l1) (car l2))))) @@ -760,27 +787,28 @@ The following commands are available: (list (format "Gnus: %%b {%s:%s}" (car method) (cadr method)))) - (let ((buffer-read-only nil) charset + (let ((buffer-read-only nil) + name (prefix (let ((gnus-select-method orig-select-method)) (gnus-group-prefixed-name "" method)))) - (while groups - (setq group (car groups)) - (setq charset (gnus-group-name-charset method (car group))) + (while (setq group (pop groups)) (gnus-add-text-properties (point) (prog1 (1+ (point)) (insert (format "%c%7d: %s\n" - (let ((level (gnus-group-level (concat prefix (car group))))) + (let ((level (gnus-group-level + (concat prefix (setq name (car group)))))) (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)))) + (mm-decode-coding-string + name + (inline (gnus-group-name-charset method name)))))) + (list 'gnus-group name)))) (switch-to-buffer (current-buffer))) (goto-char (point-min)) (gnus-group-position-point) @@ -824,7 +852,7 @@ buffer. (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) @@ -869,10 +897,14 @@ buffer. (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))))) + (concat (gnus-method-to-server-name gnus-browse-current-method) ":" + (or name + (match-string-no-properties 1))))))) + +(defun gnus-browse-describe-group (group) + "Describe the current group." + (interactive (list (gnus-browse-group-name))) + (gnus-group-describe-group nil group)) (defun gnus-browse-unsubscribe-group () "Toggle subscription of the current group in the browse buffer." @@ -885,10 +917,8 @@ buffer. (unless (eq (char-after) ? ) (setq sub t)) (setq group (gnus-browse-group-name)) - ;;;; - ;;(when (and sub - ;; (cadr (gnus-gethash group gnus-newsrc-hashtb))) - ;;(error "Group already subscribed")) + (when (gnus-server-equal gnus-browse-current-method "native") + (setq group (gnus-group-real-name group))) (if sub (progn ;; Make sure the group has been properly removed before we @@ -918,7 +948,7 @@ buffer. "Quit browsing and return to the group buffer." (interactive) (when (eq major-mode 'gnus-browse-mode) - (kill-buffer (current-buffer))) + (gnus-kill-buffer (current-buffer))) ;; Insert the newly subscribed groups in the group buffer. (save-excursion (set-buffer gnus-group-buffer)