;;; gnus-group.el --- group mode commands for Gnus
-;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002
+;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
(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
list."
:group 'gnus-group-listing
:link '(custom-manual "(gnus)Sorting Groups")
- :type '(radio (function-item gnus-group-sort-by-alphabet)
- (function-item gnus-group-sort-by-real-name)
- (function-item gnus-group-sort-by-unread)
- (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-rank)
- (function :tag "other" nil)))
-
-(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y: %(%g%)%l\n"
+ :type '(repeat :value-to-internal (lambda (widget value)
+ (if (listp value) value (list value)))
+ :match (lambda (widget value)
+ (or (symbolp value)
+ (widget-editable-list-match widget value)))
+ (choice (function-item gnus-group-sort-by-alphabet)
+ (function-item gnus-group-sort-by-real-name)
+ (function-item gnus-group-sort-by-unread)
+ (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))))
+
+(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y: %(%g%)%l %O\n"
"*Format of group lines.
It works along the same lines as a normal formatting string,
with some simple extensions.
%y Number of unread, unticked articles (integer)
%G Group name (string)
%g Qualified group name (string)
+%c Short (collapsed) group name. See `gnus-group-uncollapsed-levels'.
%D Group description (string)
%s Select method (string)
%o Moderated group (char, \"m\")
%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
will be inserted into the buffer just like information from any other
group specifier.
-Text between %( and %) will be highlighted with `gnus-mouse-face' when
-the mouse point move inside the area. There can only be one such area.
-
Note that this format specification is not always respected. For
reasons of efficiency, when listing killed groups, this specification
is ignored altogether. If the spec is changed considerably, your
a bit of extra memory will be used. %D will also worsen performance.
Also note that if you change the format specification to include any
of these specs, you must probably re-start Gnus to see them go into
-effect."
+effect.
+
+General format specifiers can also be used.
+See (gnus)Formatting Variables."
+ :link '(custom-manual "(gnus)Formatting Variables")
:group 'gnus-group-visual
:type 'string)
:group 'gnus-group-visual
:type 'string)
-(defcustom gnus-group-mode-hook nil
- "Hook for Gnus group mode."
- :group 'gnus-group-various
- :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."
(sexp :tag "Method"))))
(defcustom gnus-group-highlight
- '(;; News.
- ((and (= unread 0) (not mailp) (eq level 1)) .
+ '(;; Mail.
+ ((and mailp (= unread 0) (eq level 1)) .
+ gnus-group-mail-1-empty-face)
+ ((and mailp (eq level 1)) .
+ gnus-group-mail-1-face)
+ ((and mailp (= unread 0) (eq level 2)) .
+ gnus-group-mail-2-empty-face)
+ ((and mailp (eq level 2)) .
+ gnus-group-mail-2-face)
+ ((and mailp (= unread 0) (eq level 3)) .
+ gnus-group-mail-3-empty-face)
+ ((and mailp (eq level 3)) .
+ gnus-group-mail-3-face)
+ ((and mailp (= unread 0)) .
+ gnus-group-mail-low-empty-face)
+ ((and mailp) .
+ gnus-group-mail-low-face)
+ ;; News.
+ ((and (= unread 0) (eq level 1)) .
gnus-group-news-1-empty-face)
- ((and (not mailp) (eq level 1)) .
+ ((and (eq level 1)) .
gnus-group-news-1-face)
- ((and (= unread 0) (not mailp) (eq level 2)) .
+ ((and (= unread 0) (eq level 2)) .
gnus-group-news-2-empty-face)
- ((and (not mailp) (eq level 2)) .
+ ((and (eq level 2)) .
gnus-group-news-2-face)
- ((and (= unread 0) (not mailp) (eq level 3)) .
+ ((and (= unread 0) (eq level 3)) .
gnus-group-news-3-empty-face)
- ((and (not mailp) (eq level 3)) .
+ ((and (eq level 3)) .
gnus-group-news-3-face)
- ((and (= unread 0) (not mailp) (eq level 4)) .
+ ((and (= unread 0) (eq level 4)) .
gnus-group-news-4-empty-face)
- ((and (not mailp) (eq level 4)) .
+ ((and (eq level 4)) .
gnus-group-news-4-face)
- ((and (= unread 0) (not mailp) (eq level 5)) .
+ ((and (= unread 0) (eq level 5)) .
gnus-group-news-5-empty-face)
- ((and (not mailp) (eq level 5)) .
+ ((and (eq level 5)) .
gnus-group-news-5-face)
- ((and (= unread 0) (not mailp) (eq level 6)) .
+ ((and (= unread 0) (eq level 6)) .
gnus-group-news-6-empty-face)
- ((and (not mailp) (eq level 6)) .
+ ((and (eq level 6)) .
gnus-group-news-6-face)
- ((and (= unread 0) (not mailp)) .
+ ((and (= unread 0)) .
gnus-group-news-low-empty-face)
- ((and (not mailp)) .
- gnus-group-news-low-face)
- ;; Mail.
- ((and (= unread 0) (eq level 1)) .
- gnus-group-mail-1-empty-face)
- ((eq level 1) .
- gnus-group-mail-1-face)
- ((and (= unread 0) (eq level 2)) .
- gnus-group-mail-2-empty-face)
- ((eq level 2) .
- gnus-group-mail-2-face)
- ((and (= unread 0) (eq level 3)) .
- gnus-group-mail-3-empty-face)
- ((eq level 3) .
- gnus-group-mail-3-face)
- ((= unread 0) .
- gnus-group-mail-low-empty-face)
(t .
- gnus-group-mail-low-face))
+ gnus-group-news-low-face))
"*Controls the highlighting of group buffer lines.
Below is a list of `Form'/`Face' pairs. When deciding how a a
: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))"
+ :version "21.1"
+ :group 'gnus-charset
+ :type '(repeat (cons (sexp :tag "Method") (symbol :tag "Charset"))))
+
+(defcustom gnus-group-name-charset-group-alist
+ (if (or (and (fboundp 'find-coding-system) (find-coding-system 'utf-8))
+ (and (fboundp 'coding-system-p) (coding-system-p 'utf-8)))
+ '((".*" . utf-8))
+ 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"))))
+
+(defcustom gnus-group-jump-to-group-prompt nil
+ "Default prompt for `gnus-group-jump-to-group'.
+If non-nil, the value should be a string, e.g. \"nnml:\",
+in which case `gnus-group-jump-to-group' offers \"Group: nnml:\"
+in the minibuffer prompt."
+ :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
(?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)
(defvar gnus-group-list-mode nil)
+
+(defvar gnus-group-icon-cache nil)
+
+(defvar gnus-group-listed-groups nil)
+(defvar gnus-group-list-option nil)
+
;;;
;;; Gnus group mode
;;;
"=" 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
"l" gnus-group-list-groups
"L" gnus-group-list-all-groups
"m" gnus-group-mail
+ "i" gnus-group-news
"g" gnus-group-get-new-news
"\M-g" gnus-group-get-new-news-this-group
"R" gnus-group-restart
"r" gnus-group-mark-regexp
"U" gnus-group-unmark-all-groups)
+ (gnus-define-keys (gnus-group-sieve-map "D" gnus-group-mode-map)
+ "u" gnus-sieve-update
+ "g" gnus-sieve-generate)
+
(gnus-define-keys (gnus-group-group-map "G" gnus-group-mode-map)
"d" gnus-group-make-directory-group
"h" gnus-group-make-help-group
"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-list-limit-map "/" gnus-group-list-map)
+ "k" gnus-group-list-limit
+ "z" gnus-group-list-limit
+ "s" gnus-group-list-limit
+ "u" gnus-group-list-limit
+ "A" gnus-group-list-limit
+ "m" gnus-group-list-limit
+ "M" gnus-group-list-limit
+ "l" gnus-group-list-limit
+ "c" gnus-group-list-limit
+ "?" gnus-group-list-limit)
+
+ (gnus-define-keys (gnus-group-list-flush-map "f" gnus-group-list-map)
+ "k" gnus-group-list-flush
+ "z" gnus-group-list-flush
+ "s" gnus-group-list-flush
+ "u" gnus-group-list-flush
+ "A" gnus-group-list-flush
+ "m" gnus-group-list-flush
+ "M" gnus-group-list-flush
+ "l" gnus-group-list-flush
+ "c" gnus-group-list-flush
+ "?" gnus-group-list-flush)
+
+ (gnus-define-keys (gnus-group-list-plus-map "p" gnus-group-list-map)
+ "k" gnus-group-list-plus
+ "z" gnus-group-list-plus
+ "s" gnus-group-list-plus
+ "u" gnus-group-list-plus
+ "A" gnus-group-list-plus
+ "m" gnus-group-list-plus
+ "M" gnus-group-list-plus
+ "l" gnus-group-list-plus
+ "c" gnus-group-list-plus
+ "?" gnus-group-list-plus)
(gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map)
"f" gnus-score-flush-cache)
(easy-menu-define
gnus-group-reading-menu gnus-group-mode-map ""
- '("Group"
+ `("Group"
["Read" gnus-group-read-group (gnus-group-group-name)]
["Select" gnus-group-select-group (gnus-group-group-name)]
["See old articles" (gnus-group-select-group 'all)
:keys "C-u SPC" :active (gnus-group-group-name)]
- ["Catch up" gnus-group-catchup-current (gnus-group-group-name)]
+ ["Catch up" gnus-group-catchup-current :active (gnus-group-group-name)
+ ,@(if (featurep 'xemacs) nil
+ '(:help "Mark unread articles in the current group as read"))]
["Catch up all articles" gnus-group-catchup-current-all
(gnus-group-group-name)]
["Check for new articles" gnus-group-get-new-news-this-group
- (gnus-group-group-name)]
+ :active (gnus-group-group-name)
+ ,@(if (featurep 'xemacs) nil
+ '(:help "Check for new messages in current group"))]
["Toggle subscription" gnus-group-unsubscribe-current-group
(gnus-group-group-name)]
- ["Kill" gnus-group-kill-group (gnus-group-group-name)]
+ ["Kill" gnus-group-kill-group :active (gnus-group-group-name)
+ ,@(if (featurep 'xemacs) nil
+ '(:help "Kill (remove) current group"))]
["Yank" gnus-group-yank-group gnus-list-of-killed-groups]
- ["Describe" gnus-group-describe-group (gnus-group-group-name)]
+ ["Describe" gnus-group-describe-group :active (gnus-group-group-name)
+ ,@(if (featurep 'xemacs) nil
+ '(:help "Display description of the current group"))]
["Fetch FAQ" gnus-group-fetch-faq (gnus-group-group-name)]
;; Actually one should check, if any of the marked groups gives t for
;; (gnus-check-backend-function 'request-expire-articles ...)
["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]
["Jump to group" gnus-group-jump-to-group t]
["First unread group" gnus-group-first-unread-group t]
["Best unread group" gnus-group-best-unread-group t])
+ ("Sieve"
+ ["Generate" gnus-sieve-generate t]
+ ["Generate and update" gnus-sieve-update t])
["Delete bogus groups" gnus-group-check-bogus-groups t]
["Find new newsgroups" gnus-group-find-new-groups t]
["Transpose" gnus-group-transpose-groups
(easy-menu-define
gnus-group-misc-menu gnus-group-mode-map ""
- '("Misc"
+ `("Gnus"
("SOUP"
["Pack replies" nnsoup-pack-replies (fboundp 'nnsoup-request-group)]
["Send replies" gnus-soup-send-replies
["Save areas" gnus-soup-save-areas (fboundp 'gnus-soup-pack-packet)]
["Brew SOUP" gnus-group-brew-soup (fboundp 'gnus-soup-pack-packet)])
["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]
+ ["Send a message (mail or news)" gnus-group-post-news t]
+ ["Create a local message" gnus-group-news t]
+ ["Check for new news" gnus-group-get-new-news
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Get newly arrived articles"))
+ ]
+ ["Send queued messages" gnus-delay-send-queue
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Send all messages that are scheduled to be sent now"))
+ ]
["Activate all groups" gnus-activate-all-groups t]
["Restart Gnus" gnus-group-restart t]
["Read init file" gnus-group-read-init-file t]
["Flush score cache" gnus-score-flush-cache t]
["Toggle topics" gnus-topic-mode t]
["Send a bug report" gnus-bug t]
- ["Exit from Gnus" gnus-group-exit t]
+ ["Exit from Gnus" gnus-group-exit
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Quit reading news"))]
["Exit without saving" gnus-group-quit t]))
(gnus-run-hooks 'gnus-group-menu-hook)))
+(defvar gnus-group-toolbar-map nil)
+
+;; Emacs 21 tool bar. Should be no-op otherwise.
+(defun gnus-group-make-tool-bar ()
+ (if (and (fboundp 'tool-bar-add-item-from-menu)
+ (default-value 'tool-bar-mode)
+ (not gnus-group-toolbar-map))
+ (setq gnus-group-toolbar-map
+ (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
+ 'gnus-group-get-new-news-this-group "gnntg" gnus-group-mode-map)
+ (tool-bar-add-item-from-menu
+ 'gnus-group-catchup-current "catchup" gnus-group-mode-map)
+ (tool-bar-add-item-from-menu
+ 'gnus-group-describe-group "describe-group" gnus-group-mode-map)
+ (tool-bar-add-item "subscribe" 'gnus-group-subscribe 'subscribe
+ :help "Subscribe to the current group")
+ (tool-bar-add-item "unsubscribe" 'gnus-group-unsubscribe
+ 'unsubscribe
+ :help "Unsubscribe from the current group")
+ (tool-bar-add-item-from-menu
+ 'gnus-group-exit "exit-gnus" gnus-group-mode-map)
+ tool-bar-map)))
+ (if gnus-group-toolbar-map
+ (set (make-local-variable 'tool-bar-map) gnus-group-toolbar-map)))
+
(defun gnus-group-mode ()
"Major mode for reading news.
\\{gnus-group-mode-map}"
(interactive)
- (when (gnus-visual-p 'group-menu 'menu)
- (gnus-group-make-menu-bar))
(kill-all-local-variables)
+ (when (gnus-visual-p 'group-menu 'menu)
+ (gnus-group-make-menu-bar)
+ (gnus-group-make-tool-bar))
(gnus-simplify-mode-line)
(setq major-mode 'gnus-group-mode)
(setq mode-name "Group")
(defun gnus-update-group-mark-positions ()
(save-excursion
(let ((gnus-process-mark ?\200)
+ (gnus-group-update-hook nil)
(gnus-group-marked '("dummy.group"))
(gnus-active-hashtb (make-vector 10 0))
(topic ""))
(when gnus-carpal
(gnus-carpal-setup-buffer 'group))))
+(defun 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)))
+
+(defun gnus-group-name-decode (string charset)
+ (if (and string charset (featurep 'mule)
+ (not (mm-multibyte-string-p string)))
+ (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.
(interactive "nList groups on level: \nP")
(gnus-group-list-groups level all level))
-(defun gnus-group-prepare-flat (level &optional all lowest regexp)
+(defun gnus-group-prepare-logic (group test)
+ (or (and gnus-group-listed-groups
+ (null gnus-group-list-option)
+ (member group gnus-group-listed-groups))
+ (cond
+ ((null gnus-group-listed-groups) test)
+ ((null gnus-group-list-option) test)
+ (t (and (member group gnus-group-listed-groups)
+ (if (eq gnus-group-list-option 'flush)
+ (not test)
+ test))))))
+
+(defun gnus-group-prepare-flat (level &optional predicate lowest regexp)
"List all newsgroups with unread articles of level LEVEL or lower.
-If ALL is non-nil, list groups that have no unread articles.
+If PREDICATE is a function, list groups that the function returns non-nil;
+if it is t, list groups that have no unread articles.
If LOWEST is non-nil, list all newsgroups of level LOWEST or higher.
-If REGEXP, only list groups matching REGEXP."
+If REGEXP is a function, list dead groups that the function returns non-nil;
+if it is a string, only list groups matching REGEXP."
(set-buffer gnus-group-buffer)
(let ((buffer-read-only nil)
(newsrc (cdr gnus-newsrc-alist))
(lowest (or lowest 1))
+ (not-in-list (and gnus-group-listed-groups
+ (copy-sequence gnus-group-listed-groups)))
info clevel unread group params)
(erase-buffer)
- (when (< lowest gnus-level-zombie)
+ (when (or (< lowest gnus-level-zombie)
+ gnus-group-listed-groups)
;; List living groups.
(while newsrc
(setq info (car newsrc)
params (gnus-info-params info)
newsrc (cdr newsrc)
unread (car (gnus-gethash group gnus-newsrc-hashtb)))
- (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?
- (if (eq unread t) ; Unactivated?
- gnus-group-list-inactive-groups ; We list unactivated
- (> unread 0)) ; We list groups with unread articles
- (and gnus-list-groups-with-ticked-articles
- (cdr (assq 'tick (gnus-info-marks info))))
+ (if not-in-list
+ (setq not-in-list (delete group not-in-list)))
+ (and
+ (gnus-group-prepare-logic
+ group
+ (and unread ; This group might be unchecked
+ (or (not (stringp regexp))
+ (string-match regexp group))
+ (<= (setq clevel (gnus-info-level info)) level)
+ (>= clevel lowest)
+ (cond
+ ((functionp predicate)
+ (funcall predicate info))
+ (predicate t) ; We list all groups?
+ (t
+ (or
+ (if (eq unread t) ; Unactivated?
+ gnus-group-list-inactive-groups
+ ; We list unactivated
+ (> unread 0))
+ ; We list groups with unread articles
+ (and gnus-list-groups-with-ticked-articles
+ (cdr (assq 'tick (gnus-info-marks info))))
; And groups with tickeds
- ;; Check for permanent visibility.
- (and gnus-permanently-visible-groups
- (string-match gnus-permanently-visible-groups
- group))
- (memq 'visible params)
- (cdr (assq 'visible params)))
- (gnus-group-insert-group-line
- group (gnus-info-level info)
- (gnus-info-marks info) unread (gnus-info-method info)))))
+ ;; Check for permanent visibility.
+ (and gnus-permanently-visible-groups
+ (string-match gnus-permanently-visible-groups group))
+ (memq 'visible params)
+ (cdr (assq 'visible params)))))))
+ (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
- (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
- gnus-level-zombie ?Z
- regexp))
- (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)
- (gnus-group-prepare-flat-list-dead
- (setq gnus-killed-list (sort gnus-killed-list 'string<))
- gnus-level-killed ?K regexp))
+ (if (or gnus-group-listed-groups
+ (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
+ (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
+ not-in-list
+ (setq gnus-killed-list (sort gnus-killed-list 'string<)))
+ gnus-level-killed ?K regexp))
(gnus-group-set-mode-line)
- (setq gnus-group-list-mode (cons level all))
+ (setq gnus-group-list-mode (cons level predicate))
(gnus-run-hooks 'gnus-group-prepare-hook)
t))
;; suggested by Jack Vinson <vinson@unagi.cis.upenn.edu>. It does
;; this by ignoring the group format specification altogether.
(let (group)
- (if regexp
- ;; This loop is used when listing groups that match some
- ;; regexp.
+ (if (> (length groups) gnus-group-listing-limit)
(while groups
(setq group (pop groups))
- (when (string-match regexp group)
+ (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 " *: " group "\n"))
+ (insert " " mark " *: "
+ (gnus-group-decoded-name 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
- (gnus-add-text-properties
- (point) (prog1 (1+ (point))
- (insert " " mark " *: "
- (setq group (pop groups)) "\n"))
- (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb)
- 'gnus-unread t
- 'gnus-level level))))))
+ (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."
0
(- (1+ (cdr active)) (car active)))
nil)
- nil))))
+ (gnus-method-simplify (gnus-find-method-for-group group))))))
(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)))
((<= 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
?m ? ))
(gnus-tmp-moderated-string
(if (eq gnus-tmp-moderated ?m) "(m)" ""))
- (gnus-tmp-method
- (gnus-server-get-method gnus-tmp-group gnus-tmp-method)) ;
+ (gnus-tmp-group-icon "==&&==")
(gnus-tmp-news-server (or (cadr gnus-tmp-method) ""))
(gnus-tmp-news-method (or (car gnus-tmp-method) ""))
(gnus-tmp-news-method-string
(point)
(prog1 (1+ (point))
;; Insert the text.
- (eval gnus-group-line-format-spec))
+ (let ((gnus-tmp-group (gnus-group-name-decode
+ gnus-tmp-group group-name-charset)))
+ (eval gnus-group-line-format-spec)))
`(gnus-group ,(gnus-intern-safe gnus-tmp-group gnus-active-hashtb)
gnus-unread ,(if (numberp number)
(string-to-int gnus-tmp-number-of-unread)
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)
- (forward-line))
+ (gnus-run-hooks 'gnus-group-update-hook))
+ (forward-line)
;; Allow XEmacs to remove front-sticky text properties.
(gnus-group-remove-excess-properties)))
(info (nth 2 entry))
(method (gnus-server-get-method group (gnus-info-method info)))
(marked (gnus-info-marks info))
- (mailp (memq 'mail (assoc (symbol-name
- (car (or method gnus-select-method)))
- gnus-valid-select-methods)))
+ (mailp (apply 'append
+ (mapcar
+ (lambda (x)
+ (memq x (assoc (symbol-name
+ (car (or method gnus-select-method)))
+ gnus-valid-select-methods)))
+ '(mail post-mail))))
(level (or (gnus-info-level info) gnus-level-killed))
(score (or (gnus-info-score info) 0))
(ticked (gnus-range-length (cdr (assq 'tick marked))))
;; 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")
(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)
(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
(defun gnus-group-select-group (&optional all)
"Select this newsgroup.
No article is selected automatically.
+If the group is opened, just switch the summary buffer.
If ALL is non-nil, already read articles become readable.
If ALL is a number, fetch this number of articles."
(interactive "P")
(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))
;; if selection was successful.
(defun gnus-group-read-ephemeral-group (group method &optional activate
quit-config request-only
- select-articles)
+ select-articles
+ parameters)
"Read GROUP from METHOD as an ephemeral group.
If ACTIVATE, request the group first.
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.
+If PARAMETERS, use those as the group parameters.
Return the name of the group if selection was successful."
;; Transform the select method into a unique server.
(,(intern (format "%s-address" (car method))) ,(cadr method))
,@(cddr method)))
(let ((group (if (gnus-group-foreign-p group) group
- (gnus-group-prefixed-name group method))))
+ (gnus-group-prefixed-name (gnus-group-real-name group)
+ method))))
(gnus-sethash
group
`(-1 nil (,group
,gnus-level-default-subscribed nil nil ,method
- ((quit-config .
- ,(if quit-config quit-config
- (cons gnus-summary-buffer
- gnus-current-window-configuration))))))
+ ,(cons
+ (if quit-config
+ (cons 'quit-config quit-config)
+ (cons 'quit-config
+ (cons gnus-summary-buffer
+ gnus-current-window-configuration)))
+ parameters)))
gnus-newsrc-hashtb)
(push method gnus-ephemeral-servers)
(set-buffer gnus-group-buffer)
(when (gnus-group-read-group t t group select-articles)
group)
;;(error nil)
- (quit nil)))))
+ (quit
+ (message "Quit reading the ephemeral group")
+ nil)))))
(defun gnus-group-jump-to-group (group)
"Jump to newsgroup GROUP."
(list (completing-read
"Group: " gnus-active-hashtb nil
(gnus-read-active-file-p)
- nil
+ gnus-group-jump-to-group-prompt
'gnus-group-history)))
(when (equal 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
- (gnus-goto-char
- (text-property-any
- (point-min) (point-max)
- 'gnus-group (gnus-intern-safe group gnus-active-hashtb)))
- (beginning-of-line)
- (cond
- ;; It's quite likely that we are on the right line, so
- ;; we check the current line first.
- ((eq (get-text-property (point) 'gnus-group)
- (gnus-intern-safe group gnus-active-hashtb))
- (point))
- ;; Previous and next line are also likely, so we check them as well.
- ((save-excursion
- (forward-line -1)
- (eq (get-text-property (point) 'gnus-group)
- (gnus-intern-safe group gnus-active-hashtb)))
- (forward-line -1)
- (point))
- ((save-excursion
- (forward-line 1)
- (eq (get-text-property (point) 'gnus-group)
- (gnus-intern-safe group gnus-active-hashtb)))
- (forward-line 1)
- (point))
- (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))))))))
+ (beginning-of-line)
+ (cond
+ ;; It's quite likely that we are on the right line, so
+ ;; we check the current line first.
+ ((and (not far)
+ (eq (get-text-property (point) 'gnus-group)
+ (gnus-intern-safe group gnus-active-hashtb))
+ (or (not test-marked) (gnus-group-mark-line-p)))
+ (point))
+ ;; Previous and next line are also likely, so we check them as well.
+ ((and (not far)
+ (save-excursion
+ (forward-line -1)
+ (and (eq (get-text-property (point) 'gnus-group)
+ (gnus-intern-safe group gnus-active-hashtb))
+ (or (not test-marked) (gnus-group-mark-line-p)))))
+ (forward-line -1)
+ (point))
+ ((and (not far)
+ (save-excursion
+ (forward-line 1)
+ (and (eq (get-text-property (point) 'gnus-group)
+ (gnus-intern-safe group gnus-active-hashtb))
+ (or (not test-marked) (gnus-group-mark-line-p)))))
+ (forward-line 1)
+ (point))
+ (test-marked
+ (goto-char (point-min))
+ (let (found)
+ (while (and (not found)
+ (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.
(list (gnus-group-group-name)
current-prefix-arg))
(unless group
- (error "No group to rename"))
+ (error "No group to delete"))
(unless (gnus-check-backend-function 'request-delete-group group)
(error "This backend does not support group deletion"))
(prog1
(gnus-message 6 "Renaming group %s to %s..." group new-name)
(prog1
- (if (not (gnus-request-rename-group group new-name))
+ (if (progn
+ (gnus-group-goto-group group)
+ (not (when (< (gnus-group-group-level) gnus-level-zombie)
+ (gnus-request-rename-group group new-name))))
(gnus-error 3 "Couldn't rename group %s to %s" group new-name)
;; We rename the group internally by killing it...
- (gnus-group-goto-group group)
(gnus-group-kill-group)
;; ... changing its name ...
(setcar (cdar gnus-list-of-killed-groups) new-name)
((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)))))
+ (gnus-group-edit-group-done ',part ,group form)))
+ (local-set-key
+ "\C-c\C-i"
+ (gnus-create-info-command
+ (cond
+ ((eq part 'method)
+ "(gnus)Select Methods")
+ ((eq part 'params)
+ "(gnus)Group Parameters")
+ (t
+ "(gnus)Group Info"))))))
(defun gnus-group-edit-group-method (group)
"Edit the select method of GROUP."
(setcar entry (eval (cadar entry)))))
(gnus-group-make-group group method))
-(defun gnus-group-make-help-group ()
- "Create the Gnus documentation group."
+(defun gnus-group-make-help-group (&optional noerror)
+ "Create the Gnus documentation group.
+Optional argument NOERROR modifies the behavior of this function when the
+group already exists:
+- if not given, and error is signaled,
+- if t, stay silent,
+- if anything else, just print a message."
(interactive)
(let ((name (gnus-group-prefixed-name "gnus-help" '(nndoc "gnus-help")))
(file (nnheader-find-etc-directory "gnus-tut.txt" t)))
- (when (gnus-gethash name gnus-newsrc-hashtb)
- (error "Documentation group already exists"))
- (if (not file)
- (gnus-message 1 "Couldn't find doc group")
- (gnus-group-make-group
- (gnus-group-real-name name)
- (list 'nndoc "gnus-help"
- (list 'nndoc-address file)
- (list 'nndoc-article-type 'mbox)))))
+ (if (gnus-gethash name gnus-newsrc-hashtb)
+ (cond ((eq noerror nil)
+ (error "Documentation group already exists"))
+ ((eq noerror t)
+ ;; stay silent
+ )
+ (t
+ (gnus-message 1 "Documentation group already exists")))
+ ;; else:
+ (if (not file)
+ (gnus-message 1 "Couldn't find doc group")
+ (gnus-group-make-group
+ (gnus-group-real-name name)
+ (list 'nndoc "gnus-help"
+ (list 'nndoc-address file)
+ (list 'nndoc-article-type 'mbox))))
+ ))
(gnus-group-position-point))
(defun gnus-group-make-doc-group (file type)
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)))
(while (or (not group) (gnus-gethash group gnus-newsrc-hashtb))
(setq group
(gnus-group-prefixed-name
- (concat (file-name-as-directory (directory-file-name dir))
- ext)
+ (expand-file-name ext dir)
'(nndir "")))
(setq ext (format "<%d>" (setq i (1+ i)))))
(gnus-group-make-group
(gnus-group-real-name group)
(list 'nndir (gnus-group-real-name group) (list 'nndir-directory dir)))))
+(eval-when-compile (defvar nnkiboze-score-file))
(defun gnus-group-make-kiboze-group (group address scores)
"Create an nnkiboze group.
The user will be prompted for a name, a regexp to match groups, and
"Match on header: " headers nil t))))
(setq regexps nil)
(while (not (equal "" (setq regexp (read-string
- (format "Match on %s (string): "
+ (format "Match on %s (regexp): "
header)))))
(push (list regexp nil nil 'r) regexps))
(push (cons header regexps) scores))
scores)))
(gnus-group-make-group group "nnkiboze" address)
- (with-temp-file (gnus-score-file-name (concat "nnkiboze:" group))
- (let (emacs-lisp-mode-hook)
- (pp scores (current-buffer)))))
+ (let* ((nnkiboze-current-group group)
+ (score-file (car (nnkiboze-score-file "")))
+ (score-dir (file-name-directory score-file)))
+ (unless (file-exists-p score-dir)
+ (make-directory score-dir))
+ (with-temp-file score-file
+ (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."
(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'.
+ (unless (setq acl (nnimap-acl-get mailbox (cadr method)))
+ (error "Server does not support ACL's"))
+ (gnus-edit-form acl (format "Editing the access control list for `%s'.
An access control list is a list of (identifier . rights) elements.
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)
+ 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 (CREATE new sub-mailboxes in any implementation-defined
- hierarchy)
- d - delete (STORE DELETED flag, perform EXPUNGE)
+ 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
(interactive (list gnus-group-sort-function current-prefix-arg))
(funcall gnus-group-sort-alist-function
(gnus-make-sort-function func) reverse)
+ (gnus-group-unmark-all-groups)
(gnus-group-list-groups)
(gnus-dribble-touch))
(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)
(let ((groups (gnus-group-process-prefix n)))
(funcall gnus-group-sort-selected-function
groups (gnus-make-sort-function func) reverse)
- (gnus-group-list-groups)))
+ (gnus-group-unmark-all-groups)
+ (gnus-group-list-groups)
+ (gnus-dribble-touch)))
(defun gnus-group-sort-selected-flat (groups func reverse)
(let (entries infos)
(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-full-server-name
+ (gnus-find-method-for-group
+ (gnus-info-group info1) info1))
+ (gnus-method-to-full-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."
(defun gnus-info-clear-data (info)
"Clear all marks and read ranges from INFO."
- (let ((group (gnus-info-group info)))
+ (let ((group (gnus-info-group info))
+ action)
+ (dolist (el (gnus-info-marks info))
+ (push `(,(cdr el) add (,(car el))) action))
+ (push `(,(gnus-info-read info) add (read)) action)
(gnus-undo-register
`(progn
+ (gnus-request-set-mark ,group ',action)
(gnus-info-set-marks ',info ',(gnus-info-marks info) t)
(gnus-info-set-read ',info ',(gnus-info-read info))
(when (gnus-group-goto-group ,group)
+ (gnus-get-unread-articles-in-group ',info ',(gnus-active group) t)
(gnus-group-update-group-line))))
+ (setq action (mapcar (lambda (el) (list (nth 0 el) 'del (nth 2 el)))
+ action))
+ (gnus-request-set-mark group action)
(gnus-info-set-read info nil)
(when (gnus-info-marks info)
(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 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)))
+ (num (car entry))
+ (marks (nth 3 (nth 2 entry)))
+ (unread (gnus-list-of-unread-articles group)))
+ ;; 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)
+ (gnus-update-read-articles group nil)
+ (when all
+ ;; Nix out the lists of marks and dormants.
+ (gnus-request-set-mark group (list (list (cdr (assq 'tick marks))
+ 'del '(tick))
+ (list (cdr (assq 'dormant marks))
+ 'del '(dormant))))
+ (setq unread (gnus-uncompress-range
+ (gnus-range-add (gnus-range-add
+ unread (cdr (assq 'dormant marks)))
+ (cdr (assq 'tick marks)))))
+ (gnus-add-marked-articles group 'tick nil nil 'force)
+ (gnus-add-marked-articles group 'dormant nil nil 'force))
;; Do auto-expirable marks if that's required.
(when (gnus-group-auto-expirable-p group)
- (gnus-add-marked-articles
- group 'expire (gnus-list-of-unread-articles group))
- (when all
- (let ((marks (nth 3 (nth 2 entry))))
- (gnus-add-marked-articles
- group 'expire (gnus-uncompress-range (cdr (assq 'tick marks))))
- (gnus-add-marked-articles
- group 'expire (gnus-uncompress-range (cdr (assq 'tick marks)))))))
- (when entry
- (gnus-update-read-articles group nil)
- ;; Also nix out the lists of marks and dormants.
- (when all
- (gnus-add-marked-articles group 'tick nil nil 'force)
- (gnus-add-marked-articles group 'dormant nil nil 'force))
- (let ((gnus-newsgroup-name group))
- (gnus-run-hooks 'gnus-group-catchup-group-hook))
- num))))
+ (gnus-add-marked-articles group 'expire unread)
+ (gnus-request-set-mark group (list (list unread 'add '(expire)))))
+ (let ((gnus-newsgroup-name group))
+ (gnus-run-hooks 'gnus-group-catchup-group-hook))
+ num)))
(defun gnus-group-expire-articles (&optional n)
"Expire all expirable articles in the current newsgroup."
(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)))
+ (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
(gnus-request-expire-articles
(gnus-uncompress-sequence (cdr expirable)) group))))
(gnus-close-group group))
- (gnus-message 6 "Expiring articles in %s...done" 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."
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-decoded-name group)
+ "\n"))
(list 'gnus-group (gnus-intern-safe group gnus-active-hashtb)
'gnus-unread t
'gnus-level (inline (gnus-group-level group)))))
(when current-prefix-arg
(completing-read
"Faq dir: " (and (listp gnus-group-faq-directory)
- (mapcar (lambda (file) (list file))
+ (mapcar #'list
gnus-group-faq-directory))))))
(unless group
(error "No group name given"))
(while (and (not found)
(setq dir (pop dirs)))
(let ((name (gnus-group-real-name group)))
- (setq file (concat (file-name-as-directory dir) name)))
+ (setq file (expand-file-name name dir)))
(if (not (file-exists-p file))
(gnus-message 1 "No such file: %s" file)
(let ((enable-local-variables nil))
(mapatoms
(lambda (group)
(setq b (point))
- (insert (format " *: %-20s %s\n" (symbol-name group)
- (symbol-value group)))
+ (let ((charset (gnus-group-name-charset nil (symbol-name 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
(while groups
;; Groups may be entered twice into the list of groups.
(when (not (string= (car groups) prev))
- (insert (setq prev (car groups)) "\n")
- (when (and gnus-description-hashtb
- (setq des (gnus-gethash (car groups)
- gnus-description-hashtb)))
- (insert " " des "\n")))
+ (setq prev (car groups))
+ (let ((charset (gnus-group-name-charset nil prev)))
+ (insert (gnus-group-name-decode prev charset) "\n")
+ (when (and gnus-description-hashtb
+ (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)))
(when (and level
(> (prefix-numeric-value level) gnus-level-killed))
(gnus-get-killed-groups))
- (gnus-group-prepare-flat
- (or level gnus-level-subscribed) all (or lowest 1) regexp)
+ (funcall gnus-group-prepare-function
+ (or level gnus-level-subscribed) (and all t) (or lowest 1) regexp)
(goto-char (point-min))
(gnus-group-position-point))
(defun gnus-group-find-new-groups (&optional arg)
"Search for new groups and add them.
-Each new group will be treated with `gnus-subscribe-newsgroup-method.'
+Each new group will be treated with `gnus-subscribe-newsgroup-method'.
With 1 C-u, use the `ask-server' method to query the server for new
groups.
With 2 C-u's, use most complete method possible to query the server
The hook gnus-suspend-gnus-hook is called before actually suspending."
(interactive)
(gnus-run-hooks 'gnus-suspend-gnus-hook)
+ (gnus-offer-save-summaries)
;; Kill Gnus buffers except for group mode buffer.
(let ((group-buf (get-buffer gnus-group-buffer)))
(mapcar (lambda (buf)
- (unless (member buf (list group-buf gnus-dribble-buffer))
- (kill-buffer buf)))
+ (unless (or (member buf (list group-buf gnus-dribble-buffer))
+ (progn
+ (save-excursion
+ (set-buffer buf)
+ (eq major-mode 'message-mode))))
+ (gnus-kill-buffer buf)))
(gnus-buffers))
(gnus-kill-gnus-frames)
(when group-buf
(file-name-nondirectory gnus-current-startup-file))))
(gnus-run-hooks 'gnus-exit-gnus-hook)
(gnus-configure-windows 'group t)
+ (when (and (gnus-buffer-live-p gnus-dribble-buffer)
+ (not (zerop (save-excursion
+ (set-buffer gnus-dribble-buffer)
+ (buffer-size)))))
+ (gnus-dribble-enter
+ ";;; Gnus was exited on purpose without saving the .newsrc files."))
(gnus-dribble-save)
(gnus-close-backends)
(gnus-clear-system)
(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)
(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)
(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
;;;
"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)))
- (delta (subtract-time (current-time) time)))
+ (delta (subtract-time (current-time) time)))
(+ (* (nth 0 delta) 65536.0)
(nth 1 delta))))
""
(gnus-time-iso8601 time))))
+(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))
+ (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
+ 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))
+ (funcall gnus-group-prepare-function
+ (or level gnus-level-subscribed)
+ #'(lambda (info)
+ (let ((marks (gnus-info-marks info)))
+ (assq 'dormant marks)))
+ lowest
+ 'ignore)
+ (goto-char (point-min))
+ (gnus-group-position-point))
+
+(defun gnus-group-listed-groups ()
+ "Return a list of listed groups."
+ (let (point groups)
+ (goto-char (point-min))
+ (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)
+ (forward-char 1))
+ groups))
+
+(defun gnus-group-list-plus (&optional args)
+ "List groups plus the current selection."
+ (interactive "P")
+ (let ((gnus-group-listed-groups (gnus-group-listed-groups))
+ (gnus-group-list-mode gnus-group-list-mode) ;; Save it.
+ func)
+ (push last-command-event unread-command-events)
+ (if (featurep 'xemacs)
+ (push (make-event 'key-press '(key ?A)) unread-command-events)
+ (push ?A unread-command-events))
+ (let (gnus-pick-mode keys)
+ (setq keys (if (featurep 'xemacs)
+ (events-to-keys (read-key-sequence nil))
+ (read-key-sequence nil)))
+ (setq func (lookup-key (current-local-map) keys)))
+ (if (or (not func)
+ (numberp func))
+ (ding)
+ (call-interactively func))))
+
+(defun gnus-group-list-flush (&optional args)
+ "Flush groups from the current selection."
+ (interactive "P")
+ (let ((gnus-group-list-option 'flush))
+ (gnus-group-list-plus args)))
+
+(defun gnus-group-list-limit (&optional args)
+ "List groups limited within the current selection."
+ (interactive "P")
+ (let ((gnus-group-list-option 'limit))
+ (gnus-group-list-plus args)))
+
+(defun gnus-group-mark-article-read (group article)
+ "Mark ARTICLE read."
+ (let ((buffer (gnus-summary-buffer-name group))
+ (mark gnus-read-mark)
+ active n)
+ (if (get-buffer buffer)
+ (with-current-buffer buffer
+ (setq active gnus-newsgroup-active)
+ (gnus-activate-group group)
+ (when gnus-newsgroup-prepared
+ (when (and gnus-newsgroup-auto-expire
+ (memq mark gnus-auto-expirable-marks))
+ (setq mark gnus-expirable-mark))
+ (setq mark (gnus-request-update-mark
+ group article mark))
+ (gnus-mark-article-as-read article mark)
+ (setq gnus-newsgroup-active (gnus-active group))
+ (when active
+ (setq n (1+ (cdr active)))
+ (while (<= n (cdr gnus-newsgroup-active))
+ (unless (eq n article)
+ (push n gnus-newsgroup-unselected))
+ (setq n (1+ n))))))
+ (gnus-activate-group group)
+ (gnus-group-make-articles-read group
+ (list article))
+ (when (gnus-group-auto-expirable-p group)
+ (gnus-add-marked-articles
+ group 'expire (list article))))))
+
(provide 'gnus-group)
;;; gnus-group.el ends here
projects / elisp / gnus.git- / blobdiff