X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-srvr.el;h=5a2f895785fb4601d00fbee89788f75026fb136c;hp=351eb86c28c408a9c8b9fa1c0e5097c8e62267b1;hb=19129ec856209505e3ba9f85d67736d6ac974e6d;hpb=bae2d2abde73c4d87276a77bb5ca920a7e1d1966

diff --git a/lisp/gnus-srvr.el b/lisp/gnus-srvr.el
index 351eb86c2..5a2f89578 100644
--- a/lisp/gnus-srvr.el
+++ b/lisp/gnus-srvr.el
@@ -1,6 +1,7 @@
 ;;; gnus-srvr.el --- virtual server support for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
-;;        Free Software Foundation, Inc.
+
+;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+;;   2004, 2005 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: news
@@ -19,8 +20,8 @@
 
 ;; 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.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
 
 ;;; Commentary:
 
@@ -51,7 +52,7 @@ with some simple extensions.
 
 The following specs are understood:
 
-%h backend
+%h back end
 %n name
 %w address
 %s status
@@ -71,6 +72,7 @@ See Info node `(gnus)Formatting Variables'."
 (defcustom gnus-server-browse-in-group-buffer nil
   "Whether server browsing should take place in the group buffer.
 If nil, a faster, but more primitive, buffer is used instead."
+  :version "22.1"
   :group 'gnus-server-visual
   :type 'boolean)
 
@@ -114,6 +116,7 @@ If nil, a faster, but more primitive, buffer is used instead."
        ["Copy" gnus-server-copy-server t]
        ["Edit" gnus-server-edit-server t]
        ["Regenerate" gnus-server-regenerate-server t]
+       ["Compact" gnus-server-compact-server t]
        ["Exit" gnus-server-exit t]))
 
     (easy-menu-define
@@ -163,67 +166,84 @@ If nil, a faster, but more primitive, buffer is used instead."
 
     "g" gnus-server-regenerate-server
 
+    "z" gnus-server-compact-server
+
     "\C-c\C-i" gnus-info-find-node
     "\C-c\C-b" gnus-bug))
 
-(defface gnus-server-agent-face
+(defface gnus-server-agent
   '((((class color) (background light)) (:foreground "PaleTurquoise" :bold t))
     (((class color) (background dark)) (:foreground "PaleTurquoise" :bold t))
     (t (:bold t)))
   "Face used for displaying AGENTIZED servers"
   :group 'gnus-server-visual)
+;; backward-compatibility alias
+(put 'gnus-server-agent-face 'face-alias 'gnus-server-agent)
 
-(defface gnus-server-opened-face
+(defface gnus-server-opened
   '((((class color) (background light)) (:foreground "Green3" :bold t))
     (((class color) (background dark)) (:foreground "Green1" :bold t))
     (t (:bold t)))
   "Face used for displaying OPENED servers"
   :group 'gnus-server-visual)
+;; backward-compatibility alias
+(put 'gnus-server-opened-face 'face-alias 'gnus-server-opened)
 
-(defface gnus-server-closed-face
+(defface gnus-server-closed
   '((((class color) (background light)) (:foreground "Steel Blue" :italic t))
     (((class color) (background dark))
      (:foreground "Light Steel Blue" :italic t))
     (t (:italic t)))
   "Face used for displaying CLOSED servers"
   :group 'gnus-server-visual)
+;; backward-compatibility alias
+(put 'gnus-server-closed-face 'face-alias 'gnus-server-closed)
 
-(defface gnus-server-denied-face
+(defface gnus-server-denied
   '((((class color) (background light)) (:foreground "Red" :bold t))
     (((class color) (background dark)) (:foreground "Pink" :bold t))
     (t (:inverse-video t :bold t)))
   "Face used for displaying DENIED servers"
   :group 'gnus-server-visual)
+;; backward-compatibility alias
+(put 'gnus-server-denied-face 'face-alias 'gnus-server-denied)
 
-(defface gnus-server-offline-face
+(defface gnus-server-offline
   '((((class color) (background light)) (:foreground "Orange" :bold t))
     (((class color) (background dark)) (:foreground "Yellow" :bold t))
     (t (:inverse-video t :bold t)))
   "Face used for displaying OFFLINE servers"
   :group 'gnus-server-visual)
+;; backward-compatibility alias
+(put 'gnus-server-offline-face 'face-alias 'gnus-server-offline)
 
-(defcustom gnus-server-agent-face 'gnus-server-agent-face
+(defcustom gnus-server-agent-face 'gnus-server-agent
   "Face name to use on AGENTIZED servers."
+  :version "22.1"
   :group 'gnus-server-visual
   :type 'face)
 
-(defcustom gnus-server-opened-face 'gnus-server-opened-face
+(defcustom gnus-server-opened-face 'gnus-server-opened
   "Face name to use on OPENED servers."
+  :version "22.1"
   :group 'gnus-server-visual
   :type 'face)
 
-(defcustom gnus-server-closed-face 'gnus-server-closed-face
+(defcustom gnus-server-closed-face 'gnus-server-closed
   "Face name to use on CLOSED servers."
+  :version "22.1"
   :group 'gnus-server-visual
   :type 'face)
 
-(defcustom gnus-server-denied-face 'gnus-server-denied-face
+(defcustom gnus-server-denied-face 'gnus-server-denied
   "Face name to use on DENIED servers."
+  :version "22.1"
   :group 'gnus-server-visual
   :type 'face)
 
-(defcustom gnus-server-offline-face 'gnus-server-offline-face
+(defcustom gnus-server-offline-face 'gnus-server-offline
   "Face name to use on OFFLINE servers."
+  :version "22.1"
   :group 'gnus-server-visual
   :type 'face)
 
@@ -263,7 +283,7 @@ The following commands are available:
       (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-run-hooks 'gnus-server-mode-hook))
+  (gnus-run-mode-hooks 'gnus-server-mode-hook))
 
 (defun gnus-server-insert-server-line (gnus-tmp-name method)
   (let* ((gnus-tmp-how (car method))
@@ -281,8 +301,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 +310,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."
@@ -313,7 +333,6 @@ The following commands are available:
   (gnus-set-format 'server 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)
@@ -328,21 +347,26 @@ The following commands are available:
 	(pop alist)))
     ;; Then we insert the list of servers that have been opened in
     ;; this session.
-    (while opened
-      (when (and (not (member (caar opened) done))
+    (dolist (open gnus-opened-servers)
+      (when (and (not (member (car open) done))
 		 ;; Just ignore ephemeral servers.
-		 (not (member (caar opened) gnus-ephemeral-servers)))
-	(push (caar opened) done)
+		 (not (member (car open) gnus-ephemeral-servers)))
+	(push (car open) 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))))
+	 (setq op-ser (format "%s:%s" (caar open) (nth 1 (car open))))
+	 (car open))
+	(push (list op-ser (car open)) gnus-inserted-opened-servers))))
   (goto-char (point-min))
   (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 ()
+  "Return 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 +383,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,14 +402,21 @@ 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)))
       (if cached
 	  (setq gnus-server-method-cache
 		(delq cached gnus-server-method-cache)))
-      (if entry (setcdr entry info)
+      (if entry
+	  (progn
+	    ;; Remove the server from `gnus-opened-servers' since
+	    ;; it has never been opened with the new `info' yet.
+	    (gnus-opened-servers-remove (cdr entry))
+	    ;; Don't make a new Lisp object.
+	    (setcar (cdr entry) (car info))
+	    (setcdr (cdr entry) (cdr info)))
 	(setq gnus-server-alist
 	      (nconc gnus-server-alist (list (cons server info))))))))
 
@@ -445,7 +476,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 ()
@@ -486,9 +517,8 @@ The following commands are available:
 (defun gnus-server-open-all-servers ()
   "Open all servers."
   (interactive)
-  (let ((servers gnus-inserted-opened-servers))
-    (while servers
-      (gnus-server-open-server (car (pop servers))))))
+  (dolist (server gnus-inserted-opened-servers)
+    (gnus-server-open-server (car server))))
 
 (defun gnus-server-close-server (server)
   "Close SERVER."
@@ -678,7 +708,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 +743,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)))))
@@ -767,27 +812,35 @@ The following commands are available:
 	       (format
 		"Gnus: %%b {%s:%s}" (car method) (cadr method))))
 	(let ((buffer-read-only nil)
-	      charset
+	      name
 	      (prefix (let ((gnus-select-method orig-select-method))
 			(gnus-group-prefixed-name "" method))))
-	  (dolist (group 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)))))
-			      (cond
-			       ((<= level gnus-level-subscribed) ? )
-			       ((<= level gnus-level-unsubscribed) ?U)
-			       ((= level gnus-level-zombie) ?Z)
-			       (t ?K)))
+			(let ((level
+			       (if (string= prefix "")
+				   (gnus-group-level (setq name (car group)))
+				 (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))))
+			;; Don't decode if name is ASCII
+			(if (and (fboundp 'detect-coding-string)
+				 (eq (detect-coding-string name t) 'undecided))
+			    name
+			  (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)
@@ -822,25 +875,28 @@ buffer.
   (setq truncate-lines t)
   (gnus-set-default-directory)
   (setq buffer-read-only t)
-  (gnus-run-hooks 'gnus-browse-mode-hook))
+  (gnus-run-mode-hooks 'gnus-browse-mode-hook))
 
-(defun gnus-browse-read-group (&optional no-article)
-  "Enter the group at the current line."
-  (interactive)
+(defun gnus-browse-read-group (&optional no-article number)
+  "Enter the group at the current line.
+If NUMBER, fetch this number of articles."
+  (interactive "P")
   (let ((group (gnus-browse-group-name)))
     (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
-		 (cons (current-buffer) 'browse))
+		 group gnus-browse-current-method nil
+		 (cons (current-buffer) 'browse)
+		 nil nil nil number)
 	  (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)
-  (gnus-browse-read-group 'no))
+(defun gnus-browse-select-group (&optional number)
+  "Select the current group.
+If NUMBER, fetch this number of articles."
+  (interactive "P")
+  (gnus-browse-read-group 'no number))
 
 (defun gnus-browse-next-group (n)
   "Go to the next group."
@@ -875,11 +931,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 +952,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
@@ -911,8 +968,7 @@ buffer.
 			      gnus-browse-current-method)))
 	     gnus-level-default-subscribed (gnus-group-level group)
 	     (and (car (nth 1 gnus-newsrc-alist))
-		  (gnus-gethash (car (nth 1 gnus-newsrc-alist))
-				gnus-newsrc-hashtb))
+		  (gnus-group-entry (car (nth 1 gnus-newsrc-alist))))
 	     t)
 	    (delete-char 1)
 	    (insert ? ))
@@ -926,7 +982,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)
@@ -951,7 +1007,7 @@ buffer.
 	(gnus-get-function (gnus-server-to-method server)
 			   'request-regenerate)
       (error
-	(error "This backend doesn't support regeneration")))
+	(error "This back end doesn't support regeneration")))
     (gnus-message 5 "Requesting regeneration of %s..." server)
     (unless (gnus-open-server server)
       (error "Couldn't open server"))
@@ -959,6 +1015,41 @@ buffer.
 	(gnus-message 5 "Requesting regeneration of %s...done" server)
       (gnus-message 5 "Couldn't regenerate %s" server))))
 
+
+;;;
+;;; Server compaction. -- dvl
+;;;
+
+;; #### FIXME: this function currently fails to update the Group buffer's
+;; #### appearance.
+(defun gnus-server-compact-server ()
+  "Issue a command to the server to compact all its groups.
+
+Note: currently only implemented in nnml."
+  (interactive)
+  (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-compact)
+      (error
+       (error "This back end doesn't support compaction")))
+    (gnus-message 5 "\
+Requesting compaction of %s... (this may take a long time)"
+		  server)
+    (unless (gnus-open-server server)
+      (error "Couldn't open server"))
+    (if (not (gnus-request-compact server))
+	(gnus-message 5 "Couldn't compact %s" server)
+      (gnus-message 5 "Requesting compaction of %s...done" server)
+      ;; Invalidate the original article buffer which might be out of date.
+      ;; #### NOTE: Yes, this might be a bit rude, but since compaction
+      ;; #### will not happen very often, I think this is acceptable.
+      (let ((original (get-buffer gnus-original-article-buffer)))
+	(and original (gnus-kill-buffer original))))))
+
 (provide 'gnus-srvr)
 
+;;; arch-tag: c0117f64-27ca-475d-9406-8da6854c7a25
 ;;; gnus-srvr.el ends here