;;; gnus-group.el --- group mode commands for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
(require 'gnus-win)
(require 'gnus-undo)
(require 'time-date)
+(require 'gnus-ems)
(defcustom gnus-group-archive-directory
"*ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/"
for the groups to be sorted. Pre-made functions include
`gnus-group-sort-by-alphabet', `gnus-group-sort-by-real-name',
`gnus-group-sort-by-unread', `gnus-group-sort-by-level',
-`gnus-group-sort-by-score', `gnus-group-sort-by-method', and
-`gnus-group-sort-by-rank'.
+`gnus-group-sort-by-score', `gnus-group-sort-by-method',
+`gnus-group-sort-by-server', and `gnus-group-sort-by-rank'.
This variable can also be a list of sorting functions. In that case,
the most significant sort function should be the last function in the
(function-item gnus-group-sort-by-level)
(function-item gnus-group-sort-by-score)
(function-item gnus-group-sort-by-method)
+ (function-item gnus-group-sort-by-server)
(function-item gnus-group-sort-by-rank)
(function :tag "other" nil)))
:options '(gnus-topic-mode)
:type 'hook)
+;; Extracted from gnus-xmas-redefine in order to preserve user settings
+(when (featurep 'xemacs)
+ (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add)
+ (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar))
+
(defcustom gnus-group-menu-hook nil
"Hook run after the creation of the group mode menu."
:group 'gnus-group-various
:type '(choice (string :tag "Prompt string")
(const :tag "Empty" nil)))
+(defvar gnus-group-listing-limit 1000
+ "*A limit of the number of groups when listing.
+If the number of groups is larger than the limit, list them in a
+simple manner.")
+
;;; Internal variables
(defvar gnus-group-sort-alist-function 'gnus-group-sort-flat
["Send a mail" gnus-group-mail t]
["Post an article..." gnus-group-post-news t]
["Check for new news" gnus-group-get-new-news
- ,@(if (featurep 'xemacs) nil
+ ,@(if (featurep 'xemacs) '(t)
'(:help "Get newly arrived articles"))
]
["Activate all groups" gnus-activate-all-groups t]
["Toggle topics" gnus-topic-mode t]
["Send a bug report" gnus-bug t]
["Exit from Gnus" gnus-group-exit
- ,@(if (featurep 'xemacs) nil
+ ,@(if (featurep 'xemacs) '(t)
'(:help "Quit reading news"))]
["Exit without saving" gnus-group-quit t]))
(default-value 'tool-bar-mode)
(not gnus-group-toolbar-map))
(setq gnus-group-toolbar-map
- (let ((tool-bar-map (make-sparse-keymap)))
+ (let ((tool-bar-map (make-sparse-keymap))
+ (load-path (mm-image-load-path)))
(tool-bar-add-item-from-menu
'gnus-group-get-new-news "get-news" gnus-group-mode-map)
(tool-bar-add-item-from-menu
(let ((item (assoc method gnus-group-name-charset-method-alist))
(alist gnus-group-name-charset-group-alist)
result)
- (if item
+ (if item
(cdr item)
(while (setq item (pop alist))
(if (string-match (car item) group)
(or (and gnus-group-listed-groups
(null gnus-group-list-option)
(member group gnus-group-listed-groups))
- (cond
+ (cond
((null gnus-group-listed-groups) test)
((null gnus-group-list-option) test)
(t (and (member group gnus-group-listed-groups)
params (gnus-info-params info)
newsrc (cdr newsrc)
unread (car (gnus-gethash group gnus-newsrc-hashtb)))
- (if not-in-list
+ (if not-in-list
(setq not-in-list (delete group not-in-list)))
- (and
- (gnus-group-prepare-logic
+ (and
+ (gnus-group-prepare-logic
group
(and unread ; This group might be unchecked
(or (not (stringp regexp))
(t
(or
(if (eq unread t) ; Unactivated?
- gnus-group-list-inactive-groups
+ gnus-group-list-inactive-groups
; We list unactivated
- (> unread 0))
+ (> unread 0))
; We list groups with unread articles
(and gnus-list-groups-with-ticked-articles
(cdr (assq 'tick (gnus-info-marks info))))
(gnus-group-insert-group-line
group (gnus-info-level info)
(gnus-info-marks info) unread (gnus-info-method info)))))
-
+
;; List dead groups.
(if (or gnus-group-listed-groups
- (and (>= level gnus-level-zombie)
+ (and (>= level gnus-level-zombie)
(<= lowest gnus-level-zombie)))
(gnus-group-prepare-flat-list-dead
(setq gnus-zombie-list (sort gnus-zombie-list 'string<))
gnus-level-zombie ?Z
regexp))
- (if not-in-list
+ (if not-in-list
(dolist (group gnus-zombie-list)
(setq not-in-list (delete group not-in-list))))
(if (or gnus-group-listed-groups
(and (>= level gnus-level-killed) (<= lowest gnus-level-killed)))
(gnus-group-prepare-flat-list-dead
- (gnus-union
+ (gnus-union
not-in-list
(setq gnus-killed-list (sort gnus-killed-list 'string<)))
gnus-level-killed ?K regexp))
;; suggested by Jack Vinson <vinson@unagi.cis.upenn.edu>. It does
;; this by ignoring the group format specification altogether.
(let (group)
- (while groups
- (setq group (pop groups))
- (when (gnus-group-prepare-logic
- group
- (or (not regexp)
- (and (stringp regexp) (string-match regexp group))
- (and (functionp regexp) (funcall regexp 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))
- (gnus-group-insert-group-line
- group level nil
- (let ((active (gnus-active group)))
- (if active
- (if (zerop (cdr active))
- 0
- (- (1+ (cdr active)) (car active)))
- nil))
- (gnus-method-simplify (gnus-find-method-for-group group)))))))
+ (if (> (length groups) gnus-group-listing-limit)
+ (while groups
+ (setq group (pop groups))
+ (when (gnus-group-prepare-logic
+ group
+ (or (not regexp)
+ (and (stringp regexp) (string-match regexp group))
+ (and (functionp regexp) (funcall regexp 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))))
+ (while groups
+ (setq group (pop groups))
+ (when (gnus-group-prepare-logic
+ group
+ (or (not regexp)
+ (and (stringp regexp) (string-match regexp group))
+ (and (functionp regexp) (funcall regexp group))))
+ (gnus-group-insert-group-line
+ group level nil
+ (let ((active (gnus-active group)))
+ (if active
+ (if (zerop (cdr active))
+ 0
+ (- (1+ (cdr active)) (car active)))
+ nil))
+ (gnus-method-simplify (gnus-find-method-for-group group))))))))
(defun gnus-group-update-group-line ()
"Update the current line in the group buffer."
gnus-tmp-method)
"Insert a group line in the group buffer."
(let* ((gnus-tmp-method
- (gnus-server-get-method gnus-tmp-group 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-level gnus-level-unsubscribed) ?U)
((= gnus-tmp-level gnus-level-zombie) ?Z)
(t ?K)))
- (gnus-tmp-qualified-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-group-name-decode
- (gnus-gethash gnus-tmp-group gnus-description-hashtb)
+ (gnus-gethash gnus-tmp-group gnus-description-hashtb)
group-name-charset) "")
""))
(gnus-tmp-moderated
(test-marked
(goto-char (point-min))
(let (found)
- (while (and (not found)
+ (while (and (not found)
(gnus-goto-char
(text-property-any
(point) (point-max)
- 'gnus-group
+ 'gnus-group
(gnus-intern-safe group gnus-active-hashtb))))
(if (gnus-group-mark-line-p)
(setq found t)
default-login 'gnus-group-warchive-login-history)
user-mail-address))
(method
- `(nnwarchive ,address
+ `(nnwarchive ,address
(nnwarchive-type ,(intern type))
(nnwarchive-login ,login))))
(gnus-group-make-group group method)))
(interactive "P")
(gnus-group-sort-groups 'gnus-group-sort-by-method reverse))
+(defun gnus-group-sort-groups-by-server (&optional reverse)
+ "Sort the group buffer alphabetically by server name.
+If REVERSE, sort in reverse order."
+ (interactive "P")
+ (gnus-group-sort-groups 'gnus-group-sort-by-server reverse))
+
;;; Selected group sorting.
(defun gnus-group-sort-selected-groups (n func &optional reverse)
(symbol-name (car (gnus-find-method-for-group
(gnus-info-group info2) info2)))))
+(defun gnus-group-sort-by-server (info1 info2)
+ "Sort alphabetically by server name."
+ (string< (gnus-method-to-server-name
+ (gnus-find-method-for-group
+ (gnus-info-group info1) info1))
+ (gnus-method-to-server-name
+ (gnus-find-method-for-group
+ (gnus-info-group info2) info2))))
+
(defun gnus-group-sort-by-score (info1 info2)
"Sort by group score."
- (< (gnus-info-score info1) (gnus-info-score info2)))
+ (> (gnus-info-score info1) (gnus-info-score info2)))
(defun gnus-group-sort-by-rank (info1 info2)
"Sort by level and score."
(gnus-add-text-properties
(point) (prog1 (1+ (point))
(insert " *: "
- (gnus-group-name-decode group
+ (gnus-group-name-decode group
(gnus-group-name-charset
nil group))
"\n"))
(lambda (group)
(setq b (point))
(let ((charset (gnus-group-name-charset nil (symbol-name group))))
- (insert (format " *: %-20s %s\n"
+ (insert (format " *: %-20s %s\n"
(gnus-group-name-decode
(symbol-name group) charset)
(gnus-group-name-decode
(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))))))
+ (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)
(sort (nconc (gnus-uncompress-range (cdr m))
(copy-sequence articles)) '<) t))))))
+(defun gnus-add-mark (group mark article)
+ "Mark ARTICLE in GROUP with MARK, whether the group is displayed or not."
+ (let ((buffer (gnus-summary-buffer-name group)))
+ (if (gnus-buffer-live-p buffer)
+ (save-excursion
+ (set-buffer (get-buffer buffer))
+ (gnus-summary-add-mark article mark))
+ (gnus-add-marked-articles group (cdr (assq mark gnus-article-mark-lists))
+ (list article)))))
+
;;;
;;; Group timestamps
;;;
(setq level (prefix-numeric-value level)))
(when (or (not level) (>= level gnus-level-zombie))
(gnus-cache-open))
- (funcall gnus-group-prepare-function
+ (funcall gnus-group-prepare-function
(or level gnus-level-subscribed)
#'(lambda (info)
(let ((marks (gnus-info-marks info)))
(assq 'cache marks)))
lowest
#'(lambda (group)
- (or (gnus-gethash group
+ (or (gnus-gethash group
gnus-cache-active-hashtb)
- ;; Cache active file might use "."
+ ;; Cache active file might use "."
;; instead of ":".
- (gnus-gethash
+ (gnus-gethash
(mapconcat 'identity
(split-string group ":")
".")
(setq level (prefix-numeric-value level)))
(when (or (not level) (>= level gnus-level-zombie))
(gnus-cache-open))
- (funcall gnus-group-prepare-function
+ (funcall gnus-group-prepare-function
(or level gnus-level-subscribed)
#'(lambda (info)
(let ((marks (gnus-info-marks info)))
"Return a list of listed groups."
(let (point groups)
(goto-char (point-min))
- (while (setq point (text-property-not-all (point) (point-max)
+ (while (setq point (text-property-not-all (point) (point-max)
'gnus-group nil))
(goto-char point)
(push (symbol-name (get-text-property point 'gnus-group)) groups)
projects / gnus / blobdiff