;;; 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 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
(require 'time-date)
(require 'gnus-ems)
-(eval-when-compile
+(eval-when-compile
(require 'mm-url)
(let ((features (cons 'gnus-group features)))
(require 'gnus-sum))
(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
: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
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 "21.4"
+ :version "22.1"
:group 'gnus-group-various
:type '(choice (string :tag "Prompt string")
(const :tag "Empty" nil)
"r" gnus-group-rename-group
"R" gnus-group-make-rss-group
"c" gnus-group-customize
+ "z" gnus-group-compact-group
"x" gnus-group-nnimap-expunge
"\177" gnus-group-delete-group
[delete] gnus-group-delete-group)
(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))
(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
(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
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 "21.4"
+ :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 "21.4"
+ :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
(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
(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)
;;; 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)
(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)
(gnus-add-marked-articles
group 'expire (list article))))))
+
+;;;
+;;; Group compaction. -- dvl
+;;;
+
+(defun gnus-group-compact-group (group)
+ "Conpact 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
projects / gnus / blobdiff