emacs: lisp/gnus/gnus-group.el comparison

comparison lisp/gnus/gnus-group.el @ 31716:9968f55ad26e

Update to emacs-21-branch of the Gnus CVS repository.

author	Gerd Moellmann <gerd@gnu.org>
date	Tue, 19 Sep 2000 13:37:09 +0000
parents	d0ccf995f1ae
children	51cea22fd2aa

comparison

equal deleted inserted replaced

-:7c896543d225
+:9968f55ad26e
 ;;; gnus-group.el --- group mode commands for Gnus
-;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000
+;;        Free Software Foundation, Inc.
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: news
 ;; This file is part of GNU Emacs.
 ;; Boston, MA 02111-1307, USA.
 ;;; Commentary:
 ;;; Code:
-(eval-when-compile (require 'cl))
 (eval-when-compile (require 'cl))
 (require 'gnus)
 (require 'gnus-start)
 (require 'gnus-spec)
 (require 'gnus-int)
 (require 'gnus-range)
 (require 'gnus-win)
 (require 'gnus-undo)
+(require 'time-date)
 (defcustom gnus-group-archive-directory
 "*ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/"
 "*The address of the (ding) archives."
 :group 'gnus-group-foreign
 "*ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list-recent/"
 "*The address of the most recent (ding) articles."
 :group 'gnus-group-foreign
 :type 'directory)
-(defcustom gnus-no-groups-message "No news is no news"
+(defcustom gnus-no-groups-message "No gnus is bad news"
 "*Message displayed by Gnus when no groups are available."
 :group 'gnus-start
 :type 'string)
 (defcustom gnus-keep-same-level nil
 %m    Whether there is new(ish) mail in the group (char, \"%\")
 %l    Whether there are GroupLens predictions for this group (string)
 %n    Select from where (string)
 %z    A string that look like `<%s:%n>' if a foreign select method is used
 %d    The date the group was last entered.
+%E    Icon as defined by `gnus-group-icon-list'.
 %u    User defined specifier.  The next character in the format string should
 be a letter.  Gnus will call the function gnus-user-format-function-X,
 where X is the letter following %u.  The function will be passed the
 current header as argument.  The function should return a string, which
 will be inserted into the buffer just like information from any other
 gnus-group-news-2-face)
 ((and (= unread 0) (not mailp) (eq level 3)) .
 gnus-group-news-3-empty-face)
 ((and (not mailp) (eq level 3)) .
 gnus-group-news-3-face)
+((and (= unread 0) (not mailp) (eq level 4)) .
+gnus-group-news-4-empty-face)
+((and (not mailp) (eq level 4)) .
+gnus-group-news-4-face)
+((and (= unread 0) (not mailp) (eq level 5)) .
+gnus-group-news-5-empty-face)
+((and (not mailp) (eq level 5)) .
+gnus-group-news-5-face)
+((and (= unread 0) (not mailp) (eq level 6)) .
+gnus-group-news-6-empty-face)
+((and (not mailp) (eq level 6)) .
+gnus-group-news-6-face)
 ((and (= unread 0) (not mailp)) .
 gnus-group-news-low-empty-face)
 ((and (not mailp)) .
 gnus-group-news-low-face)
 ;; Mail.
 ((eq level 3) .
 gnus-group-mail-3-face)
 ((= unread 0) .
 gnus-group-mail-low-empty-face)
 (t .
 gnus-group-mail-low-face))
 "*Controls the highlighting of group buffer lines.
 Below is a list of `Form'/`Face' pairs.  When deciding how a a
 particular group line should be displayed, each form is
 evaluated.  The content of the face field after the first true form is
 (defcustom gnus-new-mail-mark ?%
 "Mark used for groups with new mail."
 :group 'gnus-group-visual
 :type 'character)
+(defgroup gnus-group-icons nil
+"Add Icons to your group buffer.  "
+:group 'gnus-group-visual)
+(defcustom gnus-group-icon-list
+nil
+"*Controls the insertion of icons into group buffer lines.
+Below is a list of `Form'/`File' pairs.  When deciding how a
+particular group line should be displayed, each form is evaluated.
+The icon from the file field after the first true form is used.  You
+can change how those group lines are displayed by editing the file
+field.  The File will either be found in the
+`gnus-group-glyph-directory' or by designating absolute path to the
+file.
+It is also possible to change and add form fields, but currently that
+requires an understanding of Lisp expressions.  Hopefully this will
+change in a future release.  For now, you can use the following
+variables in the Lisp expression:
+group: The name of the group.
+unread: The number of unread articles in the group.
+method: The select method used.
+mailp: Whether it's a mail group or not.
+newsp: Whether it's a news group or not
+level: The level of the group.
+score: The score of the group.
+ticked: The number of ticked articles."
+:group 'gnus-group-icons
+:type '(repeat (cons (sexp :tag "Form") file)))
+(defcustom gnus-group-name-charset-method-alist nil
+"*Alist of method and the charset for group names.
+For example:
+(((nntp \"news.com.cn\") . cn-gb-2312))
+"
+:group 'gnus-charset
+:type '(repeat (cons (sexp :tag "Method") (symbol :tag "Charset"))))
+(defcustom gnus-group-name-charset-group-alist nil
+"*Alist of group regexp and the charset for group names.
+For example:
+((\"\\.com\\.cn:\" . cn-gb-2312))
+"
+:group 'gnus-charset
+:type '(repeat (cons (regexp :tag "Group") (symbol :tag "Charset"))))
 ;;; Internal variables
 (defvar gnus-group-sort-alist-function 'gnus-group-sort-flat
 "Function for sorting the group buffer.")
 (?O gnus-tmp-moderated-string ?s)
 (?p gnus-tmp-process-marked ?c)
 (?s gnus-tmp-news-server ?s)
 (?n gnus-tmp-news-method ?s)
 (?P gnus-group-indentation ?s)
+(?E gnus-tmp-group-icon ?s)
 (?l gnus-tmp-grouplens ?s)
 (?z gnus-tmp-news-method-string ?s)
 (?m (gnus-group-new-mail gnus-tmp-group) ?c)
 (?d (gnus-group-timestamp-string gnus-tmp-group) ?s)
 (?u gnus-tmp-user-defined ?s)))
 "The complete topic-group alist.")
 (defvar gnus-group-marked nil)
 (defvar gnus-group-list-mode nil)
+(defvar gnus-group-icon-cache nil)
 ;;;
 ;;; Gnus group mode
 ;;;
 (gnus-define-keys gnus-group-mode-map
 " " gnus-group-read-group
 "=" gnus-group-select-group
 "\r" gnus-group-select-group
 "\M-\r" gnus-group-quick-select-group
+"\M- " gnus-group-visible-select-group
 [(meta control return)] gnus-group-select-group-ephemerally
 "j" gnus-group-jump-to-group
 "n" gnus-group-next-unread-group
 "p" gnus-group-prev-unread-group
 "\177" gnus-group-prev-unread-group
 "d" gnus-group-make-directory-group
 "h" gnus-group-make-help-group
 "u" gnus-group-make-useful-group
 "a" gnus-group-make-archive-group
 "k" gnus-group-make-kiboze-group
+"l" gnus-group-nnimap-edit-acl
 "m" gnus-group-make-group
 "E" gnus-group-edit-group
 "e" gnus-group-edit-group-method
 "p" gnus-group-edit-group-parameters
 "v" gnus-group-add-to-virtual
 "D" gnus-group-enter-directory
 "f" gnus-group-make-doc-group
 "w" gnus-group-make-web-group
 "r" gnus-group-rename-group
 "c" gnus-group-customize
+"x" gnus-group-nnimap-expunge
 "\177" gnus-group-delete-group
 [delete] gnus-group-delete-group)
 (gnus-define-keys (gnus-group-soup-map "s" gnus-group-group-map)
 "b" gnus-group-brew-soup
 "A" gnus-group-list-active
 "a" gnus-group-apropos
 "d" gnus-group-description-apropos
 "m" gnus-group-list-matching
 "M" gnus-group-list-all-matching
-"l" gnus-group-list-level)
+"l" gnus-group-list-level
+"c" gnus-group-list-cached
+"?" gnus-group-list-dormant)
 (gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map)
 "f" gnus-score-flush-cache)
 (gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map)
 	["Describe all groups" gnus-group-describe-all-groups t]
 	["Group apropos..." gnus-group-apropos t]
 	["Group and description apropos..." gnus-group-description-apropos t]
 	["List groups matching..." gnus-group-list-matching t]
 	["List all groups matching..." gnus-group-list-all-matching t]
-	["List active file" gnus-group-list-active t])
+	["List active file" gnus-group-list-active t]
+	["List groups with cached" gnus-group-list-cached t]
+	["List groups with dormant" gnus-group-list-dormant t])
 ("Sort"
 	["Default sort" gnus-group-sort-groups t]
 	["Sort by method" gnus-group-sort-groups-by-method t]
 	["Sort by rank" gnus-group-sort-groups-by-rank t]
 	["Sort by score" gnus-group-sort-groups-by-score t]
 	["Send replies" gnus-soup-send-replies
 	 (fboundp 'gnus-soup-pack-packet)]
 	["Pack packet" gnus-soup-pack-packet (fboundp 'gnus-soup-pack-packet)]
 	["Save areas" gnus-soup-save-areas (fboundp 'gnus-soup-pack-packet)]
 	["Brew SOUP" gnus-group-brew-soup (fboundp 'gnus-soup-pack-packet)])
-["Send a bug report" gnus-bug t]
 ["Send a mail" gnus-group-mail t]
 ["Post an article..." gnus-group-post-news t]
 ["Check for new news" gnus-group-get-new-news t]
 ["Activate all groups" gnus-activate-all-groups t]
 ["Restart Gnus" gnus-group-restart t]
 (setq major-mode 'gnus-group-mode)
 (setq mode-name "Group")
 (gnus-group-set-mode-line)
 (setq mode-line-process nil)
 (use-local-map gnus-group-mode-map)
-(buffer-disable-undo (current-buffer))
+(buffer-disable-undo)
 (setq truncate-lines t)
 (setq buffer-read-only t)
 (gnus-set-default-directory)
 (gnus-update-format-specifications nil 'group 'group-mode)
 (gnus-update-group-mark-positions)
-(make-local-hook 'post-command-hook)
-(add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t)
 (when gnus-use-undo
 (gnus-undo-mode 1))
 (when gnus-slave
 (gnus-slave-mode))
 (gnus-run-hooks 'gnus-group-mode-hook))
 (gnus-group-insert-group-line "dummy.group" 0 nil 0 nil)
 (goto-char (point-min))
 (setq gnus-group-mark-positions
 	    (list (cons 'process (and (search-forward "\200" nil t)
 				      (- (point) 2))))))))
-(defun gnus-clear-inboxes-moved ()
-(setq nnmail-moved-inboxes nil))
 (defun gnus-mouse-pick-group (e)
 "Enter the group under the mouse pointer."
 (interactive "e")
 (mouse-set-point e)
 (unless (eq major-mode 'gnus-group-mode)
 (gnus-group-mode)
 (when gnus-carpal
 (gnus-carpal-setup-buffer 'group))))
+(defsubst gnus-group-name-charset (method group)
+(if (null method)
+(setq method (gnus-find-method-for-group group)))
+(let ((item (assoc method gnus-group-name-charset-method-alist))
+	(alist gnus-group-name-charset-group-alist)
+	result)
+(if item
+	(cdr item)
+(while (setq item (pop alist))
+	(if (string-match (car item) group)
+	    (setq alist nil
+		  result (cdr item))))
+result)))
+(defsubst gnus-group-name-decode (string charset)
+(if (and string charset (featurep 'mule))
+(mm-decode-coding-string string charset)
+string))
+(defun gnus-group-decoded-name (string)
+(let ((charset (gnus-group-name-charset nil string)))
+(gnus-group-name-decode string charset)))
 (defun gnus-group-list-groups (&optional level unread lowest)
 "List newsgroups with level LEVEL or lower that have unread articles.
 Default is all subscribed groups.
 If argument UNREAD is non-nil, groups with no unread articles are also
 listed.
 	     (prefix-numeric-value current-prefix-arg)
 	   (or
 	    (gnus-group-default-level nil t)
 	    gnus-group-default-list-level
 	    gnus-level-subscribed))))
-;; Just do this here, for no particular good reason.
-(gnus-clear-inboxes-moved)
 (unless level
 (setq level (car gnus-group-list-mode)
 	  unread (cdr gnus-group-list-mode)))
 (setq level (gnus-group-default-level level))
 (gnus-group-setup-buffer)
 	(setq info (car newsrc)
 	      group (gnus-info-group info)
 	      params (gnus-info-params info)
 	      newsrc (cdr newsrc)
 	      unread (car (gnus-gethash group gnus-newsrc-hashtb)))
-	(and unread			; This group might be bogus
+	(and unread			; This group might be unchecked
 	     (or (not regexp)
 		 (string-match regexp group))
 	     (<= (setq clevel (gnus-info-level info)) level)
 	     (>= clevel lowest)
 	     (or all			; We list all groups?
 	(while groups
 	  (setq group (pop groups))
 	  (when (string-match regexp group)
 	    (gnus-add-text-properties
 	     (point) (prog1 (1+ (point))
-		       (insert " " mark "     *: " group "\n"))
+		       (insert " " mark "     *: "
+			       (gnus-group-name-decode group
+						       (gnus-group-name-charset
+							nil group))
+			       "\n"))
 	     (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb)
 		   'gnus-unread t
 		   'gnus-level level))))
 ;; This loop is used when listing all groups.
 (while groups
+	(setq group (pop groups))
 	(gnus-add-text-properties
 	 (point) (prog1 (1+ (point))
 		   (insert " " mark "     *: "
-			   (setq group (pop groups)) "\n"))
+			   (gnus-group-name-decode group
+						   (gnus-group-name-charset
+						    nil group))
+			   "\n"))
 	 (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb)
 	       'gnus-unread t
 	       'gnus-level level))))))
 (defun gnus-group-update-group-line ()
 (defun gnus-group-insert-group-line (gnus-tmp-group gnus-tmp-level
 						    gnus-tmp-marked number
 						    gnus-tmp-method)
 "Insert a group line in the group buffer."
-(let* ((gnus-tmp-active (gnus-active gnus-tmp-group))
+(let* ((gnus-tmp-method
+	  (gnus-server-get-method gnus-tmp-group gnus-tmp-method))
+	 (group-name-charset (gnus-group-name-charset gnus-tmp-method
+						      gnus-tmp-group))
+	 (gnus-tmp-active (gnus-active gnus-tmp-group))
 	 (gnus-tmp-number-total
 	  (if gnus-tmp-active
 	      (1+ (- (cdr gnus-tmp-active) (car gnus-tmp-active)))
 	    0))
 	 (gnus-tmp-number-of-unread
 	 (gnus-tmp-subscribed
 	  (cond ((<= gnus-tmp-level gnus-level-subscribed) ? )
 		((<= gnus-tmp-level gnus-level-unsubscribed) ?U)
 		((= gnus-tmp-level gnus-level-zombie) ?Z)
 		(t ?K)))
-	 (gnus-tmp-qualified-group (gnus-group-real-name gnus-tmp-group))
+	 (gnus-tmp-qualified-group
+	  (gnus-group-name-decode (gnus-group-real-name gnus-tmp-group)
+				  group-name-charset))
 	 (gnus-tmp-newsgroup-description
 	  (if gnus-description-hashtb
-	      (or (gnus-gethash gnus-tmp-group gnus-description-hashtb) "")
+	      (or (gnus-group-name-decode
+		   (gnus-gethash gnus-tmp-group gnus-description-hashtb)
+		   group-name-charset) "")
 	    ""))
 	 (gnus-tmp-moderated
 	  (if (and gnus-moderated-hashtb
 		   (gnus-gethash gnus-tmp-group gnus-moderated-hashtb))
 	      ?m ? ))
 	 (gnus-tmp-moderated-string
 	  (if (eq gnus-tmp-moderated ?m) "(m)" ""))
-	 (gnus-tmp-method
+	 (gnus-tmp-group-icon "==&&==")
-	  (gnus-server-get-method gnus-tmp-group gnus-tmp-method)) ;
 	 (gnus-tmp-news-server (or (cadr gnus-tmp-method) ""))
 	 (gnus-tmp-news-method (or (car gnus-tmp-method) ""))
 	 (gnus-tmp-news-method-string
 	  (if gnus-tmp-method
 	      (format "(%s:%s)" (car gnus-tmp-method)
 				   (string-to-int gnus-tmp-number-of-unread)
 				 t)
 		  gnus-marked ,gnus-tmp-marked-mark
 		  gnus-indentation ,gnus-group-indentation
 		  gnus-level ,gnus-tmp-level))
+(forward-line -1)
 (when (inline (gnus-visual-p 'group-highlight 'highlight))
-(forward-line -1)
+(gnus-run-hooks 'gnus-group-update-hook))
-(gnus-run-hooks 'gnus-group-update-hook)
+(forward-line)
-(forward-line))
 ;; Allow XEmacs to remove front-sticky text properties.
 (gnus-group-remove-excess-properties)))
 (defun gnus-group-highlight-line ()
 "Highlight the current line according to `gnus-group-highlight'."
 ;;; Gnus group mode commands
 ;; Group marking.
+(defun gnus-group-mark-line-p ()
+(save-excursion
+(beginning-of-line)
+(forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2))
+(eq (char-after) gnus-process-mark)))
 (defun gnus-group-mark-group (n &optional unmark no-advance)
 "Mark the current group."
 (interactive "p")
 (let ((buffer-read-only nil)
 	group)
 (when (setq group (gnus-group-group-name))
 	;; Go to the mark position.
 	(beginning-of-line)
 	(forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2))
 	(subst-char-in-region
-	 (point) (1+ (point)) (following-char)
+	 (point) (1+ (point)) (char-after)
 	 (if unmark
 	     (progn
 	       (setq gnus-group-marked (delete group gnus-group-marked))
 	       ? )
 	   (setq gnus-group-marked
 (while alist
 (when (string-match regexp (setq group (gnus-info-group (pop alist))))
 	(gnus-group-set-mark group))))
 (gnus-group-position-point))
-(defun gnus-group-remove-mark (group)
+(defun gnus-group-remove-mark (group &optional test-marked)
 "Remove the process mark from GROUP and move point there.
 Return nil if the group isn't displayed."
-(if (gnus-group-goto-group group)
+(if (gnus-group-goto-group group nil test-marked)
 (save-excursion
 	(gnus-group-mark-group 1 'unmark t)
 	t)
 (setq gnus-group-marked
 	  (delete group gnus-group-marked))
 	(groups (make-symbol "gnus-group-iterate-groups"))
 	(group (make-symbol "gnus-group-iterate-group")))
 (eval
 `(defun gnus-group-iterate (arg ,function)
 	"Iterate FUNCTION over all process/prefixed groups.
-FUNCTION will be called with the group name as the paremeter
+FUNCTION will be called with the group name as the parameter
 and with point over the group in question."
 	(let ((,groups (gnus-group-process-prefix arg))
 	      (,window (selected-window))
 	      ,group)
-	  (while (setq ,group (pop ,groups))
+	  (while ,groups
+	    (setq ,group (car ,groups)
+		  ,groups (cdr ,groups))
 	    (select-window ,window)
 	    (gnus-group-remove-mark ,group)
 	    (save-selected-window
 	      (save-excursion
 		(funcall ,function ,group)))))))))
 ;;;###autoload
 (defun gnus-fetch-group (group)
 "Start Gnus if necessary and enter GROUP.
 Returns whether the fetching was successful or not."
-(interactive "sGroup name: ")
+(interactive (list (completing-read "Group name: " gnus-active-hashtb)))
 (unless (get-buffer gnus-group-buffer)
 (gnus-no-server))
 (gnus-group-read-group nil nil group))
 ;;;###autoload
 If QUIT-CONFIG, use that window configuration when exiting from the
 ephemeral group.
 If REQUEST-ONLY, don't actually read the group; just request it.
 If SELECT-ARTICLES, only select those articles.
-Return the name of the group is selection was successful."
+Return the name of the group if selection was successful."
 ;; Transform the select method into a unique server.
 (when (stringp method)
 (setq method (gnus-server-to-method method)))
 (setq method
 	`(,(car method) ,(concat (cadr method) "-ephemeral")
 (gnus-group-update-group group)
 (gnus-group-goto-group group)))
 ;; Adjust cursor point.
 (gnus-group-position-point))
-(defun gnus-group-goto-group (group &optional far)
+(defun gnus-group-goto-group (group &optional far test-marked)
 "Goto to newsgroup GROUP.
-If FAR, it is likely that the group is not on the current line."
+If FAR, it is likely that the group is not on the current line.
+If TEST-MARKED, the line must be marked."
 (when group
-(if far
+(beginning-of-line)
-	(gnus-goto-char
+(cond
-	 (text-property-any
+;; It's quite likely that we are on the right line, so
-	  (point-min) (point-max)
+;; we check the current line first.
-	  'gnus-group (gnus-intern-safe group gnus-active-hashtb)))
+((and (not far)
-(beginning-of-line)
+	   (eq (get-text-property (point) 'gnus-group)
-(cond
+	       (gnus-intern-safe group gnus-active-hashtb))
-;; It's quite likely that we are on the right line, so
+	   (or (not test-marked) (gnus-group-mark-line-p)))
-;; we check the current line first.
+(point))
-((eq (get-text-property (point) 'gnus-group)
+;; Previous and next line are also likely, so we check them as well.
-	    (gnus-intern-safe group gnus-active-hashtb))
+((and (not far)
-	(point))
+	   (save-excursion
-;; Previous and next line are also likely, so we check them as well.
+	     (forward-line -1)
-((save-excursion
+	     (and (eq (get-text-property (point) 'gnus-group)
-	  (forward-line -1)
+		      (gnus-intern-safe group gnus-active-hashtb))
-	  (eq (get-text-property (point) 'gnus-group)
+		  (or (not test-marked) (gnus-group-mark-line-p)))))
-	      (gnus-intern-safe group gnus-active-hashtb)))
+(forward-line -1)
-	(forward-line -1)
+(point))
-	(point))
+((and (not far)
-((save-excursion
+	   (save-excursion
-	  (forward-line 1)
+	     (forward-line 1)
-	  (eq (get-text-property (point) 'gnus-group)
+	     (and (eq (get-text-property (point) 'gnus-group)
-	      (gnus-intern-safe group gnus-active-hashtb)))
+		      (gnus-intern-safe group gnus-active-hashtb))
-	(forward-line 1)
+		  (or (not test-marked) (gnus-group-mark-line-p)))))
-	(point))
+(forward-line 1)
-(t
+(point))
-	;; Search through the entire buffer.
+(test-marked
-	(gnus-goto-char
+(goto-char (point-min))
-	 (text-property-any
+(let (found)
-	  (point-min) (point-max)
+	(while (and (not found)
-	  'gnus-group (gnus-intern-safe group gnus-active-hashtb))))))))
+		    (gnus-goto-char
+		     (text-property-any
+		      (point) (point-max)
+		      'gnus-group
+		      (gnus-intern-safe group gnus-active-hashtb))))
+	  (if (gnus-group-mark-line-p)
+	      (setq found t)
+	    (forward-line 1)))
+	found))
+(t
+;; Search through the entire buffer.
+(gnus-goto-char
+(text-property-any
+	(point-min) (point-max)
+	'gnus-group (gnus-intern-safe group gnus-active-hashtb)))))))
 (defun gnus-group-next-group (n &optional silent)
 "Go to next N'th newsgroup.
 If N is negative, search backward instead.
 Returns the difference between N and the number of skips actually
 (list
 (gnus-read-group "Group name: ")
 (gnus-read-method "From method: ")))
 (when (stringp method)
-(setq method (gnus-server-to-method method)))
+(setq method (or (gnus-server-to-method method) method)))
-(let* ((meth (when (and method
+(let* ((meth (gnus-method-simplify
-			  (not (gnus-server-equal method gnus-select-method)))
+		(when (and method
-		 (if address (list (intern method) address)
+			   (not (gnus-server-equal method gnus-select-method)))
-		   method)))
+		  (if address (list (intern method) address)
+		    method))))
 	 (nname (if method (gnus-group-prefixed-name name meth) name))
 	 backend info)
 (when (gnus-gethash nname gnus-newsrc-hashtb)
 (error "Group %s already exists" nname))
 ;; Subscribe to the new group.
 (gnus-check-server meth)
 (when (gnus-check-backend-function 'request-create-group nname)
 (gnus-request-create-group nname nil args))
 t))
-(defun gnus-group-delete-group (group &optional force)
+(defun gnus-group-delete-groups (&optional arg)
-"Delete the current group.  Only meaningful with mail groups.
+"Delete the current group.  Only meaningful with editable groups."
+(interactive "P")
+(let ((n (length (gnus-group-process-prefix arg))))
+(when (gnus-yes-or-no-p
+	   (if (= n 1)
+	       "Delete this 1 group? "
+	     (format "Delete these %d groups? " n)))
+(gnus-group-iterate arg
+	(lambda (group)
+	  (gnus-group-delete-group group nil t))))))
+(defun gnus-group-delete-group (group &optional force no-prompt)
+"Delete the current group.  Only meaningful with editable groups.
 If FORCE (the prefix) is non-nil, all the articles in the group will
 be deleted.  This is \"deleted\" as in \"removed forever from the face
 of the Earth\".	 There is no undo.  The user will be prompted before
 doing the deletion."
 (interactive
 (unless group
 (error "No group to rename"))
 (unless (gnus-check-backend-function 'request-delete-group group)
 (error "This backend does not support group deletion"))
 (prog1
-(if (not (gnus-yes-or-no-p
+(if (and (not no-prompt)
-		(format
+	       (not (gnus-yes-or-no-p
-		 "Do you really want to delete %s%s? "
+		     (format
-		 group (if force " and all its contents" ""))))
+		      "Do you really want to delete %s%s? "
+		      group (if force " and all its contents" "")))))
 	  ()				; Whew!
 	(gnus-message 6 "Deleting group %s..." group)
 	(if (not (gnus-request-delete-group group force))
 	    (gnus-error 3 "Couldn't delete group %s" group)
 	  (gnus-message 6 "Deleting group %s...done" group)
 "Editing the %s for `%s'."
 (cond
 ((eq part 'method) "select method")
 ((eq part 'params) "group parameters")
 (t "group info"))
-group)
+(gnus-group-decoded-name group))
 `(lambda (form)
 	(gnus-group-edit-group-done ',part ,group form)))))
 (defun gnus-group-edit-group-method (group)
 "Edit the select method of GROUP."
 	(setq found (cond ((= (setq char (read-char)) ?m) 'mbox)
 			  ((= char ?b) 'babyl)
 			  ((= char ?d) 'digest)
 			  ((= char ?f) 'forward)
 			  ((= char ?a) 'mmfd)
+			  ((= char ?g) 'guess)
 			  (t (setq err (format "%c unknown. " char))
 			     nil))))
 (setq type found)))
 (let* ((file (expand-file-name file))
 	 (name (gnus-generate-new-group-name
 (gnus-group-read-ephemeral-group
 group method t
 (cons (current-buffer)
 	     (if (eq major-mode 'gnus-summary-mode) 'summary 'group))))))
+(defvar nnwarchive-type-definition)
+(defvar gnus-group-warchive-type-history nil)
+(defvar gnus-group-warchive-login-history nil)
+(defvar gnus-group-warchive-address-history nil)
+(defun gnus-group-make-warchive-group ()
+"Create a nnwarchive group."
+(interactive)
+(require 'nnwarchive)
+(let* ((group (gnus-read-group "Group name: "))
+	 (default-type (or (car gnus-group-warchive-type-history)
+			   (symbol-name (caar nnwarchive-type-definition))))
+	 (type
+	  (gnus-string-or
+	   (completing-read
+	    (format "Warchive type (default %s): " default-type)
+	    (mapcar (lambda (elem) (list (symbol-name (car elem))))
+		    nnwarchive-type-definition)
+	    nil t nil 'gnus-group-warchive-type-history)
+	   default-type))
+	 (address (read-string "Warchive address: "
+			       nil 'gnus-group-warchive-address-history))
+	 (default-login (or (car gnus-group-warchive-login-history)
+			    user-mail-address))
+	 (login
+	  (gnus-string-or
+	   (read-string
+	    (format "Warchive login (default %s): " user-mail-address)
+	    default-login 'gnus-group-warchive-login-history)
+	   user-mail-address))
+	 (method
+	  `(nnwarchive ,address
+		       (nnwarchive-type ,(intern type))
+		       (nnwarchive-login ,login))))
+(gnus-group-make-group group method)))
 (defun gnus-group-make-archive-group (&optional all)
 "Create the (ding) Gnus archive group of the most recent articles.
 Given a prefix, create a full group."
 (interactive "P")
 (let ((group (gnus-group-prefixed-name
 						    header)))))
 	  (push (list regexp nil nil 'r) regexps))
 	(push (cons header regexps) scores))
 scores)))
 (gnus-group-make-group group "nnkiboze" address)
-(nnheader-temp-write (gnus-score-file-name (concat "nnkiboze:" group))
+(with-temp-file (gnus-score-file-name (concat "nnkiboze:" group))
 (let (emacs-lisp-mode-hook)
 (pp scores (current-buffer)))))
 (defun gnus-group-add-to-virtual (n vgroup)
 "Add the current group to a virtual group."
 	     (cons (current-buffer)
 		   (if (eq major-mode 'gnus-summary-mode)
 		       'summary 'group)))
 (error "Couldn't enter %s" dir))))
+(eval-and-compile
+(autoload 'nnimap-expunge "nnimap")
+(autoload 'nnimap-acl-get "nnimap")
+(autoload 'nnimap-acl-edit "nnimap"))
+(defun gnus-group-nnimap-expunge (group)
+"Expunge deleted articles in current nnimap GROUP."
+(interactive (list (gnus-group-group-name)))
+(let ((mailbox (gnus-group-real-name group)) method)
+(unless group
+(error "No group on current line"))
+(unless (gnus-get-info group)
+(error "Killed group; can't be edited"))
+(unless (eq 'nnimap (car (setq method (gnus-find-method-for-group group))))
+(error "%s is not an nnimap group" group))
+(nnimap-expunge mailbox (cadr method))))
+(defun gnus-group-nnimap-edit-acl (group)
+"Edit the Access Control List of current nnimap GROUP."
+(interactive (list (gnus-group-group-name)))
+(let ((mailbox (gnus-group-real-name group)) method acl)
+(unless group
+(error "No group on current line"))
+(unless (gnus-get-info group)
+(error "Killed group; can't be edited"))
+(unless (eq (car (setq method (gnus-find-method-for-group group))) 'nnimap)
+(error "%s is not an nnimap group" group))
+(gnus-edit-form (setq acl (nnimap-acl-get mailbox (cadr method)))
+		    (format "Editing the access control list for `%s'.
+An access control list is a list of (identifier . rights) elements.
+The identifier string specifies the corresponding user.  The
+identifier \"anyone\" is reserved to refer to the universal identity.
+Rights is a string listing a (possibly empty) set of alphanumeric
+characters, each character listing a set of operations which is being
+controlled.  Letters are reserved for ``standard'' rights, listed
+below.  Digits are reserved for implementation or site defined rights.
+l - lookup (mailbox is visible to LIST/LSUB commands)
+r - read (SELECT the mailbox, perform CHECK, FETCH, PARTIAL,
+SEARCH, COPY from mailbox)
+s - keep seen/unseen information across sessions (STORE \\SEEN flag)
+w - write (STORE flags other than \\SEEN and \\DELETED)
+i - insert (perform APPEND, COPY into mailbox)
+p - post (send mail to submission address for mailbox,
+not enforced by IMAP4 itself)
+c - create and delete mailbox (CREATE new sub-mailboxes in any
+implementation-defined hierarchy, RENAME or DELETE mailbox)
+d - delete messages (STORE \\DELETED flag, perform EXPUNGE)
+a - administer (perform SETACL)" group)
+		    `(lambda (form)
+		       (nnimap-acl-edit
+			,mailbox ',method ',acl form)))))
 ;; Group sorting commands
 ;; Suggested by Joe Hildebrand <hildjj@idaho.fuentez.com>.
 (defun gnus-group-sort-groups (func &optional reverse)
 "Sort the group buffer according to FUNC.
 (when reverse
 (setq infos (nreverse infos)))
 ;; Go through all the infos and replace the old entries
 ;; with the new infos.
 (while infos
-(setcar entries (pop infos))
+(setcar (car entries) (pop infos))
 (pop entries))
 ;; Update the hashtable.
 (gnus-make-hashtable-from-newsrc-alist)))
-(defun gnus-group-sort-selected-groups-by-alphabet (&optional reverse)
+(defun gnus-group-sort-selected-groups-by-alphabet (&optional n reverse)
 "Sort the group buffer alphabetically by group name.
-If REVERSE, sort in reverse order."
+Obeys the process/prefix convention.  If REVERSE (the symbolic prefix),
-(interactive "P")
+sort in reverse order."
-(gnus-group-sort-selected-groups 'gnus-group-sort-by-alphabet reverse))
+(interactive (gnus-interactive "P\ny"))
+(gnus-group-sort-selected-groups n 'gnus-group-sort-by-alphabet reverse))
-(defun gnus-group-sort-selected-groups-by-unread (&optional reverse)
+(defun gnus-group-sort-selected-groups-by-unread (&optional n reverse)
 "Sort the group buffer by number of unread articles.
-If REVERSE, sort in reverse order."
+Obeys the process/prefix convention.  If REVERSE (the symbolic prefix),
-(interactive "P")
+sort in reverse order."
-(gnus-group-sort-selected-groups 'gnus-group-sort-by-unread reverse))
+(interactive (gnus-interactive "P\ny"))
+(gnus-group-sort-selected-groups n 'gnus-group-sort-by-unread reverse))
-(defun gnus-group-sort-selected-groups-by-level (&optional reverse)
+(defun gnus-group-sort-selected-groups-by-level (&optional n reverse)
 "Sort the group buffer by group level.
-If REVERSE, sort in reverse order."
+Obeys the process/prefix convention.  If REVERSE (the symbolic prefix),
-(interactive "P")
+sort in reverse order."
-(gnus-group-sort-selected-groups 'gnus-group-sort-by-level reverse))
+(interactive (gnus-interactive "P\ny"))
+(gnus-group-sort-selected-groups n 'gnus-group-sort-by-level reverse))
-(defun gnus-group-sort-selected-groups-by-score (&optional reverse)
+(defun gnus-group-sort-selected-groups-by-score (&optional n reverse)
 "Sort the group buffer by group score.
-If REVERSE, sort in reverse order."
+Obeys the process/prefix convention.  If REVERSE (the symbolic prefix),
-(interactive "P")
+sort in reverse order."
-(gnus-group-sort-selected-groups 'gnus-group-sort-by-score reverse))
+(interactive (gnus-interactive "P\ny"))
+(gnus-group-sort-selected-groups n 'gnus-group-sort-by-score reverse))
-(defun gnus-group-sort-selected-groups-by-rank (&optional reverse)
+(defun gnus-group-sort-selected-groups-by-rank (&optional n reverse)
 "Sort the group buffer by group rank.
-If REVERSE, sort in reverse order."
+Obeys the process/prefix convention.  If REVERSE (the symbolic prefix),
-(interactive "P")
+sort in reverse order."
-(gnus-group-sort-selected-groups 'gnus-group-sort-by-rank reverse))
+(interactive (gnus-interactive "P\ny"))
+(gnus-group-sort-selected-groups n 'gnus-group-sort-by-rank reverse))
-(defun gnus-group-sort-selected-groups-by-method (&optional reverse)
+(defun gnus-group-sort-selected-groups-by-method (&optional n reverse)
 "Sort the group buffer alphabetically by backend name.
-If REVERSE, sort in reverse order."
+Obeys the process/prefix convention.  If REVERSE (the symbolic prefix),
-(interactive "P")
+sort in reverse order."
-(gnus-group-sort-selected-groups 'gnus-group-sort-by-method reverse))
+(interactive (gnus-interactive "P\ny"))
+(gnus-group-sort-selected-groups n 'gnus-group-sort-by-method reverse))
 ;;; Sorting predicates.
 (defun gnus-group-sort-by-alphabet (info1 info2)
 "Sort alphabetically."
 (gnus-info-set-marks info nil))))
 ;; Group catching up.
 (defun gnus-group-catchup-current (&optional n all)
-"Mark all articles not marked as unread in current newsgroup as read.
+"Mark all unread articles in the current newsgroup as read.
 If prefix argument N is numeric, the next N newsgroups will be
 caught up.  If ALL is non-nil, marked articles will also be marked as
 read.  Cross references (Xref: header) of articles are ignored.
 The number of newsgroups that this function was unable to catch
 up is returned."
 (interactive "P")
 (let ((groups (gnus-group-process-prefix n))
-	(ret 0))
+	(ret 0)
+	group)
 (unless groups (error "No groups selected"))
 (if (not
 	 (or (not gnus-interactive-catchup) ;Without confirmation?
 	     gnus-expert-user
 	     (gnus-y-or-n-p
 		 "Mark all unread articles in %s as read? ")
 	       (if (= (length groups) 1)
 		   (car groups)
 		 (format "these %d groups" (length groups)))))))
 	n
-(while groups
+(while (setq group (pop groups))
+	(gnus-group-remove-mark group)
 	;; Virtual groups have to be given special treatment.
-	(let ((method (gnus-find-method-for-group (car groups))))
+	(let ((method (gnus-find-method-for-group group)))
 	  (when (eq 'nnvirtual (car method))
 	    (nnvirtual-catchup-group
-	     (gnus-group-real-name (car groups)) (nth 1 method) all)))
+	     (gnus-group-real-name group) (nth 1 method) all)))
-	(gnus-group-remove-mark (car groups))
+	(if (>= (gnus-group-level group) gnus-level-zombie)
-	(if (>= (gnus-group-group-level) gnus-level-zombie)
 	    (gnus-message 2 "Dead groups can't be caught up")
 	  (if (prog1
-		  (gnus-group-goto-group (car groups))
+		  (gnus-group-goto-group group)
-		(gnus-group-catchup (car groups) all))
+		(gnus-group-catchup group all))
 	      (gnus-group-update-group-line)
-	    (setq ret (1+ ret))))
+	    (setq ret (1+ ret)))))
-	(setq groups (cdr groups)))
 (gnus-group-next-unread-group 1)
 ret)))
 (defun gnus-group-catchup-current-all (&optional n)
 "Mark all articles in current newsgroup as read.
 If ALL is non-nil, all articles are marked as read.
 The return value is the number of articles that were marked as read,
 or nil if no action could be taken."
 (let* ((entry (gnus-gethash group gnus-newsrc-hashtb))
 	 (num (car entry)))
+;; Remove entries for this group.
+(nnmail-purge-split-history (gnus-group-real-name group))
 ;; Do the updating only if the newsgroup isn't killed.
 (if (not (numberp (car entry)))
 	(gnus-message 1 "Can't catch up %s; non-active group" group)
 ;; Do auto-expirable marks if that's required.
 (when (gnus-group-auto-expirable-p group)
 	group)
 (unless groups
 (error "No groups to expire"))
 (while (setq group (pop groups))
 (gnus-group-remove-mark group)
-(when (gnus-check-backend-function 'request-expire-articles group)
+(gnus-group-expire-articles-1 group)
-	(gnus-message 6 "Expiring articles in %s..." group)
-	(let* ((info (gnus-get-info group))
-	       (expirable (if (gnus-group-total-expirable-p group)
-			      (cons nil (gnus-list-of-read-articles group))
-			    (assq 'expire (gnus-info-marks info))))
-	       (expiry-wait (gnus-group-find-parameter group 'expiry-wait)))
-	  (when expirable
-	    (setcdr
-	     expirable
-	     (gnus-compress-sequence
-	      (if expiry-wait
-		  ;; We set the expiry variables to the group
-		  ;; parameter.
-		  (let ((nnmail-expiry-wait-function nil)
-			(nnmail-expiry-wait expiry-wait))
-		    (gnus-request-expire-articles
-		     (gnus-uncompress-sequence (cdr expirable)) group))
-		;; Just expire using the normal expiry values.
-		(gnus-request-expire-articles
-		 (gnus-uncompress-sequence (cdr expirable)) group))))
-	    (gnus-close-group group))
-	  (gnus-message 6 "Expiring articles in %s...done" group)))
 (gnus-dribble-touch)
 (gnus-group-position-point))))
+(defun gnus-group-expire-articles-1 (group)
+(when (gnus-check-backend-function 'request-expire-articles group)
+(gnus-message 6 "Expiring articles in %s..." group)
+(let* ((info (gnus-get-info group))
+	   (expirable (if (gnus-group-total-expirable-p group)
+			  (cons nil (gnus-list-of-read-articles group))
+			(assq 'expire (gnus-info-marks info))))
+	   (expiry-wait (gnus-group-find-parameter group 'expiry-wait))
+	   (nnmail-expiry-target
+	    (or (gnus-group-find-parameter group 'expiry-target)
+		nnmail-expiry-target)))
+(when expirable
+	(gnus-check-group group)
+	(setcdr
+	 expirable
+	 (gnus-compress-sequence
+	  (if expiry-wait
+	      ;; We set the expiry variables to the group
+	      ;; parameter.
+	      (let ((nnmail-expiry-wait-function nil)
+		    (nnmail-expiry-wait expiry-wait))
+		(gnus-request-expire-articles
+		 (gnus-uncompress-sequence (cdr expirable)) group))
+	    ;; Just expire using the normal expiry values.
+	    (gnus-request-expire-articles
+	     (gnus-uncompress-sequence (cdr expirable)) group))))
+	(gnus-close-group group))
+(gnus-message 6 "Expiring articles in %s...done" group)
+;; Return the list of un-expired articles.
+(cdr expirable))))
 (defun gnus-group-expire-all-groups ()
 "Expire all expirable articles in all newsgroups."
 (interactive)
 (save-excursion
 (if (string-match "^\\s-*$" s)
 	   (int-to-string (or (gnus-group-group-level)
 			      gnus-level-default-subscribed))
 	 s)))))
 (unless (and (>= level 1) (<= level gnus-level-killed))
-(error "Illegal level: %d" level))
+(error "Invalid level: %d" level))
 (let ((groups (gnus-group-process-prefix n))
 	group)
 (while (setq group (pop groups))
 (gnus-group-remove-mark group)
 (gnus-message 6 "Changed level of %s from %d to %d"
 (prog1
 (forward-line (- n))
 (gnus-group-yank-group)
 (gnus-group-position-point)))
-(defun gnus-group-kill-all-zombies ()
+(defun gnus-group-kill-all-zombies (&optional dummy)
-"Kill all zombie newsgroups."
+"Kill all zombie newsgroups.
-(interactive)
+The optional DUMMY should always be nil."
-(setq gnus-killed-list (nconc gnus-zombie-list gnus-killed-list))
+(interactive (list (not (gnus-yes-or-no-p "Really kill all zombies? "))))
-(setq gnus-zombie-list nil)
+(unless dummy
-(gnus-dribble-touch)
+(setq gnus-killed-list (nconc gnus-zombie-list gnus-killed-list))
-(gnus-group-list-groups))
+(setq gnus-zombie-list nil)
+(gnus-dribble-touch)
+(gnus-group-list-groups)))
 (defun gnus-group-kill-region (begin end)
 "Kill newsgroups in current region (excluding current point).
 The killed newsgroups can be yanked by using \\[gnus-group-yank-group]."
 (interactive "r")
 		 (gnus-group-goto-group ,(gnus-group-group-name))
 		 (gnus-group-yank-group)))
 	    (push (cons (car entry) (nth 2 entry))
 		  gnus-list-of-killed-groups))
 	  (gnus-group-change-level
-	   (if entry entry group) gnus-level-killed (if entry nil level)))
+	   (if entry entry group) gnus-level-killed (if entry nil level))
+	  (message "Killed group %s" group))
 ;; If there are lots and lots of groups to be killed, we use
 ;; this thing instead.
 (let (entry)
 	(setq groups (nreverse groups))
 	(while groups
 	  (setq prev alist))
 	(setq alist (cdr alist)))
 (gnus-make-hashtable-from-newsrc-alist)
 (gnus-group-list-groups)))
 (t
-(error "Can't kill; illegal level: %d" level))))
+(error "Can't kill; invalid level: %d" level))))
 (defun gnus-group-list-all-groups (&optional arg)
 "List all newsgroups with level ARG or lower.
 Default is gnus-level-unsubscribed, which lists all subscribed and most
 unsubscribed groups."
 (defun gnus-group-list-active ()
 "List all groups that are available from the server(s)."
 (interactive)
 ;; First we make sure that we have really read the active file.
 (unless (gnus-read-active-file-p)
-(let ((gnus-read-active-file t))
+(let ((gnus-read-active-file t)
+	  (gnus-agent nil))		; Trick the agent into ignoring the active file.
 (gnus-read-active-file)))
 ;; Find all groups and sort them.
 (let ((groups
 	 (sort
 	  (let (list)
 	  'string<))
 	(buffer-read-only nil)
 	group)
 (erase-buffer)
 (while groups
+(setq group (pop groups))
 (gnus-add-text-properties
 (point) (prog1 (1+ (point))
 		 (insert "       *: "
-			 (setq group (pop groups)) "\n"))
+			 (gnus-group-name-decode group
+						 (gnus-group-name-charset
+						  nil group))
+			 "\n"))
 (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb)
 	     'gnus-unread t
 	     'gnus-level (inline (gnus-group-level group)))))
 (goto-char (point-min))))
 "Get newly arrived articles.
 If ARG is a number, it specifies which levels you are interested in
 re-scanning.  If ARG is non-nil and not a number, this will force
 \"hard\" re-reading of the active files from all servers."
 (interactive "P")
-(let ((gnus-inhibit-demon t))
+(require 'nnmail)
+(let ((gnus-inhibit-demon t)
+	;; Binding this variable will inhibit multiple fetchings
+	;; of the same mail source.
+	(nnmail-fetched-sources (list t)))
 (gnus-run-hooks 'gnus-get-new-news-hook)
 ;; Read any slave files.
 (unless gnus-slave
 (gnus-master-read-slave-newsrc))
 (interactive "P")
 (let* ((groups (gnus-group-process-prefix n))
 	 (ret (if (numberp n) (- n (length groups)) 0))
 	 (beg (unless n
 		(point)))
-	 group method)
+	 group method
+	 (gnus-inhibit-demon t)
+	 ;; Binding this variable will inhibit multiple fetchings
+	 ;; of the same mail source.
+	 (nnmail-fetched-sources (list t)))
+(gnus-run-hooks 'gnus-get-new-news-hook)
 (while (setq group (pop groups))
 (gnus-group-remove-mark group)
 ;; Bypass any previous denials from the server.
 (gnus-remove-denial (setq method (gnus-find-method-for-group group)))
 (if (gnus-activate-group group (if dont-scan nil 'scan))
 	  (progn
 	    (gnus-get-unread-articles-in-group
 	     (gnus-get-info group) (gnus-active group) t)
 	    (unless (gnus-virtual-group-p group)
 	      (gnus-close-group group))
-	    (gnus-agent-save-group-info
+	    (when gnus-agent
-	     method (gnus-group-real-name group) (gnus-active group))
+	      (gnus-agent-save-group-info
+	       method (gnus-group-real-name group) (gnus-active group)))
 	    (gnus-group-update-group group))
 	(if (eq (gnus-server-status (gnus-find-method-for-group group))
 		'denied)
 	    (gnus-error 3 "Server denied access")
 	  (gnus-error 3 "%s error: %s" group (gnus-status-message group)))))
 	b)
 (erase-buffer)
 (mapatoms
 (lambda (group)
 (setq b (point))
-(insert (format "      *: %-20s %s\n" (symbol-name group)
+(let ((charset (gnus-group-name-charset nil (symbol-name group))))
-		       (symbol-value group)))
+	 (insert (format "      *: %-20s %s\n"
+			 (gnus-group-name-decode
+			  (symbol-name group) charset)
+			 (gnus-group-name-decode
+			  (symbol-value group) charset))))
 (gnus-add-text-properties
 	b (1+ b) (list 'gnus-group group
 		       'gnus-unread t 'gnus-marked nil
 		       'gnus-level (1+ gnus-level-subscribed))))
 gnus-description-hashtb)
 (if (not groups)
 	(gnus-message 3 "No groups matched \"%s\"." regexp)
 ;; Print out all the groups.
 (save-excursion
 	(pop-to-buffer "*Gnus Help*")
-	(buffer-disable-undo (current-buffer))
+	(buffer-disable-undo)
 	(erase-buffer)
 	(setq groups (sort groups 'string<))
 	(while groups
 	  ;; Groups may be entered twice into the list of groups.
 	  (when (not (string= (car groups) prev))
-	    (insert (setq prev (car groups)) "\n")
+	    (setq prev (car groups))
-	    (when (and gnus-description-hashtb
+	    (let ((charset (gnus-group-name-charset nil prev)))
-		       (setq des (gnus-gethash (car groups)
+	      (insert (gnus-group-name-decode prev charset) "\n")
-					       gnus-description-hashtb)))
+	      (when (and gnus-description-hashtb
-	      (insert "  " des "\n")))
+			 (setq des (gnus-gethash (car groups)
+						 gnus-description-hashtb)))
+		(insert "  " (gnus-group-name-decode des charset) "\n"))))
 	  (setq groups (cdr groups)))
 	(goto-char (point-min))))
 (pop-to-buffer obuf)))
 (defun gnus-group-description-apropos (regexp)
 	     ;; We got a server name.
 	     how))))
 (gnus-browse-foreign-server method))
 (defun gnus-group-set-info (info &optional method-only-group part)
-(let* ((entry (gnus-gethash
+(when (or info part)
-		 (or method-only-group (gnus-info-group info))
+(let* ((entry (gnus-gethash
-		 gnus-newsrc-hashtb))
+		   (or method-only-group (gnus-info-group info))
-	 (part-info info)
+		   gnus-newsrc-hashtb))
-	 (info (if method-only-group (nth 2 entry) info))
+	   (part-info info)
-	 method)
+	   (info (if method-only-group (nth 2 entry) info))
-(when method-only-group
+	   method)
+(when method-only-group
+	(unless entry
+	  (error "Trying to change non-existent group %s" method-only-group))
+	;; We have received parts of the actual group info - either the
+	;; select method or the group parameters.	 We first check
+	;; whether we have to extend the info, and if so, do that.
+	(let ((len (length info))
+	      (total (if (eq part 'method) 5 6)))
+	  (when (< len total)
+	    (setcdr (nthcdr (1- len) info)
+		    (make-list (- total len) nil)))
+	  ;; Then we enter the new info.
+	  (setcar (nthcdr (1- total) info) part-info)))
 (unless entry
-	(error "Trying to change non-existent group %s" method-only-group))
+	;; This is a new group, so we just create it.
-;; We have received parts of the actual group info - either the
-;; select method or the group parameters.	 We first check
-;; whether we have to extend the info, and if so, do that.
-(let ((len (length info))
-	    (total (if (eq part 'method) 5 6)))
-	(when (< len total)
-	  (setcdr (nthcdr (1- len) info)
-		  (make-list (- total len) nil)))
-	;; Then we enter the new info.
-	(setcar (nthcdr (1- total) info) part-info)))
-(unless entry
-;; This is a new group, so we just create it.
-(save-excursion
-	(set-buffer gnus-group-buffer)
-	(setq method (gnus-info-method info))
-	(when (gnus-server-equal method "native")
-	  (setq method nil))
 	(save-excursion
 	  (set-buffer gnus-group-buffer)
-	  (if method
+	  (setq method (gnus-info-method info))
-	      ;; It's a foreign group...
+	  (when (gnus-server-equal method "native")
-	      (gnus-group-make-group
+	    (setq method nil))
-	       (gnus-group-real-name (gnus-info-group info))
+	  (save-excursion
-	       (if (stringp method) method
+	    (set-buffer gnus-group-buffer)
-		 (prin1-to-string (car method)))
+	    (if method
-	       (and (consp method)
+		;; It's a foreign group...
-		    (nth 1 (gnus-info-method info))))
+		(gnus-group-make-group
-	    ;; It's a native group.
+		 (gnus-group-real-name (gnus-info-group info))
-	    (gnus-group-make-group (gnus-info-group info))))
+		 (if (stringp method) method
-	(gnus-message 6 "Note: New group created")
+		   (prin1-to-string (car method)))
-	(setq entry
+		 (and (consp method)
-	      (gnus-gethash (gnus-group-prefixed-name
+		      (nth 1 (gnus-info-method info))))
-			     (gnus-group-real-name (gnus-info-group info))
+	      ;; It's a native group.
-			     (or (gnus-info-method info) gnus-select-method))
+	      (gnus-group-make-group (gnus-info-group info))))
-			    gnus-newsrc-hashtb))))
+	  (gnus-message 6 "Note: New group created")
-;; Whether it was a new group or not, we now have the entry, so we
+	  (setq entry
-;; can do the update.
+		(gnus-gethash (gnus-group-prefixed-name
-(if entry
+			       (gnus-group-real-name (gnus-info-group info))
-	(progn
+			       (or (gnus-info-method info) gnus-select-method))
-	  (setcar (nthcdr 2 entry) info)
+			      gnus-newsrc-hashtb))))
-	  (when (and (not (eq (car entry) t))
+;; Whether it was a new group or not, we now have the entry, so we
-		     (gnus-active (gnus-info-group info)))
+;; can do the update.
-	    (setcar entry (length (gnus-list-of-unread-articles (car info))))))
+(if entry
-(error "No such group: %s" (gnus-info-group info)))))
+	  (progn
+	    (setcar (nthcdr 2 entry) info)
+	    (when (and (not (eq (car entry) t))
+		       (gnus-active (gnus-info-group info)))
+	      (setcar entry (length (gnus-list-of-unread-articles (car info))))))
+	(error "No such group: %s" (gnus-info-group info))))))
 (defun gnus-group-set-method-info (group select-method)
 (gnus-group-set-info select-method group 'method))
 (defun gnus-group-set-params-info (group params)
 (gnus-group-set-info params group 'params))
 (defun gnus-add-marked-articles (group type articles &optional info force)
 ;; Add ARTICLES of TYPE to the info of GROUP.
-;; If INFO is non-nil, use that info.	 If FORCE is non-nil, don't
+;; If INFO is non-nil, use that info.  If FORCE is non-nil, don't
 ;; add, but replace marked articles of TYPE with ARTICLES.
 (let ((info (or info (gnus-get-info group)))
 	marked m)
 (or (not info)
 	(and (not (setq marked (nthcdr 3 info)))
 (gnus-group-get-parameter group 'timestamp t))
 (defun gnus-group-timestamp-delta (group)
 "Return the offset in seconds from the timestamp for GROUP to the current time, as a floating point number."
 (let* ((time (or (gnus-group-timestamp group)
-		  (list 0 0)))
+		   (list 0 0)))
-(delta (gnus-time-minus (current-time) time)))
+(delta (subtract-time (current-time) time)))
 (+ (* (nth 0 delta) 65536.0)
 (nth 1 delta))))
 (defun gnus-group-timestamp-string (group)
 "Return a string of the timestamp for GROUP."
 (let ((time (gnus-group-timestamp group)))
 (if (not time)
 	""
 (gnus-time-iso8601 time))))
+(defun gnus-group-prepare-flat-list-dead-predicate
+(groups level mark predicate)
+(let (group)
+(if predicate
+	;; This loop is used when listing groups that match some
+	;; regexp.
+	(while (setq group (pop groups))
+	  (when (funcall predicate group)
+	    (gnus-add-text-properties
+	     (point) (prog1 (1+ (point))
+		       (insert " " mark "     *: "
+			       (gnus-group-name-decode group
+						       (gnus-group-name-charset
+							nil group))
+			       "\n"))
+	     (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb)
+		   'gnus-unread t
+		   'gnus-level level)))))))
+(defun gnus-group-prepare-flat-predicate (level predicate &optional lowest
+						dead-predicate)
+"List all newsgroups with unread articles of level LEVEL or lower.
+If LOWEST is non-nil, list all newsgroups of level LOWEST or higher.
+If PREDICATE, only list groups which PREDICATE returns non-nil.
+If DEAD-PREDICATE, list dead groups which DEAD-PREDICATE returns non-nil."
+(set-buffer gnus-group-buffer)
+(let ((buffer-read-only nil)
+	(newsrc (cdr gnus-newsrc-alist))
+	(lowest (or lowest 1))
+	info clevel unread group params)
+(erase-buffer)
+;; List living groups.
+(while newsrc
+(setq info (car newsrc)
+	    group (gnus-info-group info)
+	    params (gnus-info-params info)
+	    newsrc (cdr newsrc)
+	    unread (car (gnus-gethash group gnus-newsrc-hashtb)))
+(and unread			; This group might be unchecked
+	   (funcall predicate info)
+	   (<= (setq clevel (gnus-info-level info)) level)
+	   (>= clevel lowest)
+	   (gnus-group-insert-group-line
+	    group (gnus-info-level info)
+	    (gnus-info-marks info) unread (gnus-info-method info))))
+;; List dead groups.
+(and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie)
+	 (gnus-group-prepare-flat-list-dead-predicate
+	  (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
+	  gnus-level-zombie ?Z
+	  dead-predicate))
+(and (>= level gnus-level-killed) (<= lowest gnus-level-killed)
+	 (gnus-group-prepare-flat-list-dead-predicate
+	  (setq gnus-killed-list (sort gnus-killed-list 'string<))
+	  gnus-level-killed ?K dead-predicate))
+(gnus-group-set-mode-line)
+(setq gnus-group-list-mode (cons level t))
+(gnus-run-hooks 'gnus-group-prepare-hook)
+t))
+(defun gnus-group-list-cached (level &optional lowest)
+"List all groups with cached articles.
+If the prefix LEVEL is non-nil, it should be a number that says which
+level to cut off listing groups.
+If LOWEST, don't list groups with level lower than LOWEST.
+This command may read the active file."
+(interactive "P")
+(when level
+(setq level (prefix-numeric-value level)))
+(when (or (not level) (>= level gnus-level-zombie))
+(gnus-cache-open))
+(gnus-group-prepare-flat-predicate (or level gnus-level-subscribed)
+				#'(lambda (info)
+				    (let ((marks (gnus-info-marks info)))
+				      (assq 'cache marks)))
+				lowest
+				#'(lambda (group)
+				    (or (gnus-gethash group
+						      gnus-cache-active-hashtb)
+					;; Cache active file might use "."
+					;; instead of ":".
+					(gnus-gethash
+					 (mapconcat 'identity
+						    (split-string group ":")
+						    ".")
+					 gnus-cache-active-hashtb))))
+(goto-char (point-min))
+(gnus-group-position-point))
+(defun gnus-group-list-dormant (level &optional lowest)
+"List all groups with dormant articles.
+If the prefix LEVEL is non-nil, it should be a number that says which
+level to cut off listing groups.
+If LOWEST, don't list groups with level lower than LOWEST.
+This command may read the active file."
+(interactive "P")
+(when level
+(setq level (prefix-numeric-value level)))
+(when (or (not level) (>= level gnus-level-zombie))
+(gnus-cache-open))
+(gnus-group-prepare-flat-predicate (or level gnus-level-subscribed)
+				#'(lambda (info)
+				    (let ((marks (gnus-info-marks info)))
+				      (assq 'dormant marks)))
+				lowest)
+(goto-char (point-min))
+(gnus-group-position-point))
 (provide 'gnus-group)
 ;;; gnus-group.el ends here

Mercurial > emacs

comparison lisp/gnus/gnus-group.el @ 31716:9968f55ad26e