;;; gnus-group.el --- group mode commands for Gnus
-;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
+;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
(require 'gnus-range)
(require 'gnus-win)
(require 'gnus-undo)
+(require 'time-date)
(defcustom gnus-group-archive-directory
"*ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/"
:group 'gnus-group-foreign
:type 'directory)
-(defcustom gnus-no-groups-message "No news is no news"
+(defcustom gnus-no-groups-message "No gnus is bad news"
"*Message displayed by Gnus when no groups are available."
:group 'gnus-start
:type 'string)
If nil, no groups are permanently visible."
:group 'gnus-group-listing
- :type 'regexp)
+ :type '(choice regexp (const nil)))
(defcustom gnus-list-groups-with-ticked-articles t
"*If non-nil, list groups that have only ticked articles.
gnus-group-news-3-empty-face)
((and (not mailp) (eq level 3)) .
gnus-group-news-3-face)
+ ((and (= unread 0) (not mailp) (eq level 4)) .
+ gnus-group-news-4-empty-face)
+ ((and (not mailp) (eq level 4)) .
+ gnus-group-news-4-face)
+ ((and (= unread 0) (not mailp) (eq level 5)) .
+ gnus-group-news-5-empty-face)
+ ((and (not mailp) (eq level 5)) .
+ gnus-group-news-5-face)
+ ((and (= unread 0) (not mailp) (eq level 6)) .
+ gnus-group-news-6-empty-face)
+ ((and (not mailp) (eq level 6)) .
+ gnus-group-news-6-face)
((and (= unread 0) (not mailp)) .
gnus-group-news-low-empty-face)
((and (not mailp)) .
((= unread 0) .
gnus-group-mail-low-empty-face)
(t .
- gnus-group-mail-low-face))
+ gnus-group-mail-low-face))
"*Controls the highlighting of group buffer lines.
Below is a list of `Form'/`Face' pairs. When deciding how a a
"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
"e" gnus-group-edit-group-method
"w" gnus-group-make-web-group
"r" gnus-group-rename-group
"c" gnus-group-customize
+ "x" gnus-group-nnimap-expunge
"\177" gnus-group-delete-group
[delete] gnus-group-delete-group)
["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 bug report" gnus-bug t]
["Send a mail" gnus-group-mail t]
["Post an article..." gnus-group-post-news t]
["Check for new news" gnus-group-get-new-news t]
(gnus-group-set-mode-line)
(setq mode-line-process nil)
(use-local-map gnus-group-mode-map)
- (buffer-disable-undo (current-buffer))
+ (buffer-disable-undo)
(setq truncate-lines t)
(setq buffer-read-only t)
(gnus-set-default-directory)
(gnus-update-format-specifications nil 'group 'group-mode)
(gnus-update-group-mark-positions)
- (make-local-hook 'post-command-hook)
- (add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t)
(when gnus-use-undo
(gnus-undo-mode 1))
+ (when gnus-slave
+ (gnus-slave-mode))
(gnus-run-hooks 'gnus-group-mode-hook))
(defun gnus-update-group-mark-positions ()
(list (cons 'process (and (search-forward "\200" nil t)
(- (point) 2))))))))
-(defun gnus-clear-inboxes-moved ()
- (setq nnmail-moved-inboxes nil))
-
(defun gnus-mouse-pick-group (e)
"Enter the group under the mouse pointer."
(interactive "e")
(or level gnus-group-default-list-level gnus-level-subscribed))))
(defun gnus-group-setup-buffer ()
- (set-buffer (get-buffer-create gnus-group-buffer))
+ (set-buffer (gnus-get-buffer-create gnus-group-buffer))
(unless (eq major-mode 'gnus-group-mode)
- (gnus-add-current-to-buffer-list)
(gnus-group-mode)
(when gnus-carpal
(gnus-carpal-setup-buffer 'group))))
(gnus-group-default-level nil t)
gnus-group-default-list-level
gnus-level-subscribed))))
- ;; Just do this here, for no particular good reason.
- (gnus-clear-inboxes-moved)
(unless level
(setq level (car gnus-group-list-mode)
unread (cdr gnus-group-list-mode)))
params (gnus-info-params info)
newsrc (cdr newsrc)
unread (car (gnus-gethash group gnus-newsrc-hashtb)))
- (and unread ; This group might be bogus
+ (and unread ; This group might be unchecked
(or (not regexp)
(string-match regexp group))
(<= (setq clevel (gnus-info-level info)) level)
found buffer-read-only)
;; Enter the current status into the dribble buffer.
(let ((entry (gnus-gethash group gnus-newsrc-hashtb)))
- (when (and entry (not (gnus-ephemeral-group-p 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))
(beginning-of-line)
(forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2))
(subst-char-in-region
- (point) (1+ (point)) (following-char)
+ (point) (1+ (point)) (char-after)
(if unmark
(progn
(setq gnus-group-marked (delete group gnus-group-marked))
(save-selected-window
(save-excursion
(funcall ,function ,group)))))))))
-
+
(put 'gnus-group-iterate 'lisp-indent-function 1)
;; Selecting groups.
(gnus-no-server))
(gnus-group-read-group nil nil group))
+;;;###autoload
+(defun gnus-fetch-group-other-frame (group)
+ "Pop up a frame and enter GROUP."
+ (interactive "P")
+ (let ((window (get-buffer-window gnus-group-buffer)))
+ (cond (window
+ (select-frame (window-frame window)))
+ ((= (length (frame-list)) 1)
+ (select-frame (make-frame)))
+ (t
+ (other-frame 1))))
+ (gnus-fetch-group group))
+
(defvar gnus-ephemeral-group-server 0)
;; Enter a group that is not in the group buffer. Non-nil is returned
If REQUEST-ONLY, don't actually read the group; just request it.
If SELECT-ARTICLES, only select those articles.
-Return the name of the group is selection was successful."
+Return the name of the group if selection was successful."
;; Transform the select method into a unique server.
(when (stringp method)
(setq method (gnus-server-to-method method)))
(gnus-read-group "Group name: ")
(gnus-read-method "From method: ")))
- (let* ((meth (when (and method
- (not (gnus-server-equal method gnus-select-method)))
- (if address (list (intern method) address)
- method)))
+ (when (stringp method)
+ (setq method (or (gnus-server-to-method method) method)))
+ (let* ((meth (gnus-method-simplify
+ (when (and method
+ (not (gnus-server-equal method gnus-select-method)))
+ (if address (list (intern method) address)
+ method))))
(nname (if method (gnus-group-prefixed-name name meth) name))
backend info)
(when (gnus-gethash nname gnus-newsrc-hashtb)
(gnus-request-create-group nname nil args))
t))
-(defun gnus-group-delete-group (group &optional force)
- "Delete the current group. Only meaningful with mail groups.
+(defun gnus-group-delete-groups (&optional arg)
+ "Delete the current group. Only meaningful with editable groups."
+ (interactive "P")
+ (let ((n (length (gnus-group-process-prefix arg))))
+ (when (gnus-yes-or-no-p
+ (if (= n 1)
+ "Delete this 1 group? "
+ (format "Delete these %d groups? " n)))
+ (gnus-group-iterate arg
+ (lambda (group)
+ (gnus-group-delete-group group nil t))))))
+
+(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
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
(unless (gnus-check-backend-function 'request-delete-group group)
(error "This backend does not support group deletion"))
(prog1
- (if (not (gnus-yes-or-no-p
- (format
- "Do you really want to delete %s%s? "
- group (if force " and all its contents" ""))))
+ (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-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)))
(gnus-group-position-point)))
(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)
"Create the Gnus documentation group."
(interactive)
(let ((name (gnus-group-prefixed-name "gnus-help" '(nndoc "gnus-help")))
- (file (nnheader-find-etc-directory "gnus-tut.txt" t))
- dir)
+ (file (nnheader-find-etc-directory "gnus-tut.txt" t)))
(when (gnus-gethash name gnus-newsrc-hashtb)
(error "Documentation group already exists"))
(if (not file)
((= char ?d) 'digest)
((= char ?f) 'forward)
((= char ?a) 'mmfd)
+ ((= char ?g) 'guess)
(t (setq err (format "%c unknown. " char))
nil))))
(setq type found)))
(cons (current-buffer)
(if (eq major-mode 'gnus-summary-mode) 'summary 'group))))))
+(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."
(push (cons header regexps) scores))
scores)))
(gnus-group-make-group group "nnkiboze" address)
- (nnheader-temp-write (gnus-score-file-name (concat "nnkiboze:" group))
+ (with-temp-file (gnus-score-file-name (concat "nnkiboze:" group))
(let (emacs-lisp-mode-hook)
(pp scores (current-buffer)))))
'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)
+ "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))))
+
+(defun gnus-group-nnimap-edit-acl (group)
+ "Edit the Access Control List of current nnimap GROUP."
+ (interactive (list (gnus-group-group-name)))
+ (let ((mailbox (gnus-group-real-name group)) method acl)
+ (unless group
+ (error "No group on current line"))
+ (unless (gnus-get-info group)
+ (error "Killed group; can't be edited"))
+ (unless (eq (car (setq method (gnus-find-method-for-group group))) 'nnimap)
+ (error "%s is not an nnimap group" group))
+ (gnus-edit-form (setq acl (nnimap-acl-get mailbox (cadr method)))
+ (format "Editing the access control list for `%s'.
+
+ An access control list is a list of (identifier . rights) elements.
+
+ The identifier string specifies the corresponding user. The
+ identifier \"anyone\" is reserved to refer to the universal identity.
+
+ Rights is a string listing a (possibly empty) set of alphanumeric
+ characters, each character listing a set of operations which is being
+ controlled. Letters are reserved for ``standard'' rights, listed
+ below. Digits are reserved for implementation or site defined rights.
+
+ l - lookup (mailbox is visible to LIST/LSUB commands)
+ r - read (SELECT the mailbox, perform CHECK, FETCH, PARTIAL,
+ SEARCH, COPY from mailbox)
+ s - keep seen/unseen information across sessions (STORE SEEN flag)
+ w - write (STORE flags other than SEEN and DELETED)
+ i - insert (perform APPEND, COPY into mailbox)
+ p - post (send mail to submission address for mailbox,
+ not enforced by IMAP4 itself)
+ c - create (CREATE new sub-mailboxes in any implementation-defined
+ hierarchy)
+ d - delete (STORE DELETED flag, perform EXPUNGE)
+ a - administer (perform SETACL)" group)
+ `(lambda (form)
+ (nnimap-acl-edit
+ ,mailbox ',method ',acl form)))))
+
;; Group sorting commands
;; Suggested by Joe Hildebrand <hildjj@idaho.fuentez.com>.
;; Go through all the infos and replace the old entries
;; with the new infos.
(while infos
- (setcar entries (pop infos))
+ (setcar (car entries) (pop infos))
(pop entries))
;; Update the hashtable.
(gnus-make-hashtable-from-newsrc-alist)))
-(defun gnus-group-sort-selected-groups-by-alphabet (&optional reverse)
+(defun gnus-group-sort-selected-groups-by-alphabet (&optional n reverse)
"Sort the group buffer alphabetically by group name.
-If REVERSE, sort in reverse order."
- (interactive "P")
- (gnus-group-sort-selected-groups 'gnus-group-sort-by-alphabet reverse))
+Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
+sort in reverse order."
+ (interactive (gnus-interactive "P\ny"))
+ (gnus-group-sort-selected-groups n 'gnus-group-sort-by-alphabet reverse))
-(defun gnus-group-sort-selected-groups-by-unread (&optional reverse)
+(defun gnus-group-sort-selected-groups-by-unread (&optional n reverse)
"Sort the group buffer by number of unread articles.
-If REVERSE, sort in reverse order."
- (interactive "P")
- (gnus-group-sort-selected-groups 'gnus-group-sort-by-unread reverse))
+Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
+sort in reverse order."
+ (interactive (gnus-interactive "P\ny"))
+ (gnus-group-sort-selected-groups n 'gnus-group-sort-by-unread reverse))
-(defun gnus-group-sort-selected-groups-by-level (&optional reverse)
+(defun gnus-group-sort-selected-groups-by-level (&optional n reverse)
"Sort the group buffer by group level.
-If REVERSE, sort in reverse order."
- (interactive "P")
- (gnus-group-sort-selected-groups 'gnus-group-sort-by-level reverse))
+Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
+sort in reverse order."
+ (interactive (gnus-interactive "P\ny"))
+ (gnus-group-sort-selected-groups n 'gnus-group-sort-by-level reverse))
-(defun gnus-group-sort-selected-groups-by-score (&optional reverse)
+(defun gnus-group-sort-selected-groups-by-score (&optional n reverse)
"Sort the group buffer by group score.
-If REVERSE, sort in reverse order."
- (interactive "P")
- (gnus-group-sort-selected-groups 'gnus-group-sort-by-score reverse))
+Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
+sort in reverse order."
+ (interactive (gnus-interactive "P\ny"))
+ (gnus-group-sort-selected-groups n 'gnus-group-sort-by-score reverse))
-(defun gnus-group-sort-selected-groups-by-rank (&optional reverse)
+(defun gnus-group-sort-selected-groups-by-rank (&optional n reverse)
"Sort the group buffer by group rank.
-If REVERSE, sort in reverse order."
- (interactive "P")
- (gnus-group-sort-selected-groups 'gnus-group-sort-by-rank reverse))
+Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
+sort in reverse order."
+ (interactive (gnus-interactive "P\ny"))
+ (gnus-group-sort-selected-groups n 'gnus-group-sort-by-rank reverse))
-(defun gnus-group-sort-selected-groups-by-method (&optional reverse)
+(defun gnus-group-sort-selected-groups-by-method (&optional n reverse)
"Sort the group buffer alphabetically by backend name.
-If REVERSE, sort in reverse order."
- (interactive "P")
- (gnus-group-sort-selected-groups 'gnus-group-sort-by-method reverse))
+Obeys the process/prefix convention. If REVERSE (the symbolic prefix),
+sort in reverse order."
+ (interactive (gnus-interactive "P\ny"))
+ (gnus-group-sort-selected-groups n 'gnus-group-sort-by-method reverse))
;;; Sorting predicates.
(when (gnus-group-native-p (gnus-info-group info))
(gnus-info-clear-data info)))
(gnus-get-unread-articles)
- (gnus-dribble-enter "")
+ (gnus-dribble-touch)
(when (gnus-y-or-n-p
"Move the cache away to avoid problems in the future? ")
(call-interactively 'gnus-cache-move-cache)))))
up is returned."
(interactive "P")
(let ((groups (gnus-group-process-prefix n))
- (ret 0))
+ (ret 0)
+ group)
(unless groups (error "No groups selected"))
(if (not
(or (not gnus-interactive-catchup) ;Without confirmation?
(car groups)
(format "these %d groups" (length groups)))))))
n
- (while groups
+ (while (setq group (pop groups))
+ (gnus-group-remove-mark group)
;; Virtual groups have to be given special treatment.
- (let ((method (gnus-find-method-for-group (car groups))))
+ (let ((method (gnus-find-method-for-group group)))
(when (eq 'nnvirtual (car method))
(nnvirtual-catchup-group
- (gnus-group-real-name (car groups)) (nth 1 method) all)))
- (gnus-group-remove-mark (car groups))
- (if (>= (gnus-group-group-level) gnus-level-zombie)
+ (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 (car groups))
- (gnus-group-catchup (car groups) all))
+ (gnus-group-goto-group group)
+ (gnus-group-catchup group all))
(gnus-group-update-group-line)
- (setq ret (1+ ret))))
- (setq groups (cdr groups)))
+ (setq ret (1+ ret)))))
(gnus-group-next-unread-group 1)
ret)))
(error "No groups to expire"))
(while (setq group (pop groups))
(gnus-group-remove-mark group)
- (when (gnus-check-backend-function 'request-expire-articles group)
- (gnus-message 6 "Expiring articles in %s..." group)
- (let* ((info (gnus-get-info group))
- (expirable (if (gnus-group-total-expirable-p group)
- (cons nil (gnus-list-of-read-articles group))
- (assq 'expire (gnus-info-marks info))))
- (expiry-wait (gnus-group-find-parameter group 'expiry-wait)))
- (when expirable
- (setcdr
- expirable
- (gnus-compress-sequence
- (if expiry-wait
- ;; We set the expiry variables to the group
- ;; parameter.
- (let ((nnmail-expiry-wait-function nil)
- (nnmail-expiry-wait expiry-wait))
- (gnus-request-expire-articles
- (gnus-uncompress-sequence (cdr expirable)) group))
- ;; Just expire using the normal expiry values.
- (gnus-request-expire-articles
- (gnus-uncompress-sequence (cdr expirable)) group))))
- (gnus-close-group group))
- (gnus-message 6 "Expiring articles in %s...done" group)))
+ (gnus-group-expire-articles-1 group)
(gnus-dribble-touch)
(gnus-group-position-point))))
+(defun gnus-group-expire-articles-1 (group)
+ (when (gnus-check-backend-function 'request-expire-articles group)
+ (gnus-message 6 "Expiring articles in %s..." group)
+ (let* ((info (gnus-get-info group))
+ (expirable (if (gnus-group-total-expirable-p group)
+ (cons nil (gnus-list-of-read-articles group))
+ (assq 'expire (gnus-info-marks info))))
+ (expiry-wait (gnus-group-find-parameter group 'expiry-wait)))
+ (when expirable
+ (setcdr
+ expirable
+ (gnus-compress-sequence
+ (if expiry-wait
+ ;; We set the expiry variables to the group
+ ;; parameter.
+ (let ((nnmail-expiry-wait-function nil)
+ (nnmail-expiry-wait expiry-wait))
+ (gnus-request-expire-articles
+ (gnus-uncompress-sequence (cdr expirable)) group))
+ ;; Just expire using the normal expiry values.
+ (gnus-request-expire-articles
+ (gnus-uncompress-sequence (cdr expirable)) group))))
+ (gnus-close-group group))
+ (gnus-message 6 "Expiring articles in %s...done" group))))
+
(defun gnus-group-expire-all-groups ()
"Expire all expirable articles in all newsgroups."
(interactive)
gnus-level-default-subscribed))
s)))))
(unless (and (>= level 1) (<= level gnus-level-killed))
- (error "Illegal level: %d" level))
+ (error "Invalid level: %d" level))
(let ((groups (gnus-group-process-prefix n))
group)
(while (setq group (pop groups))
(gnus-group-yank-group)
(gnus-group-position-point)))
-(defun gnus-group-kill-all-zombies ()
- "Kill all zombie newsgroups."
- (interactive)
- (setq gnus-killed-list (nconc gnus-zombie-list gnus-killed-list))
- (setq gnus-zombie-list nil)
- (gnus-dribble-touch)
- (gnus-group-list-groups))
+(defun gnus-group-kill-all-zombies (&optional dummy)
+ "Kill all zombie newsgroups.
+The optional DUMMY should always be nil."
+ (interactive (list (not (gnus-yes-or-no-p "Really kill all zombies? "))))
+ (unless dummy
+ (setq gnus-killed-list (nconc gnus-zombie-list gnus-killed-list))
+ (setq gnus-zombie-list nil)
+ (gnus-dribble-touch)
+ (gnus-group-list-groups)))
(defun gnus-group-kill-region (begin end)
"Kill newsgroups in current region (excluding current point).
(push (cons (car entry) (nth 2 entry))
gnus-list-of-killed-groups))
(gnus-group-change-level
- (if entry entry group) gnus-level-killed (if entry nil level)))
+ (if entry entry group) gnus-level-killed (if entry nil level))
+ (message "Killed group %s" group))
;; If there are lots and lots of groups to be killed, we use
;; this thing instead.
(let (entry)
(gnus-make-hashtable-from-newsrc-alist)
(gnus-group-list-groups)))
(t
- (error "Can't kill; illegal level: %d" level))))
+ (error "Can't kill; invalid level: %d" level))))
(defun gnus-group-list-all-groups (&optional arg)
"List all newsgroups with level ARG or lower.
(interactive)
;; First we make sure that we have really read the active file.
(unless (gnus-read-active-file-p)
- (let ((gnus-read-active-file t))
+ (let ((gnus-read-active-file t)
+ (gnus-agent nil)) ; Trick the agent into ignoring the active file.
(gnus-read-active-file)))
;; Find all groups and sort them.
(let ((groups
re-scanning. If ARG is non-nil and not a number, this will force
\"hard\" re-reading of the active files from all servers."
(interactive "P")
- (let ((gnus-inhibit-demon t))
+ (require 'nnmail)
+ (let ((gnus-inhibit-demon t)
+ ;; Binding this variable will inhibit multiple fetchings
+ ;; of the same mail source.
+ (nnmail-fetched-sources (list t)))
(gnus-run-hooks 'gnus-get-new-news-hook)
;; Read any slave files.
(ret (if (numberp n) (- n (length groups)) 0))
(beg (unless n
(point)))
- group)
+ group method
+ (gnus-inhibit-demon t)
+ ;; Binding this variable will inhibit multiple fetchings
+ ;; of the same mail source.
+ (nnmail-fetched-sources (list t)))
+ (gnus-run-hooks 'gnus-get-new-news-hook)
(while (setq group (pop groups))
(gnus-group-remove-mark group)
;; Bypass any previous denials from the server.
- (gnus-remove-denial (gnus-find-method-for-group group))
+ (gnus-remove-denial (setq method (gnus-find-method-for-group group)))
(if (gnus-activate-group group (if dont-scan nil 'scan))
(progn
(gnus-get-unread-articles-in-group
(gnus-get-info group) (gnus-active group) t)
(unless (gnus-virtual-group-p group)
(gnus-close-group group))
+ (when gnus-agent
+ (gnus-agent-save-group-info
+ method (gnus-group-real-name group) (gnus-active group)))
(gnus-group-update-group group))
(if (eq (gnus-server-status (gnus-find-method-for-group group))
'denied)
(while (and (not found)
(setq dir (pop dirs)))
(let ((name (gnus-group-real-name group)))
- (while (string-match "\\." name)
- (setq name (replace-match "/" t t name)))
(setq file (concat (file-name-as-directory dir) name)))
(if (not (file-exists-p file))
(gnus-message 1 "No such file: %s" file)
(lambda (group)
(and (symbol-name group)
(string-match regexp (symbol-name group))
+ (symbol-value group)
(push (symbol-name group) groups)))
gnus-active-hashtb)
;; Also go through all descriptions that are known to Gnus.
(mapatoms
(lambda (group)
(and (string-match regexp (symbol-value group))
- (gnus-active (symbol-name group))
(push (symbol-name group) groups)))
gnus-description-hashtb))
(if (not groups)
;; Print out all the groups.
(save-excursion
(pop-to-buffer "*Gnus Help*")
- (buffer-disable-undo (current-buffer))
+ (buffer-disable-undo)
(erase-buffer)
(setq groups (sort groups 'string<))
(while groups
(defun gnus-group-find-new-groups (&optional arg)
"Search for new groups and add them.
Each new group will be treated with `gnus-subscribe-newsgroup-method.'
-If ARG (the prefix), use the `ask-server' method to query
-the server for new groups."
- (interactive "P")
- (gnus-find-new-newsgroups arg)
+With 1 C-u, use the `ask-server' method to query the server for new
+groups.
+With 2 C-u's, use most complete method possible to query the server
+for new groups, and subscribe the new groups as zombies."
+ (interactive "p")
+ (gnus-find-new-newsgroups (or arg 1))
(gnus-group-list-groups))
-
+
(defun gnus-group-edit-global-kill (&optional article group)
"Edit the global kill file.
If GROUP, edit that local kill file instead."
(interactive)
(gnus-run-hooks 'gnus-suspend-gnus-hook)
;; Kill Gnus buffers except for group mode buffer.
- (let* ((group-buf (get-buffer gnus-group-buffer))
- ;; Do this on a separate list in case the user does a ^G before we finish
- (gnus-buffer-list
- (delete group-buf (delete gnus-dribble-buffer
- (append gnus-buffer-list nil)))))
- (while gnus-buffer-list
- (gnus-kill-buffer (pop gnus-buffer-list)))
+ (let ((group-buf (get-buffer gnus-group-buffer)))
+ (mapcar (lambda (buf)
+ (unless (member buf (list group-buf gnus-dribble-buffer))
+ (kill-buffer buf)))
+ (gnus-buffers))
(gnus-kill-gnus-frames)
(when group-buf
- (setq gnus-buffer-list (list group-buf))
(bury-buffer group-buf)
(delete-windows-on group-buf t))))
(gnus-browse-foreign-server method))
(defun gnus-group-set-info (info &optional method-only-group part)
- (let* ((entry (gnus-gethash
- (or method-only-group (gnus-info-group info))
- gnus-newsrc-hashtb))
- (part-info info)
- (info (if method-only-group (nth 2 entry) info))
- method)
- (when method-only-group
+ (when (or info part)
+ (let* ((entry (gnus-gethash
+ (or method-only-group (gnus-info-group info))
+ gnus-newsrc-hashtb))
+ (part-info info)
+ (info (if method-only-group (nth 2 entry) info))
+ method)
+ (when method-only-group
+ (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
+ ;; whether we have to extend the info, and if so, do that.
+ (let ((len (length info))
+ (total (if (eq part 'method) 5 6)))
+ (when (< len total)
+ (setcdr (nthcdr (1- len) info)
+ (make-list (- total len) nil)))
+ ;; Then we enter the new info.
+ (setcar (nthcdr (1- total) info) part-info)))
(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
- ;; whether we have to extend the info, and if so, do that.
- (let ((len (length info))
- (total (if (eq part 'method) 5 6)))
- (when (< len total)
- (setcdr (nthcdr (1- len) info)
- (make-list (- total len) nil)))
- ;; Then we enter the new info.
- (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)
- (setq method (gnus-info-method info))
- (when (gnus-server-equal method "native")
- (setq method nil))
+ ;; This is a new group, so we just create it.
(save-excursion
(set-buffer gnus-group-buffer)
- (if method
- ;; It's a foreign group...
- (gnus-group-make-group
- (gnus-group-real-name (gnus-info-group info))
- (if (stringp method) method
- (prin1-to-string (car method)))
- (and (consp method)
- (nth 1 (gnus-info-method info))))
- ;; It's a native group.
- (gnus-group-make-group (gnus-info-group info))))
- (gnus-message 6 "Note: New group created")
- (setq entry
- (gnus-gethash (gnus-group-prefixed-name
- (gnus-group-real-name (gnus-info-group info))
- (or (gnus-info-method info) gnus-select-method))
- gnus-newsrc-hashtb))))
- ;; Whether it was a new group or not, we now have the entry, so we
- ;; can do the update.
- (if entry
- (progn
- (setcar (nthcdr 2 entry) info)
- (when (and (not (eq (car entry) t))
- (gnus-active (gnus-info-group info)))
- (setcar entry (length (gnus-list-of-unread-articles (car info))))))
- (error "No such group: %s" (gnus-info-group info)))))
+ (setq method (gnus-info-method info))
+ (when (gnus-server-equal method "native")
+ (setq method nil))
+ (save-excursion
+ (set-buffer gnus-group-buffer)
+ (if method
+ ;; It's a foreign group...
+ (gnus-group-make-group
+ (gnus-group-real-name (gnus-info-group info))
+ (if (stringp method) method
+ (prin1-to-string (car method)))
+ (and (consp method)
+ (nth 1 (gnus-info-method info))))
+ ;; It's a native group.
+ (gnus-group-make-group (gnus-info-group info))))
+ (gnus-message 6 "Note: New group created")
+ (setq entry
+ (gnus-gethash (gnus-group-prefixed-name
+ (gnus-group-real-name (gnus-info-group info))
+ (or (gnus-info-method info) gnus-select-method))
+ gnus-newsrc-hashtb))))
+ ;; Whether it was a new group or not, we now have the entry, so we
+ ;; can do the update.
+ (if entry
+ (progn
+ (setcar (nthcdr 2 entry) info)
+ (when (and (not (eq (car entry) t))
+ (gnus-active (gnus-info-group info)))
+ (setcar entry (length (gnus-list-of-unread-articles (car info))))))
+ (error "No such group: %s" (gnus-info-group info))))))
(defun gnus-group-set-method-info (group select-method)
(gnus-group-set-info select-method group 'method))
(defun gnus-add-marked-articles (group type articles &optional info force)
;; Add ARTICLES of TYPE to the info of GROUP.
- ;; If INFO is non-nil, use that info. If FORCE is non-nil, don't
+ ;; If INFO is non-nil, use that info. If FORCE is non-nil, don't
;; add, but replace marked articles of TYPE with ARTICLES.
(let ((info (or info (gnus-get-info group)))
- (uncompressed '(score bookmark killed))
marked m)
(or (not info)
(and (not (setq marked (nthcdr 3 info)))
(defun gnus-group-timestamp-delta (group)
"Return the offset in seconds from the timestamp for GROUP to the current time, as a floating point number."
(let* ((time (or (gnus-group-timestamp group)
- (list 0 0)))
- (delta (gnus-time-minus (current-time) time)))
+ (list 0 0)))
+ (delta (subtract-time (current-time) time)))
(+ (* (nth 0 delta) 65536.0)
(nth 1 delta))))
projects / elisp / gnus.git- / blobdiff