X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-srvr.el;h=ae773657d24359ac71fa48114b2694c82e5e0133;hb=576f700c4b3e7702f2c2f64fdc9298c8bbe8beb3;hp=7b5a851f9d246251e802696a29e4bbc0126ceb9e;hpb=1946c4f9f108ec6ca2600faf55f72f0b37e93099;p=gnus

diff --git a/lisp/gnus-srvr.el b/lisp/gnus-srvr.el
index 7b5a851f9..ae773657d 100644
--- a/lisp/gnus-srvr.el
+++ b/lisp/gnus-srvr.el
@@ -1,17 +1,17 @@
 ;;; gnus-srvr.el --- virtual server support for Gnus
 
 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;;   2004, 2005, 2006, 2007 Free Software Foundation, Inc.
+;;   2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: news
 
 ;; This file is part of GNU Emacs.
 
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; 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.
+;; the Free Software Foundation, either version 3 of the License, 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
@@ -19,9 +19,7 @@
 ;; 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., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 
 ;;; Commentary:
 
@@ -30,11 +28,14 @@
 (eval-when-compile (require 'cl))
 
 (require 'gnus)
+(require 'gnus-start)
 (require 'gnus-spec)
 (require 'gnus-group)
 (require 'gnus-int)
 (require 'gnus-range)
 
+(autoload 'gnus-group-make-nnir-group "nnir")
+
 (defcustom gnus-server-mode-hook nil
   "Hook run in `gnus-server-mode' buffers."
   :group 'gnus-server
@@ -166,6 +167,8 @@ If nil, a faster, but more primitive, buffer is used instead."
 
     "g" gnus-server-regenerate-server
 
+    "G" gnus-group-make-nnir-group
+
     "z" gnus-server-compact-server
 
     "\C-c\C-i" gnus-info-find-node
@@ -179,6 +182,7 @@ If nil, a faster, but more primitive, buffer is used instead."
   :group 'gnus-server-visual)
 ;; backward-compatibility alias
 (put 'gnus-server-agent-face 'face-alias 'gnus-server-agent)
+(put 'gnus-server-agent-face 'obsolete-face "22.1")
 
 (defface gnus-server-opened
   '((((class color) (background light)) (:foreground "Green3" :bold t))
@@ -188,6 +192,7 @@ If nil, a faster, but more primitive, buffer is used instead."
   :group 'gnus-server-visual)
 ;; backward-compatibility alias
 (put 'gnus-server-opened-face 'face-alias 'gnus-server-opened)
+(put 'gnus-server-opened-face 'obsolete-face "22.1")
 
 (defface gnus-server-closed
   '((((class color) (background light)) (:foreground "Steel Blue" :italic t))
@@ -198,6 +203,7 @@ If nil, a faster, but more primitive, buffer is used instead."
   :group 'gnus-server-visual)
 ;; backward-compatibility alias
 (put 'gnus-server-closed-face 'face-alias 'gnus-server-closed)
+(put 'gnus-server-closed-face 'obsolete-face "22.1")
 
 (defface gnus-server-denied
   '((((class color) (background light)) (:foreground "Red" :bold t))
@@ -207,6 +213,7 @@ If nil, a faster, but more primitive, buffer is used instead."
   :group 'gnus-server-visual)
 ;; backward-compatibility alias
 (put 'gnus-server-denied-face 'face-alias 'gnus-server-denied)
+(put 'gnus-server-denied-face 'obsolete-face "22.1")
 
 (defface gnus-server-offline
   '((((class color) (background light)) (:foreground "Orange" :bold t))
@@ -216,13 +223,14 @@ If nil, a faster, but more primitive, buffer is used instead."
   :group 'gnus-server-visual)
 ;; backward-compatibility alias
 (put 'gnus-server-offline-face 'face-alias 'gnus-server-offline)
+(put 'gnus-server-offline-face 'obsolete-face "22.1")
 
 (defvar gnus-server-font-lock-keywords
-  '(("(\\(agent\\))" 1 gnus-server-agent)
-    ("(\\(opened\\))" 1 gnus-server-opened)
-    ("(\\(closed\\))" 1 gnus-server-closed)
-    ("(\\(offline\\))" 1 gnus-server-offline)
-    ("(\\(denied\\))" 1 gnus-server-denied)))
+  '(("(\\(agent\\))" 1 'gnus-server-agent)
+    ("(\\(opened\\))" 1 'gnus-server-opened)
+    ("(\\(closed\\))" 1 'gnus-server-closed)
+    ("(\\(offline\\))" 1 'gnus-server-offline)
+    ("(\\(denied\\))" 1 'gnus-server-denied)))
 
 (defun gnus-server-mode ()
   "Major mode for listing and editing servers.
@@ -280,22 +288,24 @@ The following commands are available:
        ;; Insert the text.
        (eval gnus-server-line-format-spec))
      (list 'gnus-server (intern gnus-tmp-name)
-           'gnus-named-server (intern (gnus-method-to-server method))))))
+           'gnus-named-server (intern (gnus-method-to-server method t))))))
 
 (defun gnus-enter-server-buffer ()
   "Set up the server buffer."
   (gnus-server-setup-buffer)
   (gnus-configure-windows 'server)
-  (gnus-server-prepare))
+  ;; Usually `gnus-configure-windows' will finish with the
+  ;; `gnus-server-buffer' selected as the current buffer, but not always (I
+  ;; bumped into it when starting from a dedicated *Group* frame, and
+  ;; gnus-configure-windows opened *Server* into its own dedicated frame).
+  (with-current-buffer (get-buffer gnus-server-buffer)
+    (gnus-server-prepare)))
 
 (defun gnus-server-setup-buffer ()
   "Initialize the server buffer."
   (unless (get-buffer gnus-server-buffer)
-    (save-excursion
-      (set-buffer (gnus-get-buffer-create gnus-server-buffer))
-      (gnus-server-mode)
-      (when gnus-carpal
-	(gnus-carpal-setup-buffer 'server)))))
+    (with-current-buffer (gnus-get-buffer-create gnus-server-buffer)
+      (gnus-server-mode))))
 
 (defun gnus-server-prepare ()
   (gnus-set-format 'server-mode)
@@ -343,8 +353,7 @@ The following commands are available:
 (defconst gnus-server-edit-buffer "*Gnus edit server*")
 
 (defun gnus-server-update-server (server)
-  (save-excursion
-    (set-buffer gnus-server-buffer)
+  (with-current-buffer gnus-server-buffer
     (let* ((buffer-read-only nil)
 	   (entry (assoc server gnus-server-alist))
 	   (oentry (assoc (gnus-server-to-method server)
@@ -517,6 +526,8 @@ The following commands are available:
   "Close all servers."
   (interactive)
   (dolist (server gnus-inserted-opened-servers)
+    (gnus-server-close-server (car server)))
+  (dolist (server gnus-server-alist)
     (gnus-server-close-server (car server))))
 
 (defun gnus-server-deny-server (server)
@@ -539,6 +550,7 @@ The following commands are available:
   (gnus-server-list-servers))
 
 (defun gnus-server-copy-server (from to)
+  "Copy a server definiton to a new name."
   (interactive
    (list
     (or (gnus-server-server-name)
@@ -561,8 +573,9 @@ The following commands are available:
 
 (defun gnus-server-add-server (how where)
   (interactive
-   (list (intern (completing-read "Server method: "
-				  gnus-valid-select-methods nil t))
+   (list (intern (gnus-completing-read "Server method"
+                                       (mapcar 'car gnus-valid-select-methods)
+                                       t))
 	 (read-string "Server name: ")))
   (when (assq where gnus-server-alist)
     (error "Server with that name already defined"))
@@ -572,7 +585,7 @@ The following commands are available:
 (defun gnus-server-goto-server (server)
   "Jump to a server line."
   (interactive
-   (list (completing-read "Goto server: " gnus-server-alist nil t)))
+   (list (gnus-completing-read "Goto server" (mapcar 'car gnus-server-alist) t)))
   (let ((to (text-property-any (point-min) (point-max)
 			       'gnus-server (intern server))))
     (when to
@@ -618,8 +631,7 @@ The following commands are available:
   (let ((buf (current-buffer)))
     (prog1
 	(gnus-browse-foreign-server server buf)
-      (save-excursion
-	(set-buffer buf)
+      (with-current-buffer buf
 	(gnus-server-update-server (gnus-server-server-name))
 	(gnus-server-position-point)))))
 
@@ -636,6 +648,30 @@ The following commands are available:
 (defvar gnus-browse-menu-hook nil
   "*Hook run after the creation of the browse mode menu.")
 
+(defcustom gnus-browse-subscribe-newsgroup-method
+  'gnus-subscribe-alphabetically
+  "Function(s) called when subscribing groups in the Browse Server Buffer
+A few pre-made functions are supplied: `gnus-subscribe-randomly'
+inserts new groups at the beginning of the list of groups;
+`gnus-subscribe-alphabetically' inserts new groups in strict
+alphabetic order; `gnus-subscribe-hierarchically' inserts new groups
+in hierarchical newsgroup order; `gnus-subscribe-interactively' asks
+for your decision; `gnus-subscribe-killed' kills all new groups;
+`gnus-subscribe-zombies' will make all new groups into zombies;
+`gnus-subscribe-topics' will enter groups into the topics that
+claim them."
+  :version "24.1"
+  :group 'gnus-server
+  :type '(radio (function-item gnus-subscribe-randomly)
+		(function-item gnus-subscribe-alphabetically)
+		(function-item gnus-subscribe-hierarchically)
+		(function-item gnus-subscribe-interactively)
+		(function-item gnus-subscribe-killed)
+		(function-item gnus-subscribe-zombies)
+		(function-item gnus-subscribe-topics)
+		function
+		(repeat function)))
+
 (defvar gnus-browse-mode-hook nil)
 (defvar gnus-browse-mode-map nil)
 (put 'gnus-browse-mode 'mode-class 'special)
@@ -725,11 +761,12 @@ The following commands are available:
 	      (while (not (eobp))
 		(ignore-errors
 		  (push (cons
-			 (buffer-substring
-			  (point)
-			  (progn
-			    (skip-chars-forward "^ \t")
-			    (point)))
+			 (mm-string-as-unibyte
+			  (buffer-substring
+			   (point)
+			   (progn
+			     (skip-chars-forward "^ \t")
+			     (point))))
 			 (let ((last (read cur)))
 			   (cons (read cur) last)))
 			groups))
@@ -737,18 +774,19 @@ The following commands are available:
 	    (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))
+		       (mm-string-as-unibyte
+			(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))
@@ -770,8 +808,6 @@ The following commands are available:
 	    (funcall gnus-group-prepare-function
 		     gnus-level-killed 'ignore 1 'ignore))
 	(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))
@@ -881,7 +917,9 @@ If NUMBER, fetch this number of articles."
   (gnus-browse-next-group (- n)))
 
 (defun gnus-browse-unsubscribe-current-group (arg)
-  "(Un)subscribe to the next ARG groups."
+  "(Un)subscribe to the next ARG groups.
+The variable `gnus-browse-subscribe-newsgroup-method' determines
+how new groups will be entered into the group buffer."
   (interactive "p")
   (when (eobp)
     (error "No group at current line"))
@@ -930,22 +968,24 @@ If NUMBER, fetch this number of articles."
 	    ;; subscribe to it.
  	    (if (gnus-ephemeral-group-p group)
 		(gnus-kill-ephemeral-group group))
-	    ;; We need to discern between killed/zombie groups and
-	    ;; just unsubscribed ones.
-	    (gnus-group-change-level
-	     (or (gnus-group-entry group)
-		 (list t group gnus-level-default-subscribed
-		       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)
-	     (and (car (nth 1 gnus-newsrc-alist))
-		  (gnus-group-entry (car (nth 1 gnus-newsrc-alist))))
-	     (null (gnus-group-entry group)))
+	    (let ((entry (gnus-group-entry group)))
+	      (if entry
+		  ;; Just change the subscription level if it is an
+		  ;; unsubscribed group.
+		  (gnus-group-change-level entry
+					   gnus-level-default-subscribed)
+		;; If it is a killed group or a zombie, feed it to the
+		;; mechanism for new group subscription.
+		(gnus-call-subscribe-functions
+		 gnus-browse-subscribe-newsgroup-method
+		 group)))
 	    (delete-char 1)
-	    (insert ? ))
+	    (insert (let ((lvl (gnus-group-level group)))
+		      (cond
+		       ((< lvl gnus-level-unsubscribed) ? )
+		       ((< lvl gnus-level-zombie) ?U)
+		       ((< lvl gnus-level-killed) ?Z)
+		       (t ?K)))))
 	(gnus-group-change-level
 	 group gnus-level-unsubscribed gnus-level-default-subscribed)
 	(delete-char 1)
@@ -958,8 +998,7 @@ If NUMBER, fetch this number of articles."
   (when (eq major-mode 'gnus-browse-mode)
     (gnus-kill-buffer (current-buffer)))
   ;; Insert the newly subscribed groups in the group buffer.
-  (save-excursion
-    (set-buffer gnus-group-buffer)
+  (with-current-buffer gnus-group-buffer
     (gnus-group-list-groups nil))
   (if gnus-browse-return-buffer
       (gnus-configure-windows 'server 'force)
@@ -968,7 +1007,7 @@ If NUMBER, fetch this number of articles."
 (defun gnus-browse-describe-briefly ()
   "Give a one line description of the group mode commands."
   (interactive)
-  (gnus-message 6
+  (gnus-message 6 "%s"
 		(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")))
 
 (defun gnus-server-regenerate-server ()
@@ -1025,5 +1064,4 @@ Requesting compaction of %s... (this may take a long time)"
 
 (provide 'gnus-srvr)
 
-;;; arch-tag: c0117f64-27ca-475d-9406-8da6854c7a25
 ;;; gnus-srvr.el ends here