;;; gnus-group.el --- group mode commands for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
-;; Free Software Foundation, Inc.
+
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
+;; For Emacs <22.2 and XEmacs.
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+
(eval-when-compile
- (require 'cl)
- (defvar tool-bar-map))
+ (require 'cl))
+(defvar tool-bar-mode)
(require 'gnus)
(require 'gnus-start)
(require 'gnus-range)
(require 'gnus-win)
(require 'gnus-undo)
+(require 'gmm-utils)
(require 'time-date)
(require 'gnus-ems)
-(eval-when-compile
+(eval-when-compile
(require 'mm-url)
(let ((features (cons 'gnus-group features)))
(require 'gnus-sum))
(autoload 'gnus-agent-total-fetched-for "gnus-agent")
(autoload 'gnus-cache-total-fetched-for "gnus-cache")
-(defcustom gnus-group-archive-directory
- "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/"
- "*The address of the (ding) archives."
- :group 'gnus-group-foreign
- :type 'directory)
-
-(defcustom gnus-group-recent-archive-directory
- "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list-recent/"
- "*The address of the most recent (ding) articles."
- :group 'gnus-group-foreign
- :type 'directory)
+(autoload 'gnus-group-make-nnir-group "nnir")
(defcustom gnus-no-groups-message "No Gnus is good news"
"*Message displayed by Gnus when no groups are available."
:group 'gnus-group-listing
:type '(choice regexp (const nil)))
+(defcustom gnus-safe-html-newsgroups "\\`nnrss[+:]"
+ "Groups in which links in html articles are considered all safe.
+The value may be a regexp matching those groups, a list of group names,
+or nil. This overrides `mm-w3m-safe-url-regexp' (which see). This is
+effective only when emacs-w3m renders html articles, i.e., in the case
+`mm-text-html-renderer' is set to `w3m'."
+ :version "23.2"
+ :group 'gnus-group-various
+ :type '(choice regexp
+ (repeat :tag "List of group names" (string :tag "Group"))
+ (const nil)))
+
(defcustom gnus-list-groups-with-ticked-articles t
"*If non-nil, list groups that have only ticked articles.
If nil, only list groups that have unread articles."
`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,
+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
(function-item gnus-group-sort-by-rank)
(function :tag "other" nil))))
-(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y:%B%(%g%)%O\n"
+(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y:%B%(%g%)\n"
"*Format of group lines.
It works along the same lines as a normal formatting string,
with some simple extensions.
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
+is ignored altogether. If the spec is changed considerably, your
output may end up looking strange when listing both alive and killed
groups.
:group 'gnus-exit
:type 'hook)
-(defcustom gnus-group-update-hook '(gnus-group-highlight-line)
- "Hook called when a group line is changed.
-The hook will not be called if `gnus-visual' is nil.
-
-The default function `gnus-group-highlight-line' will
-highlight the line according to the `gnus-group-highlight'
-variable."
+(defcustom gnus-group-update-hook nil
+ "Hook called when a group line is changed."
:group 'gnus-group-visual
+ :version "24.1"
:type 'hook)
(defcustom gnus-useful-groups
- '(("(ding) mailing list mirrored at sunsite.auc.dk"
- "emacs.ding"
- (nntp "sunsite.auc.dk"
- (nntp-address "sunsite.auc.dk")))
- ("gnus-bug archive"
- "gnus-bug"
- (nndir "/ftp@ftp.ifi.uio.no:/pub/emacs/gnus/gnus-bug/"))
- ("Gnus help group"
+ '(("(ding) mailing list mirrored at gmane.org"
+ "gmane.emacs.gnus.general"
+ (nntp "Gmane"
+ (nntp-address "news.gmane.org")))
+ ("Gnus bug archive"
+ "gnus.gnus-bug"
+ (nntp "news.gnus.org"
+ (nntp-address "news.gnus.org")))
+ ("Local Gnus help group"
"gnus-help"
(nndoc "gnus-help"
(nndoc-article-type mbox)
(defcustom gnus-group-highlight
'(;; Mail.
((and mailp (= unread 0) (eq level 1)) .
- gnus-group-mail-1-empty-face)
+ gnus-group-mail-1-empty)
((and mailp (eq level 1)) .
- gnus-group-mail-1-face)
+ gnus-group-mail-1)
((and mailp (= unread 0) (eq level 2)) .
- gnus-group-mail-2-empty-face)
+ gnus-group-mail-2-empty)
((and mailp (eq level 2)) .
- gnus-group-mail-2-face)
+ gnus-group-mail-2)
((and mailp (= unread 0) (eq level 3)) .
- gnus-group-mail-3-empty-face)
+ gnus-group-mail-3-empty)
((and mailp (eq level 3)) .
- gnus-group-mail-3-face)
+ gnus-group-mail-3)
((and mailp (= unread 0)) .
- gnus-group-mail-low-empty-face)
+ gnus-group-mail-low-empty)
((and mailp) .
- gnus-group-mail-low-face)
+ gnus-group-mail-low)
;; News.
((and (= unread 0) (eq level 1)) .
- gnus-group-news-1-empty-face)
+ gnus-group-news-1-empty)
((and (eq level 1)) .
- gnus-group-news-1-face)
+ gnus-group-news-1)
((and (= unread 0) (eq level 2)) .
- gnus-group-news-2-empty-face)
+ gnus-group-news-2-empty)
((and (eq level 2)) .
- gnus-group-news-2-face)
+ gnus-group-news-2)
((and (= unread 0) (eq level 3)) .
- gnus-group-news-3-empty-face)
+ gnus-group-news-3-empty)
((and (eq level 3)) .
- gnus-group-news-3-face)
+ gnus-group-news-3)
((and (= unread 0) (eq level 4)) .
- gnus-group-news-4-empty-face)
+ gnus-group-news-4-empty)
((and (eq level 4)) .
- gnus-group-news-4-face)
+ gnus-group-news-4)
((and (= unread 0) (eq level 5)) .
- gnus-group-news-5-empty-face)
+ gnus-group-news-5-empty)
((and (eq level 5)) .
- gnus-group-news-5-face)
+ gnus-group-news-5)
((and (= unread 0) (eq level 6)) .
- gnus-group-news-6-empty-face)
+ gnus-group-news-6-empty)
((and (eq level 6)) .
- gnus-group-news-6-face)
+ gnus-group-news-6)
((and (= unread 0)) .
- gnus-group-news-low-empty-face)
+ gnus-group-news-low-empty)
(t .
- gnus-group-news-low-face))
+ gnus-group-news-low))
"*Controls the highlighting of group buffer lines.
Below is a list of `Form'/`Face' pairs. When deciding how a a
ticked: The number of ticked articles."
:group 'gnus-group-visual
:type '(repeat (cons (sexp :tag "Form") face)))
+(put 'gnus-group-highlight 'risky-local-variable t)
(defcustom gnus-new-mail-mark ?%
"Mark used for groups with new mail."
:type 'character)
(defgroup gnus-group-icons nil
- "Add Icons to your group buffer. "
+ "Add Icons to your group buffer."
:group 'gnus-group-visual)
(defcustom gnus-group-icon-list
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)))
+(put 'gnus-group-icon-list 'risky-local-variable t)
(defcustom gnus-group-name-charset-method-alist nil
"Alist of method and the charset for group names.
If it is an alist, it must consist of \(NUMBER . PROMPT\) pairs, for example:
\((1 . \"\") (2 . \"nnfolder+archive:\")). The element with number 0 is
used when no prefix argument is given to `gnus-group-jump-to-group'."
+ :version "22.1"
:group 'gnus-group-various
:type '(choice (string :tag "Prompt string")
(const :tag "Empty" nil)
(gnus-range-length (cdr (assq 'tick gnus-tmp-marked))))))
(t number)) ?s)
(?R gnus-tmp-number-of-read ?s)
- (?U (gnus-number-of-unseen-articles-in-group gnus-tmp-group) ?d)
+ (?U (if (gnus-active gnus-tmp-group)
+ (gnus-number-of-unseen-articles-in-group gnus-tmp-group)
+ "*")
+ ?s)
(?t gnus-tmp-number-total ?d)
(?y gnus-tmp-number-of-unread ?s)
(?I (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) ?d)
(?T (gnus-range-length (cdr (assq 'tick gnus-tmp-marked))) ?d)
(?i (+ (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked)))
(gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))) ?d)
- (?g gnus-tmp-group ?s)
+ (?g (if (boundp 'gnus-tmp-decoded-group)
+ gnus-tmp-decoded-group
+ gnus-tmp-group)
+ ?s)
(?G gnus-tmp-qualified-group ?s)
- (?c (gnus-short-group-name gnus-tmp-group) ?s)
+ (?c (gnus-short-group-name (if (boundp 'gnus-tmp-decoded-group)
+ gnus-tmp-decoded-group
+ gnus-tmp-group))
+ ?s)
(?C gnus-tmp-comment ?s)
(?D gnus-tmp-newsgroup-description ?s)
(?o gnus-tmp-moderated ?c)
(?O gnus-tmp-moderated-string ?s)
(?p gnus-tmp-process-marked ?c)
(?s gnus-tmp-news-server ?s)
- (?n gnus-tmp-news-method ?s)
+ (?n ,(if (featurep 'xemacs)
+ '(symbol-name gnus-tmp-news-method)
+ 'gnus-tmp-news-method)
+ ?s)
(?P gnus-group-indentation ?s)
(?E gnus-tmp-group-icon ?s)
(?B gnus-tmp-summary-live ?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)
"\M-e" gnus-group-edit-group-method
"^" gnus-group-enter-server-mode
gnus-mouse-2 gnus-mouse-pick-group
+ [follow-link] mouse-face
"<" beginning-of-buffer
">" end-of-buffer
"\C-c\C-b" gnus-bug
"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
"D" gnus-group-enter-directory
"f" gnus-group-make-doc-group
"w" gnus-group-make-web-group
+ "G" gnus-group-make-nnir-group
"M" gnus-group-read-ephemeral-group
"r" gnus-group-rename-group
"R" gnus-group-make-rss-group
"c" gnus-group-customize
- "x" gnus-group-nnimap-expunge
+ "z" gnus-group-compact-group
+ "x" gnus-group-expunge-group
"\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
- "w" gnus-soup-save-areas
- "s" gnus-soup-send-replies
- "p" gnus-soup-pack-packet
- "r" nnsoup-pack-replies)
-
(gnus-define-keys (gnus-group-sort-map "S" gnus-group-group-map)
"s" gnus-group-sort-groups
"a" gnus-group-sort-groups-by-alphabet
"e" gnus-score-edit-all-score)
(gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map)
- "c" gnus-group-fetch-charter
"C" gnus-group-fetch-control
"d" gnus-group-describe-group
- "f" gnus-group-fetch-faq
"v" gnus-version)
(gnus-define-keys (gnus-group-sub-map "S" gnus-group-mode-map)
(symbol-value 'gnus-topic-mode)))
(defun gnus-group-make-menu-bar ()
- (gnus-turn-off-edit-menu 'group)
(unless (boundp 'gnus-group-reading-menu)
(easy-menu-define
["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)]
- ["Fetch charter" gnus-group-fetch-charter
- :active (gnus-group-group-name)
- ,@(if (featurep 'xemacs) nil
- '(:help "Display the charter of the current group"))]
["Fetch control message" gnus-group-fetch-control
:active (gnus-group-group-name)
,@(if (featurep 'xemacs) nil
(gnus-group-group-name)]
["Select quick" gnus-group-quick-select-group (gnus-group-group-name)]
["Customize" gnus-group-customize (gnus-group-group-name)]
+ ["Compact" gnus-group-compact-group
+ :active (gnus-group-group-name)]
("Edit"
["Parameters" gnus-group-edit-group-parameters
:included (not (gnus-topic-mode-p))
["Make a foreign group..." gnus-group-make-group t]
["Add a directory group..." gnus-group-make-directory-group t]
["Add the help group" gnus-group-make-help-group t]
- ["Add the archive group" gnus-group-make-archive-group t]
["Make a doc group..." gnus-group-make-doc-group t]
["Make a web group..." gnus-group-make-web-group t]
- ["Make a kiboze group..." gnus-group-make-kiboze-group t]
+ ["Make a search group..." gnus-group-make-nnir-group t]
["Make a virtual group..." gnus-group-make-empty-virtual t]
["Add a group to a virtual..." gnus-group-add-to-virtual t]
["Make an ephemeral group..." gnus-group-read-ephemeral-group t]
(easy-menu-define
gnus-group-misc-menu gnus-group-mode-map ""
`("Gnus"
- ("SOUP"
- ["Pack replies" nnsoup-pack-replies (fboundp 'nnsoup-request-group)]
- ["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 mail" gnus-group-mail t]
["Send a message (mail or news)" gnus-group-post-news t]
["Create a local message" gnus-group-news t]
["Browse foreign server..." gnus-group-browse-foreign-server t]
["Enter server buffer" gnus-group-enter-server-mode t]
["Expire all expirable articles" gnus-group-expire-all-groups t]
- ["Generate any kiboze groups" nnkiboze-generate-groups t]
["Gnus version" gnus-version t]
["Save .newsrc files" gnus-group-save-newsrc t]
["Suspend Gnus" gnus-group-suspend 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
- (condition-case nil (require 'tool-bar) (error nil))
- (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)))
+
+(defvar gnus-group-tool-bar-map nil)
+
+(defun gnus-group-tool-bar-update (&optional symbol value)
+ "Update group buffer toolbar.
+Setter function for custom variables."
+ (when symbol
+ (set-default symbol value))
+ ;; (setq-default gnus-group-tool-bar-map nil)
+ ;; (use-local-map gnus-group-mode-map)
+ (when (gnus-alive-p)
+ (with-current-buffer gnus-group-buffer
+ (gnus-group-make-tool-bar t))))
+
+(defcustom gnus-group-tool-bar (if (eq gmm-tool-bar-style 'gnome)
+ 'gnus-group-tool-bar-gnome
+ 'gnus-group-tool-bar-retro)
+ "Specifies the Gnus group tool bar.
+
+It can be either a list or a symbol refering to a list. See
+`gmm-tool-bar-from-list' for the format of the list. The
+default key map is `gnus-group-mode-map'.
+
+Pre-defined symbols include `gnus-group-tool-bar-gnome' and
+`gnus-group-tool-bar-retro'."
+ :type '(choice (const :tag "GNOME style" gnus-group-tool-bar-gnome)
+ (const :tag "Retro look" gnus-group-tool-bar-retro)
+ (repeat :tag "User defined list" gmm-tool-bar-item)
+ (symbol))
+ :version "23.1" ;; No Gnus
+ :initialize 'custom-initialize-default
+ :set 'gnus-group-tool-bar-update
+ :group 'gnus-group)
+
+(defcustom gnus-group-tool-bar-gnome
+ '((gnus-group-post-news "mail/compose")
+ ;; Some useful agent icons? I don't use the agent so agent users should
+ ;; suggest useful commands:
+ (gnus-agent-toggle-plugged "disconnect" t
+ :help "Gnus is currently unplugged. Click to work online."
+ :visible (and gnus-agent (not gnus-plugged)))
+ (gnus-agent-toggle-plugged "connect" t
+ :help "Gnus is currently plugged. Click to work offline."
+ :visible (and gnus-agent gnus-plugged))
+ ;; FIXME: gnus-agent-toggle-plugged (in gnus-agent-group-make-menu-bar)
+ ;; should have a better help text.
+ (gnus-group-send-queue "mail/outbox" t
+ :visible (and gnus-agent gnus-plugged)
+ :help "Send articles from the queue group")
+ (gnus-group-get-new-news "mail/inbox" nil
+ :visible (or (not gnus-agent)
+ gnus-plugged))
+ ;; FIXME: gnus-*-read-group should have a better help text.
+ (gnus-topic-read-group "open" nil
+ :visible (and (boundp 'gnus-topic-mode)
+ gnus-topic-mode))
+ (gnus-group-read-group "open" nil
+ :visible (not (and (boundp 'gnus-topic-mode)
+ gnus-topic-mode)))
+ ;; (gnus-group-find-new-groups "???" nil)
+ (gnus-group-save-newsrc "save")
+ (gnus-group-describe-group "describe")
+ (gnus-group-unsubscribe-current-group "gnus/toggle-subscription")
+ (gnus-group-prev-unread-group "left-arrow")
+ (gnus-group-next-unread-group "right-arrow")
+ (gnus-group-exit "exit")
+ (gmm-customize-mode "preferences" t :help "Edit mode preferences")
+ (gnus-info-find-node "help"))
+ "List of functions for the group tool bar (GNOME style).
+
+See `gmm-tool-bar-from-list' for the format of the list."
+ :type '(repeat gmm-tool-bar-item)
+ :version "23.1" ;; No Gnus
+ :initialize 'custom-initialize-default
+ :set 'gnus-group-tool-bar-update
+ :group 'gnus-group)
+
+(defcustom gnus-group-tool-bar-retro
+ '((gnus-group-get-new-news "gnus/get-news")
+ (gnus-group-get-new-news-this-group "gnus/gnntg")
+ (gnus-group-catchup-current "gnus/catchup")
+ (gnus-group-describe-group "gnus/describe-group")
+ (gnus-group-subscribe "gnus/subscribe" t
+ :help "Subscribe to the current group")
+ (gnus-group-unsubscribe "gnus/unsubscribe" t
+ :help "Unsubscribe from the current group")
+ (gnus-group-exit "gnus/exit-gnus" gnus-group-mode-map))
+ "List of functions for the group tool bar (retro look).
+
+See `gmm-tool-bar-from-list' for the format of the list."
+ :type '(repeat gmm-tool-bar-item)
+ :version "23.1" ;; No Gnus
+ :initialize 'custom-initialize-default
+ :set 'gnus-group-tool-bar-update
+ :group 'gnus-group)
+
+(defcustom gnus-group-tool-bar-zap-list t
+ "List of icon items from the global tool bar.
+These items are not displayed in the Gnus group mode tool bar.
+
+See `gmm-tool-bar-from-list' for the format of the list."
+ :type 'gmm-tool-bar-zap-list
+ :version "23.1" ;; No Gnus
+ :initialize 'custom-initialize-default
+ :set 'gnus-group-tool-bar-update
+ :group 'gnus-group)
+
+(defvar image-load-path)
+(defvar tool-bar-map)
+
+(defun gnus-group-make-tool-bar (&optional force)
+ "Make a group mode tool bar from `gnus-group-tool-bar'.
+When FORCE, rebuild the tool bar."
+ (when (and (not (featurep 'xemacs))
+ (boundp 'tool-bar-mode)
+ tool-bar-mode
+ ;; The Gnus 5.10.6 code checked (default-value 'tool-bar-mode).
+ ;; Why? --rsteib
+ (or (not gnus-group-tool-bar-map) force))
+ (let* ((load-path
+ (gmm-image-load-path-for-library "gnus"
+ "gnus/toggle-subscription.xpm"
+ nil t))
+ (image-load-path (cons (car load-path)
+ (when (boundp 'image-load-path)
+ image-load-path)))
+ (map (gmm-tool-bar-from-list gnus-group-tool-bar
+ gnus-group-tool-bar-zap-list
+ 'gnus-group-mode-map)))
+ (if map
+ (set (make-local-variable 'tool-bar-map) map))))
+ gnus-group-tool-bar-map)
(defun gnus-group-mode ()
"Major mode for reading news.
All normal editing commands are switched off.
\\<gnus-group-mode-map>
-The group buffer lists (some of) the groups available. For instance,
+The group buffer lists (some of) the groups available. For instance,
`\\[gnus-group-list-groups]' will list all subscribed groups with unread articles, while `\\[gnus-group-list-zombies]'
lists all zombie groups.
(gnus-undo-mode 1))
(when gnus-slave
(gnus-slave-mode))
- (gnus-run-hooks 'gnus-group-mode-hook))
+ (gnus-run-mode-hooks 'gnus-group-mode-hook))
(defun gnus-update-group-mark-positions ()
(save-excursion
(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))))))))
+ (list (cons 'process (and (search-forward
+ (mm-string-to-multibyte "\200") nil t)
+ (- (point) (point-min) 1))))))))
(defun gnus-mouse-pick-group (e)
"Enter the group under the mouse pointer."
(defun gnus-group-setup-buffer ()
(set-buffer (gnus-get-buffer-create gnus-group-buffer))
(unless (eq major-mode 'gnus-group-mode)
- (gnus-group-mode)
- (when gnus-carpal
- (gnus-carpal-setup-buffer 'group))))
+ (gnus-group-mode)))
(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))
+ (let ((item (or (assoc method gnus-group-name-charset-method-alist)
+ (and (consp method)
+ (assoc (list (car method) (cadr method))
+ gnus-group-name-charset-method-alist))))
(alist gnus-group-name-charset-group-alist)
result)
(if item
(zerop number))
(zerop (buffer-size)))
;; No groups in the buffer.
- (gnus-message 5 gnus-no-groups-message))
+ (gnus-message 5 "%s" gnus-no-groups-message))
;; We have some groups displayed.
(goto-char (point-max))
(when (or (not gnus-group-goto-next-group-function)
(setq not-in-list (delete group not-in-list)))
(when (gnus-group-prepare-logic
group
- (and unread ; This group might be unchecked
+ (and (or unread ; This group might be unchecked
+ predicate) ; Check if this group should be listed
(or (not (stringp regexp))
(string-match regexp group))
(<= (setq clevel (gnus-info-level info)) level)
(if (eq unread t) ; Unactivated?
gnus-group-list-inactive-groups
; We list unactivated
- (> unread 0))
+ (and (numberp unread) (> unread 0)))
; We list groups with unread articles
(and gnus-list-groups-with-ticked-articles
(cdr (assq 'tick (gnus-info-marks info))))
(gnus-range-difference (list active) (gnus-info-read info))
seen))))))
+;; Moving through the Group buffer (in topic mode) e.g. with C-n doesn't
+;; update the state (enabled/disabled) of the icon `gnus-group-describe-group'
+;; automatically. After `C-l' the state is correct. See the following report
+;; on emacs-devel
+;; <http://thread.gmane.org/v9acdmrcse.fsf@marauder.physik.uni-ulm.de>:
+;; From: Reiner Steib
+;; Subject: tool bar icons not updated according to :active condition
+;; Newsgroups: gmane.emacs.devel
+;; Date: Mon, 23 Jan 2006 19:59:13 +0100
+;; Message-ID: <v9acdmrcse.fsf@marauder.physik.uni-ulm.de>
+
+(defcustom gnus-group-update-tool-bar
+ (and (not (featurep 'xemacs))
+ (boundp 'tool-bar-mode)
+ tool-bar-mode
+ ;; Using `redraw-frame' (see `gnus-tool-bar-update') in Emacs might
+ ;; be confusing, so maybe we shouldn't call it by default.
+ (fboundp 'force-window-update))
+ "Force updating the group buffer tool bar."
+ :group 'gnus-group
+ :version "22.1"
+ :initialize 'custom-initialize-default
+ :set (lambda (symbol value)
+ (set-default symbol value)
+ (when (gnus-alive-p)
+ (with-current-buffer gnus-group-buffer
+ ;; FIXME: Is there a better way to redraw the group buffer?
+ (gnus-group-get-new-news 0))))
+ :type 'boolean)
+
(defun gnus-group-insert-group-line (gnus-tmp-group gnus-tmp-level
gnus-tmp-marked number
gnus-tmp-method)
?m ? ))
(gnus-tmp-moderated-string
(if (eq gnus-tmp-moderated ?m) "(m)" ""))
- (gnus-tmp-group-icon "==&&==")
+ (gnus-tmp-group-icon (gnus-group-get-icon gnus-tmp-group))
(gnus-tmp-news-server (or (cadr gnus-tmp-method) ""))
(gnus-tmp-news-method (or (car gnus-tmp-method) ""))
(gnus-tmp-news-method-string
(if (member gnus-tmp-group gnus-group-marked)
gnus-process-mark ? ))
(buffer-read-only nil)
+ beg end
header gnus-tmp-header) ; passed as parameter to user-funcs.
(beginning-of-line)
+ (setq beg (point))
(gnus-add-text-properties
(point)
(prog1 (1+ (point))
;; Insert the text.
- (let ((gnus-tmp-group (gnus-group-name-decode
- gnus-tmp-group group-name-charset)))
+ (let ((gnus-tmp-decoded-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)
+ (string-to-number gnus-tmp-number-of-unread)
t)
gnus-marked ,gnus-tmp-marked-mark
gnus-indentation ,gnus-group-indentation
gnus-level ,gnus-tmp-level))
+ (setq end (point))
+ (when gnus-group-update-tool-bar
+ (gnus-put-text-property beg end 'point-entered
+ 'gnus-tool-bar-update)
+ (gnus-put-text-property beg end 'point-left
+ 'gnus-tool-bar-update))
(forward-line -1)
(when (inline (gnus-visual-p 'group-highlight 'highlight))
- (gnus-run-hooks 'gnus-group-update-hook))
+ (gnus-group-highlight-line gnus-tmp-group beg end))
+ (gnus-run-hooks 'gnus-group-update-hook)
(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'."
- (let* ((list gnus-group-highlight)
- (p (point))
- (end (point-at-eol))
- ;; now find out where the line starts and leave point there.
- (beg (progn (beginning-of-line) (point)))
- (group (gnus-group-group-name))
- (entry (gnus-group-entry group))
- (unread (if (numberp (car entry)) (car entry) 0))
- (active (gnus-active group))
- (total (if active (1+ (- (cdr active) (car active))) 0))
- (info (nth 2 entry))
- (method (inline (gnus-server-get-method group (gnus-info-method info))))
- (marked (gnus-info-marks info))
- (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-age (gnus-group-timestamp-delta group))
- (inhibit-read-only t))
- ;; Eval the cars of the lists until we find a match.
- (while (and list
- (not (eval (caar list))))
- (setq list (cdr list)))
- (let ((face (cdar list)))
- (unless (eq face (get-text-property beg 'face))
- (gnus-put-text-property-excluding-characters-with-faces
- beg end 'face
- (setq face (if (boundp face) (symbol-value face) face)))
- (gnus-extent-start-open beg)))
- (goto-char p)))
+(defun gnus-group-update-eval-form (group list)
+ "Eval `car' of each element of LIST, and return the first that return t.
+Some value are bound so the form can use them."
+ (when list
+ (let* ((entry (gnus-group-entry group))
+ (unread (if (numberp (car entry)) (car entry) 0))
+ (active (gnus-active group))
+ (total (if active (1+ (- (cdr active) (car active))) 0))
+ (info (nth 2 entry))
+ (method (inline (gnus-server-get-method group (gnus-info-method info))))
+ (marked (gnus-info-marks info))
+ (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-age (gnus-group-timestamp-delta group)))
+ ;; FIXME: http://thread.gmane.org/gmane.emacs.gnus.general/65451/focus=65465
+ ;; ======================================================================
+ ;; From: Richard Stallman
+ ;; Subject: Re: Rewriting gnus-group-highlight-line (was: [...])
+ ;; Cc: ding@gnus.org
+ ;; Date: Sat, 27 Oct 2007 19:41:20 -0400
+ ;; Message-ID: <E1IlvHM-0006TS-7t@fencepost.gnu.org>
+ ;;
+ ;; [...]
+ ;; The kludge is that the alist elements contain expressions that refer
+ ;; to local variables with short names. Perhaps write your own tiny
+ ;; evaluator that handles just `and', `or', and numeric comparisons
+ ;; and just a few specific variables.
+ ;; ======================================================================
+ ;;
+ ;; Similar for other evaluated variables. Grep for risky-local-variable
+ ;; to find them! -- rsteib
+ ;;
+ ;; Eval the cars of the lists until we find a match.
+ (while (and list
+ (not (eval (caar list))))
+ (setq list (cdr list)))
+ list)))
+
+(defun gnus-group-highlight-line (group beg end)
+ "Highlight the current line according to `gnus-group-highlight'.
+GROUP is current group, and the line to highlight starts at BEG
+and ends at END."
+ (let ((face (cdar (gnus-group-update-eval-form
+ group
+ gnus-group-highlight))))
+ (unless (eq face (get-text-property beg 'face))
+ (let ((inhibit-read-only t))
+ (gnus-put-text-property-excluding-characters-with-faces
+ beg end 'face
+ (if (boundp face) (symbol-value face) face)))
+ (gnus-extent-start-open beg))))
+
+(defun gnus-group-get-icon (group)
+ "Return an icon for GROUP according to `gnus-group-icon-list'."
+ (if gnus-group-icon-list
+ (let ((image-path
+ (cdar (gnus-group-update-eval-form group gnus-group-icon-list))))
+ (if image-path
+ (propertize " "
+ 'display
+ (append
+ (gnus-create-image (expand-file-name image-path))
+ '(:ascent center)))
+ " "))
+ " "))
(defun gnus-group-update-group (group &optional visible-only)
"Update all lines where GROUP appear.
If VISIBLE-ONLY is non-nil, the group won't be displayed if it isn't
already."
- ;; Can't use `save-excursion' here, so we do it manually.
- (let ((buf (current-buffer))
- mark)
- (set-buffer gnus-group-buffer)
- (setq mark (point-marker))
- ;; The buffer may be narrowed.
- (save-restriction
- (widen)
- (let ((ident (gnus-intern-safe group gnus-active-hashtb))
- (loc (point-min))
- found buffer-read-only)
- ;; Enter the current status into the dribble buffer.
- (let ((entry (gnus-group-entry group)))
- (when (and entry
- (not (gnus-ephemeral-group-p group)))
- (gnus-dribble-enter
- (concat "(gnus-group-set-info '"
- (gnus-prin1-to-string (nth 2 entry))
- ")"))))
- ;; Find all group instances. If topics are in use, each group
- ;; may be listed in more than once.
- (while (setq loc (text-property-any
- loc (point-max) 'gnus-group ident))
- (setq found t)
- (goto-char loc)
- (let ((gnus-group-indentation (gnus-group-group-indentation)))
- (gnus-delete-line)
- (gnus-group-insert-group-line-info group)
- (save-excursion
- (forward-line -1)
- (gnus-run-hooks 'gnus-group-update-group-hook)))
- (setq loc (1+ loc)))
- (unless (or found visible-only)
- ;; No such line in the buffer, find out where it's supposed to
- ;; go, and insert it there (or at the end of the buffer).
- (if gnus-goto-missing-group-function
- (funcall gnus-goto-missing-group-function group)
- (let ((entry (cddr (gnus-group-entry group))))
- (while (and entry (car entry)
- (not
- (gnus-goto-char
- (text-property-any
- (point-min) (point-max)
- 'gnus-group (gnus-intern-safe
- (caar entry) gnus-active-hashtb)))))
- (setq entry (cdr entry)))
- (or entry (goto-char (point-max)))))
- ;; Finally insert the line.
- (let ((gnus-group-indentation (gnus-group-group-indentation)))
- (gnus-group-insert-group-line-info group)
- (save-excursion
- (forward-line -1)
- (gnus-run-hooks 'gnus-group-update-group-hook))))
- (when gnus-group-update-group-function
- (funcall gnus-group-update-group-function group))
- (gnus-group-set-mode-line)))
- (goto-char mark)
- (set-marker mark nil)
- (set-buffer buf)))
+ (with-current-buffer gnus-group-buffer
+ (save-excursion
+ ;; The buffer may be narrowed.
+ (save-restriction
+ (widen)
+ (let ((ident (gnus-intern-safe group gnus-active-hashtb))
+ (loc (point-min))
+ found buffer-read-only)
+ ;; Enter the current status into the dribble buffer.
+ (let ((entry (gnus-group-entry group)))
+ (when (and entry
+ (not (gnus-ephemeral-group-p group)))
+ (gnus-dribble-enter
+ (concat "(gnus-group-set-info '"
+ (gnus-prin1-to-string (nth 2 entry))
+ ")"))))
+ ;; Find all group instances. If topics are in use, each group
+ ;; may be listed in more than once.
+ (while (setq loc (text-property-any
+ loc (point-max) 'gnus-group ident))
+ (setq found t)
+ (goto-char loc)
+ (let ((gnus-group-indentation (gnus-group-group-indentation)))
+ (gnus-delete-line)
+ (gnus-group-insert-group-line-info group)
+ (save-excursion
+ (forward-line -1)
+ (gnus-run-hooks 'gnus-group-update-group-hook)))
+ (setq loc (1+ loc)))
+ (unless (or found visible-only)
+ ;; No such line in the buffer, find out where it's supposed to
+ ;; go, and insert it there (or at the end of the buffer).
+ (if gnus-goto-missing-group-function
+ (funcall gnus-goto-missing-group-function group)
+ (let ((entry (cddr (gnus-group-entry group))))
+ (while (and entry (car entry)
+ (not
+ (gnus-goto-char
+ (text-property-any
+ (point-min) (point-max)
+ 'gnus-group (gnus-intern-safe
+ (caar entry)
+ gnus-active-hashtb)))))
+ (setq entry (cdr entry)))
+ (or entry (goto-char (point-max)))))
+ ;; Finally insert the line.
+ (let ((gnus-group-indentation (gnus-group-group-indentation)))
+ (gnus-group-insert-group-line-info group)
+ (save-excursion
+ (forward-line -1)
+ (gnus-run-hooks 'gnus-group-update-group-hook))))
+ (when gnus-group-update-group-function
+ (funcall gnus-group-update-group-function group))
+ (gnus-group-set-mode-line))))))
(defun gnus-group-set-mode-line ()
"Update the mode line in the group buffer."
(when (memq 'group gnus-updated-mode-lines)
;; Yes, we want to keep this mode line updated.
- (save-excursion
- (set-buffer gnus-group-buffer)
+ (with-current-buffer gnus-group-buffer
(let* ((gformat (or gnus-group-mode-line-format-spec
(gnus-set-format 'group-mode)))
(gnus-tmp-news-server (cadr gnus-select-method))
(and gnus-dribble-buffer
(buffer-name gnus-dribble-buffer)
(buffer-modified-p gnus-dribble-buffer)
- (save-excursion
- (set-buffer gnus-dribble-buffer)
+ (with-current-buffer gnus-dribble-buffer
(not (zerop (buffer-size))))))
(mode-string (eval gformat)))
;; Say whether the dribble buffer has been modified.
(size (+ size-in-cache size-in-agent))
(suffix '("B" "K" "M" "G"))
(scale 1024.0)
- (cutoff (* 10 scale)))
+ (cutoff scale))
(while (> size cutoff)
(setq size (/ size scale)
suffix (cdr suffix)))
(unless no-advance
(gnus-group-next-group 1))
(decf n))
- (gnus-summary-position-point)
+ (gnus-group-position-point)
n))
(defun gnus-group-unmark-group (n)
(defun gnus-group-unmark-all-groups ()
"Unmark all groups."
(interactive)
- (let ((groups gnus-group-marked))
- (save-excursion
- (while groups
- (gnus-group-remove-mark (pop groups)))))
+ (save-excursion
+ (mapc 'gnus-group-remove-mark gnus-group-marked))
(gnus-group-position-point))
(defun gnus-group-mark-region (unmark beg end)
(defun gnus-group-read-group (&optional all no-article group select-articles)
"Read news in this newsgroup.
If the prefix argument ALL is non-nil, already read articles become
-readable. IF ALL is a number, fetch this number of articles. If the
-optional argument NO-ARTICLE is non-nil, no article will be
-auto-selected upon group entry. If GROUP is non-nil, fetch that
-group."
+readable.
+
+If ALL is a positive number, fetch this number of the latest
+articles in the group. If ALL is a negative number, fetch this
+number of the earliest articles in the group.
+
+If the optional argument NO-ARTICLE is non-nil, no article will
+be auto-selected upon group entry. If GROUP is non-nil, fetch
+that group."
(interactive "P")
(let ((no-display (eq all 0))
(group (or group (gnus-group-group-name)))
(forward-line -1))
(gnus-group-read-group all t))
-(defun gnus-group-quick-select-group (&optional all)
- "Select the current group \"quickly\".
-This means that no highlighting or scoring will be performed.
-If ALL (the prefix argument) is 0, don't even generate the summary
-buffer.
+(defun gnus-group-quick-select-group (&optional all group)
+ "Select the GROUP \"quickly\".
+This means that no highlighting or scoring will be performed. If
+ALL (the prefix argument) is 0, don't even generate the summary
+buffer. If GROUP is nil, use current group.
This might be useful if you want to toggle threading
before entering the group."
gnus-home-score-file
gnus-apply-kill-hook
gnus-summary-expunge-below)
- (gnus-group-read-group all t)))
+ (gnus-group-read-group all t group)))
(defun gnus-group-visible-select-group (&optional all)
"Select the current group without hiding any articles."
(gnus-group-read-ephemeral-group
(gnus-group-prefixed-name group method) method)))
+(defun gnus-group-name-at-point ()
+ "Return a group name from around point if it exists, or nil."
+ (if (eq major-mode 'gnus-group-mode)
+ (let ((group (gnus-group-group-name)))
+ (when group
+ (gnus-group-decoded-name group)))
+ (let ((regexp "[][\C-@-\t\v-*,/:-@\\^`{-\C-?]*\
+\\(nn[a-z]+\\(?:\\+[^][\C-@-*,/:-@\\^`{-\C-?]+\\)?:\
+\[^][\C-@-*,./:-@\\^`{-\C-?]+\\(?:\\.[^][\C-@-*,./:-@\\^`{-\C-?]+\\)*\
+\\|[^][\C-@-*,./:-@\\^`{-\C-?]+\\(?:\\.[^][\C-@-*,./:-@\\^`{-\C-?]+\\)+\\)")
+ (start (point))
+ (case-fold-search nil))
+ (prog1
+ (if (or (and (not (or (eobp)
+ (looking-at "[][\C-@-*,/;-@\\^`{-\C-?]")))
+ (prog1 t
+ (skip-chars-backward "^][\C-@-\t\v-*,/;-@\\^`{-\C-?"
+ (point-at-bol))))
+ (and (looking-at "[][\C-@-\t\v-*,/;-@\\^`{-\C-?]*$")
+ (prog1 t
+ (skip-chars-backward "][\C-@-\t\v-*,/;-@\\^`{-\C-?")
+ (skip-chars-backward "^][\C-@-\t\v-*,/;-@\\^`{-\C-?"
+ (point-at-bol))))
+ (string-match "\\`[][\C-@-\t\v-*,/;-@\\^`{-\C-?]*\\'"
+ (buffer-substring (point-at-bol) (point))))
+ (when (looking-at regexp)
+ (match-string 1))
+ (let (group distance)
+ (when (looking-at regexp)
+ (setq group (match-string 1)
+ distance (- (match-beginning 1) (match-beginning 0))))
+ (skip-chars-backward "][\C-@-\t\v-*,/;-@\\^`{-\C-?")
+ (skip-chars-backward "^][\C-@-\t\v-*,/;-@\\^`{-\C-?"
+ (point-at-bol))
+ (if (looking-at regexp)
+ (if (and group (<= distance (- start (match-end 0))))
+ group
+ (match-string 1))
+ group)))
+ (goto-char start)))))
+
+(defun gnus-group-completing-read (&optional prompt collection
+ require-match initial-input hist
+ def)
+ "Read a group name with completion. Non-ASCII group names are allowed.
+The arguments are the same as `completing-read' except that COLLECTION
+and HIST default to `gnus-active-hashtb' and `gnus-group-history'
+respectively if they are omitted. Regards COLLECTION as a hash table
+if it is not a list."
+ (or collection (setq collection gnus-active-hashtb))
+ (let (choices group)
+ (if (listp collection)
+ (dolist (symbol collection)
+ (setq group (symbol-name symbol))
+ (push (if (string-match "[^\000-\177]" group)
+ (gnus-group-decoded-name group)
+ group)
+ choices))
+ (mapatoms (lambda (symbol)
+ (setq group (symbol-name symbol))
+ (push (if (string-match "[^\000-\177]" group)
+ (gnus-group-decoded-name group)
+ group)
+ choices))
+ collection))
+ (setq group (gnus-completing-read (or prompt "Group") (nreverse choices)
+ require-match initial-input
+ (or hist 'gnus-group-history)
+ def))
+ (unless (if (listp collection)
+ (member group (mapcar 'symbol-name collection))
+ (symbol-value (intern-soft group collection)))
+ (setq group
+ (mm-encode-coding-string
+ group (gnus-group-name-charset nil group))))
+ (replace-regexp-in-string "\n" "" group)))
+
;;;###autoload
(defun gnus-fetch-group (group &optional articles)
"Start Gnus if necessary and enter GROUP.
+If ARTICLES, display those articles.
Returns whether the fetching was successful or not."
- (interactive (list (completing-read "Group name: " gnus-active-hashtb)))
- (unless (get-buffer gnus-group-buffer)
+ (interactive (list (gnus-group-completing-read nil
+ nil nil
+ (gnus-group-name-at-point))))
+ (unless (gnus-alive-p)
(gnus-no-server))
- (gnus-group-read-group articles nil group))
+ (gnus-group-read-group (if articles nil t) nil group articles))
;;;###autoload
(defun gnus-fetch-group-other-frame (group)
(other-frame 1))))
(gnus-fetch-group group))
-(defvar gnus-ephemeral-group-server 0)
-
(defcustom gnus-large-ephemeral-newsgroup 200
"The number of articles which indicates a large ephemeral newsgroup.
Same as `gnus-large-newsgroup', but only used for ephemeral newsgroups.
If the number of articles in a newsgroup is greater than this value,
confirmation is required for selecting the newsgroup. If it is nil, no
confirmation is required."
+ :version "22.1"
:group 'gnus-group-select
:type '(choice (const :tag "No limit" nil)
integer))
(defcustom gnus-fetch-old-ephemeral-headers nil
"Same as `gnus-fetch-old-headers', but only used for ephemeral newsgroups."
+ :version "22.1"
:group 'gnus-thread
:type '(choice (const :tag "off" nil)
(const some)
(defun gnus-group-read-ephemeral-group (group method &optional activate
quit-config request-only
select-articles
- parameters)
+ parameters
+ number)
"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
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.
+If NUMBER, fetch this number of articles.
Return the name of the group if selection was successful."
(interactive
(list
;; (gnus-read-group "Group name: ")
- (completing-read
- "Group: " gnus-active-hashtb
- nil nil nil
- 'gnus-group-history)
+ (gnus-group-completing-read)
(gnus-read-method "From method: ")))
;; Transform the select method into a unique server.
(when (stringp method)
(when (let ((gnus-large-newsgroup gnus-large-ephemeral-newsgroup)
(gnus-fetch-old-headers
gnus-fetch-old-ephemeral-headers))
- (gnus-group-read-group t t group select-articles))
+ (gnus-group-read-group (or number t) t group select-articles))
group)
;;(error nil)
(quit
(message "Quit reading the ephemeral group")
nil)))))
+(defcustom gnus-gmane-group-download-format
+ "http://download.gmane.org/%s/%s/%s"
+ "URL for downloading mbox files.
+It must contain three \"%s\". They correspond to the group, the
+minimal and maximal article numbers, respectively."
+ :group 'gnus-group-foreign
+ :version "23.1" ;; No Gnus
+ :type 'string)
+
+(autoload 'url-insert-file-contents "url-handlers")
+;; FIXME:
+;; - Add documentation, menu, key bindings, ...
+
+(defun gnus-read-ephemeral-gmane-group (group start &optional range)
+ "Read articles from Gmane group GROUP as an ephemeral group.
+START is the first article. RANGE specifies how many articles
+are fetched. The articles are downloaded via HTTP using the URL
+specified by `gnus-gmane-group-download-format'."
+ ;; See <http://gmane.org/export.php> for more information.
+ (interactive
+ (list
+ (gnus-group-completing-read "Gmane group")
+ (read-number "Start article number: ")
+ (read-number "How many articles: ")))
+ (unless range (setq range 500))
+ (when (< range 1)
+ (error "Invalid range: %s" range))
+ (let ((tmpfile (mm-make-temp-file
+ (format "%s.start-%s.range-%s." group start range)))
+ (gnus-thread-sort-functions '(gnus-thread-sort-by-number)))
+ (with-temp-file tmpfile
+ (url-insert-file-contents
+ (format gnus-gmane-group-download-format
+ group start (+ start range)))
+ (write-region (point-min) (point-max) tmpfile)
+ (gnus-group-read-ephemeral-group
+ (format "%s.start-%s.range-%s" group start range)
+ `(nndoc ,tmpfile
+ (nndoc-article-type mbox))))
+ (delete-file tmpfile)))
+
+(defun gnus-read-ephemeral-gmane-group-url (url)
+ "Create an ephemeral Gmane group from URL.
+
+Valid input formats include:
+\"http://thread.gmane.org/gmane.foo.bar/12300/focus=12399\",
+\"http://thread.gmane.org/gmane.foo.bar/12345/\",
+\"http://article.gmane.org/gmane.foo.bar/12345/\",
+\"http://news.gmane.org/group/gmane.foo.bar/thread=12345\""
+ ;; - Feel free to add other useful Gmane URLs here! Maybe the URLs should
+ ;; be customizable?
+ ;; - The URLs should be added to `gnus-button-alist'. Probably we should
+ ;; prompt the user to decide: "View via `browse-url' or in Gnus? "
+ ;; (`gnus-read-ephemeral-gmane-group-url')
+ (interactive
+ (list (gnus-group-completing-read "Gmane URL")))
+ (let (group start range)
+ (cond
+ ;; URLs providing `group', `start' and `range':
+ ((string-match
+ ;; http://thread.gmane.org/gmane.emacs.devel/86326/focus=86525
+ "^http://thread\.gmane\.org/\\([^/]+\\)/\\([0-9]+\\)/focus=\\([0-9]+\\)$"
+ url)
+ (setq group (match-string 1 url)
+ start (string-to-number (match-string 2 url))
+ ;; Ensure that `range' is large enough to ensure focus article is
+ ;; included.
+ range (- (string-to-number (match-string 3 url))
+ start -1)))
+ ;; URLs providing `group' and `start':
+ ((or (string-match
+ ;; http://article.gmane.org/gmane.comp.gnu.make.bugs/3584
+ "^http://\\(?:thread\\|article\\|permalink\\)\.gmane\.org/\\([^/]+\\)/\\([0-9]+\\)"
+ url)
+ (string-match
+ ;; Don't advertise these in the doc string yet:
+ "^\\(?:nntp\\|news\\)://news\.gmane\.org/\\([^/]+\\)/\\([0-9]+\\)"
+ url)
+ (string-match
+ ;; http://news.gmane.org/group/gmane.emacs.gnus.general/thread=65099/force_load=t
+ "^http://news\.gmane\.org/group/\\([^/]+\\)/thread=\\([0-9]+\\)"
+ url))
+ (setq group (match-string 1 url)
+ start (string-to-number (match-string 2 url))))
+ (t
+ (error "Can't parse URL %s" url)))
+ (gnus-read-ephemeral-gmane-group group start range)))
+
+(defcustom gnus-bug-group-download-format-alist
+ '((emacs . "http://debbugs.gnu.org/%s;mbox=yes")
+ (debian
+ . "http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=%s&mbox=yes"))
+ "Alist of symbols for bug trackers and the corresponding URL format string.
+The URL format string must contain a single \"%s\", specifying
+the bug number, and browsing the URL must return mbox output."
+ :group 'gnus-group-foreign
+ :version "23.2" ;; No Gnus
+ :type '(repeat (cons (symbol) (string :tag "URL format string"))))
+
+(defun gnus-read-ephemeral-bug-group (number mbox-url)
+ "Browse bug NUMBER as ephemeral group."
+ (interactive (list (read-string "Enter bug number: "
+ (thing-at-point 'word) nil)
+ ;; FIXME: Add completing-read from
+ ;; `gnus-emacs-bug-group-download-format' ...
+ (cdr (assoc 'emacs gnus-bug-group-download-format-alist))))
+ (when (stringp number)
+ (setq number (string-to-number number)))
+ (let ((tmpfile (mm-make-temp-file "gnus-temp-group-")))
+ (with-temp-file tmpfile
+ (url-insert-file-contents (format mbox-url number))
+ (goto-char (point-min))
+ ;; Add the debbugs address so that we can respond to reports easily.
+ (while (re-search-forward "^To: " nil t)
+ (end-of-line)
+ (insert (format ", %s@%s" number
+ (replace-regexp-in-string
+ "/.*$" ""
+ (replace-regexp-in-string "^http://" "" mbox-url)))))
+ (write-region (point-min) (point-max) tmpfile)
+ (gnus-group-read-ephemeral-group
+ "gnus-read-ephemeral-bug"
+ `(nndoc ,tmpfile
+ (nndoc-article-type mbox))))
+ (delete-file tmpfile)))
+
+(defun gnus-read-ephemeral-debian-bug-group (number)
+ "Browse Debian bug NUMBER as ephemeral group."
+ (interactive (list (read-string "Enter bug number: "
+ (thing-at-point 'word) nil)))
+ (gnus-read-ephemeral-bug-group
+ number
+ (cdr (assoc 'debian gnus-bug-group-download-format-alist))))
+
+(defun gnus-read-ephemeral-emacs-bug-group (number)
+ "Browse Emacs bug NUMBER as ephemeral group."
+ (interactive (list (read-string "Enter bug number: "
+ (thing-at-point 'word) nil)))
+ (gnus-read-ephemeral-bug-group
+ number
+ (cdr (assoc 'emacs gnus-bug-group-download-format-alist))))
+
(defun gnus-group-jump-to-group (group &optional prompt)
"Jump to newsgroup GROUP.
If PROMPT (the prefix) is a number, use the prompt specified in
`gnus-group-jump-to-group-prompt'."
(interactive
- (list (mm-string-make-unibyte
- (completing-read
- "Group: " gnus-active-hashtb nil
- (gnus-read-active-file-p)
- (if current-prefix-arg
- (cdr (assq current-prefix-arg gnus-group-jump-to-group-prompt))
- (or (and (stringp gnus-group-jump-to-group-prompt)
- gnus-group-jump-to-group-prompt)
- (let ((p (cdr (assq 0 gnus-group-jump-to-group-prompt))))
- (and (stringp p) p))))
- 'gnus-group-history))))
+ (list (gnus-group-completing-read
+ nil nil (gnus-read-active-file-p)
+ (if current-prefix-arg
+ (cdr (assq current-prefix-arg gnus-group-jump-to-group-prompt))
+ (or (and (stringp gnus-group-jump-to-group-prompt)
+ gnus-group-jump-to-group-prompt)
+ (let ((p (cdr (assq 0 gnus-group-jump-to-group-prompt))))
+ (and (stringp p) p)))))))
(when (equal group "")
(error "Empty group name"))
(gnus-group-position-point)
(and best-point (gnus-group-group-name))))
+;; Is there something like an after-point-motion-hook?
+;; (inhibit-point-motion-hooks?). Is there a tool-bar-update function?
+
+;; (defun gnus-group-menu-bar-update ()
+;; (let* ((buf (list (with-current-buffer gnus-group-buffer
+;; (current-buffer))))
+;; (name (buffer-name (car buf))))
+;; (setcdr buf
+;; (if (> (length name) 27)
+;; (concat (substring name 0 12)
+;; "..."
+;; (substring name -12))
+;; name))
+;; (menu-bar-update-buffers-1 buf)))
+
+;; (defun gnus-group-position-point ()
+;; (gnus-goto-colon)
+;; (gnus-group-menu-bar-update))
+
(defun gnus-group-first-unread-group ()
"Go to the first group with unread articles."
(interactive)
(defun gnus-group-make-group-simple (&optional group)
"Add a new newsgroup.
The user will be prompted for GROUP."
- (interactive
- (list (completing-read "Group: " gnus-active-hashtb
- nil nil nil 'gnus-group-history)))
- (gnus-group-make-group
- (gnus-group-real-name group)
- (gnus-group-server group)))
+ (interactive (list (gnus-group-completing-read)))
+ (gnus-group-make-group (gnus-group-real-name group)
+ (gnus-group-server group)
+ nil nil t))
-(defun gnus-group-make-group (name &optional method address args)
+(defun gnus-group-make-group (name &optional method address args encoded)
"Add a new newsgroup.
The user will be prompted for a NAME, for a select METHOD, and an
-ADDRESS."
+ADDRESS. NAME should be a human-readable string (i.e., not be encoded
+even if it contains non-ASCII characters) unless ENCODED is non-nil.
+
+If the backend supports it, the group will also be created on the
+server."
(interactive
(list
(gnus-read-group "Group name: ")
(when (stringp method)
(setq method (or (gnus-server-to-method method) method)))
+ (unless encoded
+ (setq name (mm-encode-coding-string
+ name
+ (gnus-group-name-charset method name))))
(let* ((meth (gnus-method-simplify
(when (and method
(not (gnus-server-equal method gnus-select-method)))
(nname (if method (gnus-group-prefixed-name name meth) name))
backend info)
(when (gnus-group-entry nname)
- (error "Group %s already exists" nname))
+ (error "Group %s already exists" (gnus-group-decoded-name nname)))
;; Subscribe to the new group.
(gnus-group-change-level
(setq info (list t nname gnus-level-default-subscribed nil nil meth))
"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
+of the Earth\". There is no undo. The user will be prompted before
doing the deletion.
Note that you also have to specify FORCE if you want the group to
be removed from the server, even when it's empty."
(unless (gnus-check-backend-function 'request-delete-group group)
(error "This back end does not support group deletion"))
(prog1
- (if (and (not no-prompt)
- (not (gnus-yes-or-no-p
- (format
- "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)
- (gnus-group-goto-group group)
- (gnus-group-kill-group 1 t)
- (gnus-set-active group nil)
- t))
+ (let ((group-decoded (gnus-group-decoded-name group)))
+ (if (and (not no-prompt)
+ (not (gnus-yes-or-no-p
+ (format
+ "Do you really want to delete %s%s? "
+ group-decoded (if force " and all its contents" "")))))
+ () ; Whew!
+ (gnus-message 6 "Deleting group %s..." group-decoded)
+ (if (not (gnus-request-delete-group group force))
+ (gnus-error 3 "Couldn't delete group %s" group-decoded)
+ (gnus-message 6 "Deleting group %s...done" group-decoded)
+ (gnus-group-goto-group group)
+ (gnus-group-kill-group 1 t)
+ (gnus-set-active group nil)
+ t)))
(gnus-group-position-point)))
(defun gnus-group-rename-group (group new-name)
When used interactively, GROUP is the group under point
and NEW-NAME will be prompted for."
(interactive
- (list
- (gnus-group-group-name)
- (progn
- (unless (gnus-check-backend-function
- 'request-rename-group (gnus-group-group-name))
- (error "This back end does not support renaming groups"))
- (gnus-read-group "Rename group to: "
- (gnus-group-real-name (gnus-group-group-name))))))
+ (let ((group (gnus-group-group-name))
+ method new-name)
+ (unless (gnus-check-backend-function 'request-rename-group group)
+ (error "This back end does not support renaming groups"))
+ (setq new-name (gnus-read-group
+ "Rename group to: "
+ (gnus-group-real-name (gnus-group-decoded-name group)))
+ method (gnus-info-method (gnus-get-info group)))
+ (list group (mm-encode-coding-string
+ new-name
+ (gnus-group-name-charset
+ method
+ (gnus-group-prefixed-name new-name method))))))
(unless (gnus-check-backend-function 'request-rename-group group)
(error "This back end does not support renaming groups"))
(gnus-group-real-name new-name)
(gnus-info-method (gnus-get-info group)))))
- (when (gnus-active new-name)
- (error "The group %s already exists" new-name))
-
- (gnus-message 6 "Renaming group %s to %s..." group new-name)
- (prog1
- (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-kill-group)
- ;; ... changing its name ...
- (setcar (cdar gnus-list-of-killed-groups) new-name)
- ;; ... and then yanking it. Magic!
- (gnus-group-yank-group)
- (gnus-set-active new-name (gnus-active group))
- (gnus-message 6 "Renaming group %s to %s...done" group new-name)
- new-name)
- (setq gnus-killed-list (delete group gnus-killed-list))
- (gnus-set-active group nil)
- (gnus-dribble-touch)
- (gnus-group-position-point)))
+ (let ((decoded-group (gnus-group-decoded-name group))
+ (decoded-new-name (gnus-group-decoded-name new-name)))
+ (when (gnus-active new-name)
+ (error "The group %s already exists" decoded-new-name))
+
+ (gnus-message 6 "Renaming group %s to %s..."
+ decoded-group decoded-new-name)
+ (prog1
+ (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"
+ decoded-group decoded-new-name)
+ ;; We rename the group internally by killing it...
+ (gnus-group-kill-group)
+ ;; ... changing its name ...
+ (setcar (cdar gnus-list-of-killed-groups) new-name)
+ ;; ... and then yanking it. Magic!
+ (gnus-group-yank-group)
+ (gnus-set-active new-name (gnus-active group))
+ (gnus-message 6 "Renaming group %s to %s...done"
+ decoded-group decoded-new-name)
+ new-name)
+ (setq gnus-killed-list (delete group gnus-killed-list))
+ (gnus-set-active group nil)
+ (gnus-dribble-touch)
+ (gnus-group-position-point))))
(defun gnus-group-edit-group (group &optional part)
"Edit the group on the current line."
(defun gnus-group-make-useful-group (group method)
"Create one of the groups described in `gnus-useful-groups'."
(interactive
- (let ((entry (assoc (completing-read "Create group: " gnus-useful-groups
- nil t)
+ (let ((entry (assoc (gnus-completing-read "Create group"
+ (mapcar 'car gnus-useful-groups)
+ t)
gnus-useful-groups)))
- (list (cadr entry) (caddr entry))))
+ (list (cadr entry)
+ ;; Don't use `caddr' here since macros within the `interactive'
+ ;; form won't be expanded.
+ (car (cddr entry)))))
(setq method (gnus-copy-sequence method))
(let (entry)
(while (setq entry (memq (assq 'eval method) method))
(gnus-group-position-point))
(defun gnus-group-make-doc-group (file type)
- "Create a group that uses a single file as the source."
+ "Create a group that uses a single file as the source.
+
+If called with a prefix argument, ask for the file type."
(interactive
(list (read-file-name "File name: ")
(and current-prefix-arg 'ask)))
char found)
(while (not found)
(message
- "%sFile type (mbox, babyl, digest, forward, mmdf, guess) [mbdfag]: "
+ "%sFile type (mbox, babyl, digest, forward, mmdf, guess) [m, b, d, f, a, g]: "
err)
(setq found (cond ((= (setq char (read-char)) ?m) 'mbox)
((= char ?b) 'babyl)
(t (setq err (format "%c unknown. " char))
nil))))
(setq type found)))
- (let* ((file (expand-file-name file))
- (name (gnus-generate-new-group-name
+ (setq file (expand-file-name file))
+ (let* ((name (gnus-generate-new-group-name
(gnus-group-prefixed-name
- (file-name-nondirectory file) '(nndoc "")))))
+ (file-name-nondirectory file) '(nndoc ""))))
+ (method (list 'nndoc file
+ (list 'nndoc-address file)
+ (list 'nndoc-article-type (or type 'guess))))
+ (coding (gnus-group-name-charset method name)))
+ (setcar (cdr method) (mm-encode-coding-string file coding))
(gnus-group-make-group
- (gnus-group-real-name name)
- (list 'nndoc file
- (list 'nndoc-address file)
- (list 'nndoc-article-type (or type 'guess))))))
+ (mm-encode-coding-string (gnus-group-real-name name) coding)
+ method nil nil t)))
(defvar nnweb-type-definition)
(defvar gnus-group-web-type-history nil)
(symbol-name (caar nnweb-type-definition))))
(type
(gnus-string-or
- (completing-read
- (format "Search engine type (default %s): " default-type)
- (mapcar (lambda (elem) (list (symbol-name (car elem))))
+ (gnus-completing-read
+ "Search engine type"
+ (mapcar (lambda (elem) (symbol-name (car elem)))
nnweb-type-definition)
- nil t nil 'gnus-group-web-type-history)
+ t nil 'gnus-group-web-type-history)
default-type))
(search
(read-string
(nnweb-ephemeral-p t))))
(if solid
(progn
- (gnus-pull 'nnweb-ephemeral-p method)
+ (gnus-alist-pull 'nnweb-ephemeral-p method)
(gnus-group-make-group group method))
(gnus-group-read-ephemeral-group
group method t
(cons (current-buffer)
(if (eq major-mode 'gnus-summary-mode) 'summary 'group))))))
+(defvar nnrss-group-alist)
(eval-when-compile
- (defvar nnrss-group-alist)
(defun nnrss-discover-feed (arg))
(defun nnrss-save-server-data (arg)))
(defun gnus-group-make-rss-group (&optional url)
(setq url (read-from-minibuffer "URL to Search for RSS: ")))
(let ((feedinfo (nnrss-discover-feed url)))
(if feedinfo
- (let ((title (read-from-minibuffer "Title: "
- (cdr (assoc 'title
- feedinfo))))
- (desc (read-from-minibuffer "Description: "
- (cdr (assoc 'description
- feedinfo))))
- (href (cdr (assoc 'href feedinfo))))
- (push (list title href desc)
- nnrss-group-alist)
- (gnus-group-unsubscribe-group
- (concat "nnrss:" title))
+ (let* ((title (gnus-newsgroup-savable-name
+ (read-from-minibuffer "Title: "
+ (gnus-newsgroup-savable-name
+ (mapconcat
+ 'identity
+ (split-string
+ (or (cdr (assoc 'title
+ feedinfo))
+ ""))
+ " ")))))
+ (desc (read-from-minibuffer "Description: "
+ (mapconcat
+ 'identity
+ (split-string
+ (or (cdr (assoc 'description
+ feedinfo))
+ ""))
+ " ")))
+ (href (cdr (assoc 'href feedinfo)))
+ (coding (gnus-group-name-charset '(nnrss "") title)))
+ (when coding
+ ;; Unify non-ASCII text.
+ (setq title (mm-decode-coding-string
+ (mm-encode-coding-string title coding)
+ coding)))
+ (gnus-group-make-group title '(nnrss ""))
+ (push (list title href desc) nnrss-group-alist)
(nnrss-save-server-data nil))
(error "No feeds found for %s" url))))
-(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
- (if all "ding.archives" "ding.recent") '(nndir ""))))
- (when (gnus-group-entry group)
- (error "Archive group already exists"))
- (gnus-group-make-group
- (gnus-group-real-name group)
- (list 'nndir (if all "hpc" "edu")
- (list 'nndir-directory
- (if all gnus-group-archive-directory
- gnus-group-recent-archive-directory))))
- (gnus-group-add-parameter group (cons 'to-address "ding@gnus.org"))))
-
(defun gnus-group-make-directory-group (dir)
"Create an nndir group.
The user will be prompted for a directory. The contents of this
-directory will be used as a newsgroup. The directory should contain
+directory will be used as a newsgroup. The directory should contain
mail messages or news articles in files that have numeric names."
(interactive
(list (read-file-name "Create group from directory: ")))
(gnus-group-real-name group)
(list 'nndir (gnus-group-real-name group) (list 'nndir-directory dir)))))
-(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
-score file entries for articles to include in the group."
- (interactive
- (list
- (read-string "nnkiboze group name: ")
- (read-string "Source groups (regexp): ")
- (let ((headers (mapcar 'list
- '("subject" "from" "number" "date" "message-id"
- "references" "chars" "lines" "xref"
- "followup" "all" "body" "head")))
- scores header regexp regexps)
- (while (not (equal "" (setq header (completing-read
- "Match on header: " headers nil t))))
- (setq regexps nil)
- (while (not (equal "" (setq regexp (read-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)
- (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."
(interactive
(list current-prefix-arg
- (completing-read "Add to virtual group: " gnus-newsrc-hashtb nil t
- "nnvirtual:")))
+ (gnus-group-completing-read "Add to virtual group"
+ nil t "nnvirtual:")))
(unless (eq (car (gnus-find-method-for-group vgroup)) 'nnvirtual)
(error "%s is not an nnvirtual group" vgroup))
(gnus-close-group vgroup)
'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)
+(defun gnus-group-expunge-group (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))))
+ (let ((method (gnus-find-method-for-group group)))
+ (if (not (gnus-check-backend-function
+ 'request-expunge-group (car method)))
+ (error "%s does not support expunging" (car method))
+ (gnus-request-expunge-group group method))))
+
+(autoload 'nnimap-acl-get "nnimap")
+(autoload 'nnimap-acl-edit "nnimap")
(defun gnus-group-nnimap-edit-acl (group)
"Edit the Access Control List of current nnimap GROUP."
(defun gnus-group-sort-by-unread (info1 info2)
"Sort by number of unread articles."
(let ((n1 (gnus-group-unread (gnus-info-group info1)))
- (n2 (gnus-group-unread (gnus-info-group info1))))
+ (n2 (gnus-group-unread (gnus-info-group info2))))
(< (or (and (numberp n1) n1) 0)
(or (and (numberp n2) n2) 0))))
;;; Clearing data
(defun gnus-group-clear-data (&optional arg)
- "Clear all marks and read ranges from the current group."
+ "Clear all marks and read ranges from the current group.
+Obeys the process/prefix convention."
(interactive "P")
(gnus-group-iterate arg
(lambda (group)
"Do you really want to mark all articles in %s as read? "
"Mark all unread articles in %s as read? ")
(if (= (length groups) 1)
- (car groups)
+ (gnus-group-decoded-name (car groups))
(format "these %d groups" (length groups)))))))
n
(while (setq group (pop groups))
(when (eq 'nnvirtual (car method))
(nnvirtual-catchup-group
(gnus-group-real-name group) (nth 1 method) all)))
- (if (>= (gnus-group-level group) gnus-level-zombie)
- (gnus-message 2 "Dead groups can't be caught up")
- (if (prog1
- (gnus-group-goto-group group)
- (gnus-group-catchup group all))
- (gnus-group-update-group-line)
- (setq ret (1+ ret)))))
+ (cond
+ ((>= (gnus-group-level group) gnus-level-zombie)
+ (gnus-message 2 "Dead groups can't be caught up"))
+ ((prog1
+ (gnus-group-goto-group group)
+ (gnus-group-catchup group all))
+ (gnus-group-update-group-line))
+ (t
+ (setq ret (1+ ret)))))
(gnus-group-next-unread-group 1)
ret)))
(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-range-map (lambda (article)
- (gnus-add-marked-articles group 'expire (list article))
- (gnus-request-set-mark group (list (list (list article) 'add '(expire)))))
- unread))
+ (gnus-range-map
+ (lambda (article)
+ (gnus-add-marked-articles group 'expire (list article))
+ (gnus-request-set-mark group (list (list (list article)
+ 'add '(expire)))))
+ unread))
(let ((gnus-newsgroup-name group))
(gnus-run-hooks 'gnus-group-catchup-group-hook))
num)))
(defun gnus-group-expire-articles-1 (group)
(when (gnus-check-backend-function 'request-expire-articles group)
- (gnus-message 6 "Expiring articles in %s..." group)
+ (gnus-message 6 "Expiring articles in %s..."
+ (gnus-group-decoded-name group))
(let* ((info (gnus-get-info group))
(expirable (if (gnus-group-total-expirable-p group)
(cons nil (gnus-list-of-read-articles group))
(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"
+ (gnus-group-decoded-name group))
;; Return the list of un-expired articles.
(cdr expirable))))
(progn
(unless (gnus-group-process-prefix current-prefix-arg)
(error "No group on the current line"))
- (string-to-int
+ (string-to-number
(let ((s (read-string
(format "Level (default %s): "
(or (gnus-group-group-level)
s))))))
(unless (and (>= level 1) (<= level gnus-level-killed))
(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"
- group (or (gnus-group-group-level) gnus-level-killed)
- level)
- (gnus-group-change-level
- group level (or (gnus-group-group-level) gnus-level-killed))
- (gnus-group-update-group-line)))
+ (dolist (group (gnus-group-process-prefix n))
+ (gnus-group-remove-mark group)
+ (gnus-message 6 "Changed level of %s from %d to %d"
+ (gnus-group-decoded-name group)
+ (or (gnus-group-group-level) gnus-level-killed)
+ level)
+ (gnus-group-change-level
+ group level (or (gnus-group-group-level) gnus-level-killed))
+ (gnus-group-update-group-line))
(gnus-group-position-point))
(defun gnus-group-unsubscribe (&optional n)
"Toggle subscription to GROUP.
Killed newsgroups are subscribed. If SILENT, don't try to update the
group line."
- (interactive
- (list (completing-read
- "Group: " gnus-active-hashtb nil
- (gnus-read-active-file-p)
- nil
- 'gnus-group-history)))
+ (interactive (list (gnus-group-completing-read
+ nil nil (gnus-read-active-file-p))))
(let ((newsrc (gnus-group-entry group)))
(cond
((string-match "^[ \t]*$" group)
(defun gnus-group-transpose-groups (n)
"Move the current newsgroup up N places.
-If given a negative prefix, move down instead. The difference between
+If given a negative prefix, move down instead. The difference between
N and the number of steps taken is returned."
(interactive "p")
(unless (gnus-group-group-name)
gnus-list-of-killed-groups))
(gnus-group-change-level
(if entry entry group) gnus-level-killed (if entry nil level))
- (message "Killed group %s" group))
+ (message "Killed group %s" (gnus-group-decoded-name group)))
;; If there are lots and lots of groups to be killed, we use
;; this thing instead.
(dolist (group (nreverse groups))
(unless gnus-slave
(gnus-master-read-slave-newsrc))
- ;; We might read in new NoCeM messages here.
- (when (and gnus-use-nocem
- (null arg))
- (gnus-nocem-scan-groups))
- ;; If ARG is not a number, then we read the active file.
- (when (and arg (not (numberp arg)))
- (let ((gnus-read-active-file t))
- (gnus-read-active-file))
- (setq arg nil)
-
- ;; If the user wants it, we scan for new groups.
- (when (eq gnus-check-new-newsgroups 'always)
- (gnus-find-new-newsgroups)))
-
- (setq arg (gnus-group-default-level arg t))
- (if (and gnus-read-active-file (not arg))
- (progn
- (gnus-read-active-file)
- (gnus-get-unread-articles arg))
- (let ((gnus-read-active-file (if arg nil gnus-read-active-file)))
- (gnus-get-unread-articles arg)))
+ (gnus-get-unread-articles arg)
+
+ ;; If the user wants it, we scan for new groups.
+ (when (eq gnus-check-new-newsgroups 'always)
+ (gnus-find-new-newsgroups))
+
+ (gnus-check-reasonable-setup)
(gnus-run-hooks 'gnus-after-getting-new-news-hook)
(gnus-group-list-groups (and (numberp arg)
(max (car gnus-group-list-mode) arg)))))
(goto-char beg))
(when gnus-goto-next-group-when-activating
(gnus-group-next-unread-group 1 t))
- (gnus-summary-position-point)
+ (gnus-group-position-point)
ret))
-(defun gnus-group-fetch-faq (group &optional faq-dir)
- "Fetch the FAQ for the current group.
-If given a prefix argument, prompt for the FAQ dir
-to use."
- (interactive
- (list
- (gnus-group-group-name)
- (when current-prefix-arg
- (completing-read
- "FAQ dir: " (and (listp gnus-group-faq-directory)
- (mapcar #'list
- gnus-group-faq-directory))))))
- (unless group
- (error "No group name given"))
- (let ((dirs (or faq-dir gnus-group-faq-directory))
- dir found file)
- (unless (listp dirs)
- (setq dirs (list dirs)))
- (while (and (not found)
- (setq dir (pop dirs)))
- (let ((name (gnus-group-real-name group)))
- (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))
- (find-file file)
- (setq found t))))))
-
-(defun gnus-group-fetch-charter (group)
- "Fetch the charter for the current group.
-If given a prefix argument, prompt for a group."
- (interactive
- (list (or (when current-prefix-arg
- (completing-read "Group: " gnus-active-hashtb))
- (gnus-group-group-name)
- gnus-newsgroup-name)))
- (unless group
- (error "No group name given"))
- (require 'mm-url)
- (condition-case nil (require 'url-http) (error nil))
- (let ((name (mm-url-form-encode-xwfu (gnus-group-real-name group)))
- url hierarchy)
- (when (string-match "\\(^[^\\.]+\\)\\..*" name)
- (setq hierarchy (match-string 1 name))
- (if (and (setq url (cdr (assoc hierarchy gnus-group-charter-alist)))
- (if (fboundp 'url-http-file-exists-p)
- (url-http-file-exists-p (eval url))
- t))
- (browse-url (eval url))
- (setq url (concat "http://" hierarchy
- ".news-admin.org/charters/" name))
- (if (and (fboundp 'url-http-file-exists-p)
- (url-http-file-exists-p url))
- (browse-url url)
- (gnus-group-fetch-control group))))))
-
(defun gnus-group-fetch-control (group)
"Fetch the archived control messages for the current group.
If given a prefix argument, prompt for a group."
(interactive
(list (or (when current-prefix-arg
- (completing-read "Group: " gnus-active-hashtb))
+ (gnus-group-completing-read))
(gnus-group-group-name)
gnus-newsgroup-name)))
(unless group
(gnus-gethash mname gnus-description-hashtb))
(setq desc (gnus-group-get-description group))
(gnus-read-descriptions-file method))
- (gnus-message 1
+ (gnus-message 1 "%s"
(or desc (gnus-gethash group gnus-description-hashtb)
"No description available")))))
(interactive "P")
(setq gnus-current-kill-article article)
(gnus-kill-file-edit-file group)
- (gnus-message
- 6
- (substitute-command-keys
- (format "Editing a %s kill file (Type \\[gnus-kill-file-exit] to exit)"
- (if group "local" "global")))))
+ (gnus-message 6 "Editing a %s kill file (Type %s to exit)"
+ (if group "local" "global")
+ (substitute-command-keys "\\[gnus-kill-file-exit]")))
(defun gnus-group-edit-local-kill (article group)
"Edit a local kill file."
(gnus-offer-save-summaries)
;; Kill Gnus buffers except for group mode buffer.
(let ((group-buf (get-buffer gnus-group-buffer)))
- (mapcar (lambda (buf)
- (unless (or (member buf (list group-buf gnus-dribble-buffer))
- (with-current-buffer buf
- (eq major-mode 'message-mode)))
- (gnus-kill-buffer buf)))
- (gnus-buffers))
+ (dolist (buf (gnus-buffers))
+ (unless (or (eq buf group-buf)
+ (eq buf gnus-dribble-buffer)
+ (with-current-buffer buf
+ (eq major-mode 'message-mode)))
+ (gnus-kill-buffer buf)))
(setq gnus-backlog-articles nil)
(gnus-kill-gnus-frames)
(when group-buf
(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)
+ (not (zerop (with-current-buffer gnus-dribble-buffer
(buffer-size)))))
(gnus-dribble-enter
";;; Gnus was exited on purpose without saving the .newsrc files."))
(defun gnus-group-describe-briefly ()
"Give a one line description of the group mode commands."
(interactive)
- (gnus-message 7 (substitute-command-keys "\\<gnus-group-mode-map>\\[gnus-group-read-group]:Select \\[gnus-group-next-unread-group]:Forward \\[gnus-group-prev-unread-group]:Backward \\[gnus-group-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-group-describe-briefly]:This help")))
+ (gnus-message 7 "%s" (substitute-command-keys "\\<gnus-group-mode-map>\\[gnus-group-read-group]:Select \\[gnus-group-next-unread-group]:Forward \\[gnus-group-prev-unread-group]:Backward \\[gnus-group-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-group-describe-briefly]:This help")))
(defun gnus-group-browse-foreign-server (method)
"Browse a foreign news server.
If not, METHOD should be a list where the first element is the method
and the second element is the address."
(interactive
- (list (let ((how (completing-read
- "Which back end: "
- (append gnus-valid-select-methods gnus-server-alist)
- nil t (cons "nntp" 0) 'gnus-method-history)))
+ (list (let ((how (gnus-completing-read
+ "Which back end"
+ (mapcar 'car (append gnus-valid-select-methods
+ gnus-server-alist))
+ t (cons "nntp" 0) 'gnus-method-history)))
;; We either got a back end name or a virtual server name.
;; If the first, we also need an address.
(if (assoc how gnus-valid-select-methods)
(list (intern how)
;; Suggested by mapjph@bath.ac.uk.
- (completing-read
- "Address: "
- (mapcar 'list gnus-secondary-servers)))
+ (gnus-completing-read
+ "Address"
+ gnus-secondary-servers))
;; We got a server name.
how))))
(gnus-browse-foreign-server method))
(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
+ ;; 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)))
(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)
+ (with-current-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)
+ (with-current-buffer gnus-group-buffer
(if method
;; It's a foreign group...
(gnus-group-make-group
(if (stringp method) method
(prin1-to-string (car method)))
(and (consp method)
- (nth 1 (gnus-info-method info))))
+ (nth 1 (gnus-info-method info)))
+ nil t)
;; It's a native group.
- (gnus-group-make-group (gnus-info-group info))))
+ (gnus-group-make-group (gnus-info-group info) nil nil nil t)))
(gnus-message 6 "Note: New group created")
(setq entry
(gnus-group-entry (gnus-group-prefixed-name
"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))
+ (with-current-buffer (get-buffer buffer)
(gnus-summary-add-mark article mark))
(gnus-add-marked-articles group (cdr (assq mark gnus-article-mark-lists))
(list article)))))
(gnus-add-marked-articles
group 'expire (list article))))))
+
+;;;
+;;; Group compaction. -- dvl
+;;;
+
+(defun gnus-group-compact-group (group)
+ "Compact the current group.
+Compaction means removing gaps between article numbers. Hence, this
+operation is only meaningful for back ends using one file per article
+\(e.g. nnml).
+
+Note: currently only implemented in nnml."
+ (interactive (list (gnus-group-group-name)))
+ (unless group
+ (error "No group to compact"))
+ (unless (gnus-check-backend-function 'request-compact-group group)
+ (error "This back end does not support group compaction"))
+ (let ((group-decoded (gnus-group-decoded-name group)))
+ (gnus-message 6 "\
+Compacting group %s... (this may take a long time)"
+ group-decoded)
+ (prog1
+ (if (not (gnus-request-compact-group group))
+ (gnus-error 3 "Couldn't compact group %s" group-decoded)
+ (gnus-message 6 "Compacting group %s...done" group-decoded)
+ t)
+ ;; Invalidate the "original article" buffer which might be out of date.
+ ;; #### NOTE: Yes, this might be a bit rude, but since compaction
+ ;; #### will not happen very often, I think this is acceptable.
+ (let ((original (get-buffer gnus-original-article-buffer)))
+ (and original (gnus-kill-buffer original)))
+ ;; Update the group line to reflect new information (art number etc).
+ (gnus-group-update-group-line))))
+
(provide 'gnus-group)
-;;; arch-tag: 2eb5440f-0bca-4091-814c-e37817536af6
;;; gnus-group.el ends here
projects / gnus / blobdiff