X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-srvr.el;h=f92b1ac3c4846c0f524d704811acf166f3fb7353;hb=b719a6d1d90bb76a5f2cb4072064606b9bc0ca06;hp=6c579396f479b2d7285f4f7f6d815c9d205176c8;hpb=b67f34e34bdbd160c1ec5e1ac0d7b4e6ebbebe0f;p=gnus

diff --git a/lisp/gnus-srvr.el b/lisp/gnus-srvr.el
index 6c579396f..f92b1ac3c 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, 2003
-;;        Free Software Foundation, Inc.
+
+;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+;;   2004, 2005, 2006 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))
@@ -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,27 +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 ()
-  "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)))
+  "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)
@@ -391,7 +409,14 @@ gnus-method-to-server."
       (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))))))))
 
@@ -492,9 +517,8 @@ gnus-method-to-server."
 (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."
@@ -730,10 +754,10 @@ gnus-method-to-server."
 	  (if (eq (car method) 'nntp)
 	      (while (not (eobp))
 		(ignore-errors
-		  (push (cons 
-			 (buffer-substring 
+		  (push (cons
+			 (buffer-substring
 			  (point)
-			  (progn 
+			  (progn
 			    (skip-chars-forward "^ \t")
 			    (point)))
 			 (let ((last (read cur)))
@@ -797,18 +821,26 @@ gnus-method-to-server."
 	     (prog1 (1+ (point))
 	       (insert
 		(format "%c%7d: %s\n"
-			(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)))
+			(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)))
-			(mm-decode-coding-string
-			 name
-			 (inline (gnus-group-name-charset method name))))))
-	     (list 'gnus-group name))))
+			;; 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)
@@ -843,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
 		 group gnus-browse-current-method nil
-		 (cons (current-buffer) 'browse))
+		 (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."
@@ -896,8 +931,8 @@ buffer.
   (save-excursion
     (beginning-of-line)
     (let ((name (get-text-property (point) 'gnus-group)))
-      (when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t)
-	(concat (gnus-method-to-server-name 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)))))))
 
@@ -933,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 ? ))
@@ -973,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"))
@@ -981,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