X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-srvr.el;h=0e41ff5f27738be63d8aef356ed1431ae4a597f2;hb=a77dd35f2d1dc13eb88e5b153d4c03b83f7eb2c7;hp=5220f2e2db6b6b8c30e922a23b5cfc1b3d528901;hpb=08d63e5990ef4c3995f5623e7dd26bf1a8a00f97;p=gnus diff --git a/lisp/gnus-srvr.el b/lisp/gnus-srvr.el index 5220f2e2d..0e41ff5f2 100644 --- a/lisp/gnus-srvr.el +++ b/lisp/gnus-srvr.el @@ -281,8 +281,7 @@ The following commands are available: "(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." @@ -342,7 +342,13 @@ The following commands are available: (gnus-server-position-point)) (defun gnus-server-server-name () - (let ((server (get-text-property (gnus-point-at-bol) 'gnus-server))) + (let ((server (get-text-property (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 (point-at-bol) 'gnus-named-server))) (and server (symbol-name server)))) (defalias 'gnus-server-position-point 'gnus-goto-colon) @@ -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,7 +384,7 @@ 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)) (cached (assoc server gnus-server-method-cache))) @@ -678,7 +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-groups t] + ["Describe" gnus-browse-describe-group t] ["Next" gnus-browse-next-group t] ["Prev" gnus-browse-prev-group t] ["Exit" gnus-browse-exit t])) @@ -713,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))))) @@ -831,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) @@ -875,11 +896,10 @@ buffer. (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 ": \\(.*\\)$" (point-at-eol) t) + (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." @@ -897,6 +917,8 @@ buffer. (unless (eq (char-after) ? ) (setq sub t)) (setq group (gnus-browse-group-name)) + (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