;;; gnus-group.el --- group mode commands for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
(autoload 'gnus-agent-total-fetched-for "gnus-agent")
(autoload 'gnus-cache-total-fetched-for "gnus-cache")
+(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-start
:type 'boolean)
(defcustom gnus-group-default-list-level gnus-level-subscribed
- "*Default listing level.
+ "Default listing level.
Ignored if `gnus-group-use-permanent-levels' is non-nil."
:group 'gnus-group-listing
- :type 'integer)
+ :type '(choice (integer :tag "Level")
+ (function :tag "Function returning level")))
(defcustom gnus-group-list-inactive-groups t
"*If non-nil, inactive groups will be listed."
"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
"M" gnus-group-list-all-matching
"l" gnus-group-list-level
"c" gnus-group-list-cached
- "?" gnus-group-list-dormant)
+ "?" gnus-group-list-dormant
+ "!" gnus-group-list-ticked)
(gnus-define-keys (gnus-group-list-limit-map "/" gnus-group-list-map)
"k" gnus-group-list-limit
"e" gnus-score-edit-all-score)
(gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map)
- "C" gnus-group-fetch-control
"d" gnus-group-describe-group
"v" gnus-version)
["Describe" gnus-group-describe-group :active (gnus-group-group-name)
,@(if (featurep 'xemacs) nil
'(:help "Display description of the current group"))]
- ["Fetch control message" gnus-group-fetch-control
- :active (gnus-group-group-name)
- ,@(if (featurep 'xemacs) nil
- '(:help "Display the archived control message for the current group"))]
;; Actually one should check, if any of the marked groups gives t for
;; (gnus-check-backend-function 'request-expire-articles ...)
["Expire articles" gnus-group-expire-articles
["List all groups matching..." gnus-group-list-all-matching 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])
+ ["List groups with dormant" gnus-group-list-dormant t]
+ ["List groups with ticked" gnus-group-list-ticked t])
("Sort"
["Default sort" gnus-group-sort-groups t]
["Sort by method" gnus-group-sort-groups-by-method t]
["Add the help group" gnus-group-make-help-group t]
["Make a doc group..." gnus-group-make-doc-group t]
["Make a web group..." gnus-group-make-web-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]
(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
+ (display-graphic-p)
(or (not gnus-group-tool-bar-map) force))
(let* ((load-path
(gmm-image-load-path-for-library "gnus"
(mouse-set-point e)
(gnus-group-read-group nil))
+(defun gnus-group-default-list-level ()
+ "Return the real value for `gnus-group-default-list-level'."
+ (if (functionp gnus-group-default-list-level)
+ (funcall gnus-group-default-list-level)
+ gnus-group-default-list-level))
+
;; Look at LEVEL and find out what the level is really supposed to be.
;; If LEVEL is non-nil, LEVEL will be returned, if not, what happens
;; will depend on whether `gnus-group-use-permanent-levels' is used.
(or (setq gnus-group-use-permanent-levels
(or level (if (numberp gnus-group-use-permanent-levels)
gnus-group-use-permanent-levels
- (or gnus-group-default-list-level
+ (or (gnus-group-default-list-level)
gnus-level-subscribed))))
- gnus-group-default-list-level gnus-level-subscribed))
+ (gnus-group-default-list-level) gnus-level-subscribed))
(number-or-nil
level)
(t
- (or level gnus-group-default-list-level gnus-level-subscribed))))
+ (or level (gnus-group-default-list-level) gnus-level-subscribed))))
(defun gnus-group-setup-buffer ()
(set-buffer (gnus-get-buffer-create gnus-group-buffer))
(prefix-numeric-value current-prefix-arg)
(or
(gnus-group-default-level nil t)
- gnus-group-default-list-level
+ (gnus-group-default-list-level)
gnus-level-subscribed))))
(unless level
(setq level (car gnus-group-list-mode)
(gnus-dribble-enter
(concat "(gnus-group-set-info '"
(gnus-prin1-to-string (nth 2 entry))
- ")")))
+ ")")
+ (concat "^(gnus-group-set-info '(\"" (regexp-quote group) "\"")))
(setq gnus-group-indentation (gnus-group-group-indentation))
(gnus-delete-line)
(gnus-group-insert-group-line-info group)
(when (inline (gnus-visual-p 'group-highlight 'highlight))
(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)))
+ (forward-line)))
(defun gnus-group-update-eval-form (group list)
"Eval `car' of each element of LIST, and return the first that return t.
" "))
" "))
-(defun gnus-group-update-group (group &optional visible-only)
+
+(defun gnus-group-refresh-group (group)
+ (gnus-activate-group group)
+ (gnus-get-unread-articles-in-group (gnus-get-info group)
+ (gnus-active group))
+ (gnus-group-update-group group))
+
+(defun gnus-group-update-group (group &optional visible-only
+ info-unchanged)
"Update all lines where GROUP appear.
If VISIBLE-ONLY is non-nil, the group won't be displayed if it isn't
-already."
+already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated."
(with-current-buffer gnus-group-buffer
(save-excursion
;; The buffer may be narrowed.
(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))
- ")"))))
+ (unless info-unchanged
+ ;; 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))
+ ")")
+ (concat "^(gnus-group-set-info '(\""
+ (regexp-quote group) "\"")))))
;; Find all group instances. If topics are in use, each group
;; may be listed in more than once.
(while (setq loc (text-property-any
(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)
require-match initial-input
(or hist 'gnus-group-history)
def))
- (if (if (listp collection)
- (member group (mapcar 'symbol-name collection))
- (symbol-value (intern-soft group collection)))
- group
- (mm-encode-coding-string group (gnus-group-name-charset nil group)))))
+ (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))))
+ (gnus-replace-in-string group "\n" "")))
;;;###autoload
(defun gnus-fetch-group (group &optional articles)
(list
;; (gnus-read-group "Group name: ")
(gnus-group-completing-read)
- (gnus-read-method "From method: ")))
+ (gnus-read-method "From method")))
;; Transform the select method into a unique server.
(when (stringp method)
(setq method (gnus-server-to-method method)))
gnus-fetch-old-ephemeral-headers))
(gnus-group-read-group (or number t) t group select-articles))
group)
- ;;(error nil)
(quit
- (message "Quit reading the ephemeral group")
+ (if debug-on-quit
+ (debug "Quit")
+ (message "Quit reading the ephemeral group"))
nil)))))
(defcustom gnus-gmane-group-download-format
(gnus-read-ephemeral-gmane-group group start range)))
(defcustom gnus-bug-group-download-format-alist
- '((emacs . "http://debbugs.gnu.org/%s;mbox=yes")
+ '((emacs . "http://debbugs.gnu.org/%s;mboxstat=yes")
(debian
- . "http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=%s&mbox=yes"))
+ . "http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=%s&mbox=yes;mboxmaint=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
+ ;; Added mboxmaint=yes. This gets the version with the messages as
+ ;; they went out, not as they came in.
+ ;; Eg bug-gnu-emacs is replaced by ###@debbugs.
+ :version "24.1"
:type '(repeat (cons (symbol) (string :tag "URL format string"))))
-(defun gnus-read-ephemeral-bug-group (number mbox-url)
+(defun gnus-read-ephemeral-bug-group (ids mbox-url &optional window-conf)
"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-")))
+ (when (stringp ids)
+ (setq ids (string-to-number ids)))
+ (unless (listp ids)
+ (setq ids (list ids)))
+ (let ((tmpfile (mm-make-temp-file "gnus-temp-group-"))
+ (coding-system-for-write 'binary)
+ (coding-system-for-read 'binary))
(with-temp-file tmpfile
- (url-insert-file-contents (format mbox-url number))
+ (dolist (id ids)
+ (url-insert-file-contents (format mbox-url id)))
(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)))))
+ (insert (format ", %s@%s" (car ids)
+ (gnus-replace-in-string
+ (gnus-replace-in-string mbox-url "^http://" "")
+ "/.*$" ""))))
(write-region (point-min) (point-max) tmpfile)
(gnus-group-read-ephemeral-group
"gnus-read-ephemeral-bug"
`(nndoc ,tmpfile
- (nndoc-article-type mbox))))
+ (nndoc-article-type mbox))
+ nil window-conf))
(delete-file tmpfile)))
(defun gnus-read-ephemeral-debian-bug-group (number)
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)))
+(defun gnus-read-ephemeral-emacs-bug-group (ids &optional window-conf)
+ "Browse Emacs bugs IDS as an ephemeral group."
+ (interactive (list (string-to-number
+ (read-string "Enter bug number: "
+ (thing-at-point 'word) nil))))
+ (unless (listp ids)
+ (setq ids (list ids)))
(gnus-read-ephemeral-bug-group
- number
- (cdr (assoc 'emacs gnus-bug-group-download-format-alist))))
+ ids
+ (cdr (assoc 'emacs gnus-bug-group-download-format-alist))
+ window-conf)
+ (when (boundp 'debbugs-summary-mode)
+ (with-current-buffer (window-buffer (selected-window))
+ (debbugs-summary-mode 1)
+ (set (make-local-variable 'debbugs-bug-number) (car ids)))))
(defun gnus-group-jump-to-group (group &optional prompt)
"Jump to newsgroup GROUP.
`gnus-group-jump-to-group-prompt'."
(interactive
(list (gnus-group-completing-read
- nil nil (gnus-read-active-file-p)
+ nil nil nil
(if current-prefix-arg
(cdr (assq current-prefix-arg gnus-group-jump-to-group-prompt))
(or (and (stringp gnus-group-jump-to-group-prompt)
(interactive
(list
(gnus-read-group "Group name: ")
- (gnus-read-method "From method: ")))
+ (gnus-read-method "From method")))
(when (stringp method)
(setq method (or (gnus-server-to-method method) method)))
(unless (gnus-ephemeral-group-p name)
(gnus-dribble-enter
(concat "(gnus-group-set-info '"
- (gnus-prin1-to-string (cdr info)) ")")))
+ (gnus-prin1-to-string (cdr info)) ")")
+ (concat "^(gnus-group-set-info '(\"" (regexp-quote name) "\"")))
;; Insert the line.
(gnus-group-insert-group-line-info nname)
(forward-line -1)
(lambda (group)
(gnus-group-delete-group group nil t))))))
+(defun gnus-group-delete-articles (group)
+ "Delete all articles in the current group."
+ (interactive (list (gnus-group-group-name)))
+ (let ((articles (gnus-uncompress-range (gnus-active group))))
+ (when (gnus-yes-or-no-p
+ (format "Do you really want to delete these %d articles forever? "
+ (length articles)))
+ (gnus-request-expire-articles articles group 'force))))
+
(defun gnus-group-delete-group (group &optional force no-prompt)
"Delete the current group. Only meaningful with editable groups.
If FORCE (the prefix) is non-nil, all the articles in the group will
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: ")))
+ (list (read-directory-name "Create group from directory: ")))
(unless (file-exists-p dir)
(error "No such directory"))
(unless (file-directory-p dir)
(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)
+ (when (and (gnus-group-auto-expirable-p group)
+ (not (gnus-group-read-only-p group)))
(gnus-range-map
(lambda (article)
(gnus-add-marked-articles group 'expire (list article))
gnus-list-of-killed-groups))
(gnus-group-change-level
(if entry entry group) gnus-level-killed (if entry nil level))
+ (when (numberp (gnus-group-unread group))
+ (gnus-request-update-group-status group 'unsubscribe))
(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.
(setq gnus-zombie-list (delete group gnus-zombie-list))))
;; There may be more than one instance displayed.
(while (gnus-group-goto-group group)
- (gnus-delete-line)))
+ (gnus-delete-line))
+ (when (numberp (gnus-group-unread group))
+ (gnus-request-update-group-status group 'unsubscribe)))
(gnus-make-hashtable-from-newsrc-alist))
(gnus-group-position-point)
(and prev (gnus-group-entry prev))
t)
(gnus-group-insert-group-line-info group)
+ (gnus-request-update-group-status group 'subscribe)
(gnus-undo-register
`(when (gnus-group-goto-group ,group)
(gnus-group-kill-group 1))))
(let* ((groups (gnus-group-process-prefix n))
(ret (if (numberp n) (- n (length groups)) 0))
(beg (unless n
- (point)))
+ (point-marker)))
group method
(gnus-inhibit-demon t)
;; Binding this variable will inhibit multiple fetchings
(when gnus-agent
(gnus-agent-save-group-info
method (gnus-group-real-name group) active))
- (gnus-group-update-group group))
+ (gnus-group-update-group group nil t))
(if (eq (gnus-server-status (gnus-find-method-for-group group))
'denied)
(gnus-error 3 "Server denied access")
(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-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
- (gnus-group-completing-read))
- (gnus-group-group-name)
- gnus-newsgroup-name)))
- (unless group
- (error "No group name given"))
- (let ((name (gnus-group-real-name group))
- hierarchy)
- (when (string-match "\\(^[^\\.]+\\)\\..*" name)
- (setq hierarchy (match-string 1 name))
- (if gnus-group-fetch-control-use-browse-url
- (browse-url (concat "ftp://ftp.isc.org/usenet/control/"
- hierarchy "/" name ".gz"))
- (let ((enable-local-variables nil))
- (gnus-group-read-ephemeral-group
- group
- `(nndoc ,group (nndoc-address
- ,(find-file-noselect
- (concat "/ftp@ftp.isc.org:/usenet/control/"
- hierarchy "/" name ".gz")))
- (nndoc-article-type mbox)) t nil nil))))))
-
(defun gnus-group-describe-group (force &optional group)
"Display a description of the current newsgroup."
(interactive (list current-prefix-arg (gnus-group-group-name)))
With 2 C-u's, use most complete method possible to query the server
for new groups, and subscribe the new groups as zombies."
(interactive "p")
- (gnus-find-new-newsgroups (or arg 1))
- (gnus-group-list-groups))
+ (let ((new-groups (gnus-find-new-newsgroups (or arg 1)))
+ current-group)
+ (gnus-group-list-groups)
+ (setq current-group (gnus-group-group-name))
+ (dolist (group new-groups)
+ (gnus-group-jump-to-group group))
+ (when current-group
+ (gnus-group-jump-to-group current-group))))
(defun gnus-group-edit-global-kill (&optional article group)
"Edit the global kill file.
(defun gnus-group-set-params-info (group params)
(gnus-group-set-info params group 'params))
+;; Ad-hoc function for inserting data from a different newsrc.eld
+;; file. Use with caution, if at all.
+(defun gnus-import-other-newsrc-file (file)
+ (with-temp-buffer
+ (insert-file-contents file)
+ (let (form)
+ (while (ignore-errors
+ (setq form (read (current-buffer))))
+ (when (and (consp form)
+ (eq (cadr form) 'gnus-newsrc-alist))
+ (let ((infos (cadr (nth 2 form))))
+ (dolist (info infos)
+ (when (gnus-get-info (car info))
+ (gnus-set-info (car info) info)))))))))
+
(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
(goto-char (point-min))
(gnus-group-position-point))
+(defun gnus-group-list-ticked (level &optional lowest)
+ "List all groups with ticked 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 'tick 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)
(push n gnus-newsgroup-unselected))
(setq n (1+ n)))
(setq gnus-newsgroup-unselected
- (nreverse gnus-newsgroup-unselected)))))
+ (sort gnus-newsgroup-unselected '<)))))
(gnus-activate-group group)
(gnus-group-make-articles-read group (list article))
- (when (gnus-group-auto-expirable-p group)
+ (when (and (gnus-group-auto-expirable-p group)
+ (not (gnus-group-read-only-p group)))
(gnus-add-marked-articles
group 'expire (list article))))))