;;; gnus-group.el --- group mode commands for Gnus
-;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc.
+;; Copyright (C) 1996,97,98 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 gnus is bad news"
+(defcustom gnus-no-groups-message "No news is no 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 '(choice regexp (const nil)))
+ :type 'regexp)
(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)
+ (buffer-disable-undo (current-buffer))
(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
(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")
(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 unchecked
+ (and unread ; This group might be bogus
(or (not regexp)
(string-match regexp group))
(<= (setq clevel (gnus-info-level info)) level)
(beginning-of-line)
(forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2))
(subst-char-in-region
- (point) (1+ (point)) (char-after)
+ (point) (1+ (point)) (following-char)
(if unmark
(progn
(setq gnus-group-marked (delete group gnus-group-marked))
(defun gnus-fetch-group (group)
"Start Gnus if necessary and enter GROUP.
Returns whether the fetching was successful or not."
- (interactive (list (completing-read "Group name: " gnus-active-hashtb)))
+ (interactive "sGroup name: ")
(unless (get-buffer gnus-group-buffer)
(gnus-no-server))
(gnus-group-read-group nil nil group))
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 if selection was successful."
+Return the name of the group is selection was successful."
;; Transform the select method into a unique server.
(when (stringp method)
(setq method (gnus-server-to-method method)))
(gnus-read-method "From 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))))
+ (setq method (gnus-server-to-method method)))
+ (let* ((meth (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-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.
+(defun gnus-group-delete-group (group &optional force)
+ "Delete the current group. Only meaningful with mail 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 (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" "")))))
+ (if (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))
((= 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)
- (with-temp-file (gnus-score-file-name (concat "nnkiboze:" group))
+ (nnheader-temp-write (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 (car entries) (pop infos))
+ (setcar entries (pop infos))
(pop entries))
;; Update the hashtable.
(gnus-make-hashtable-from-newsrc-alist)))
-(defun gnus-group-sort-selected-groups-by-alphabet (&optional n reverse)
+(defun gnus-group-sort-selected-groups-by-alphabet (&optional reverse)
"Sort the group buffer alphabetically by group name.
-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))
+If REVERSE, sort in reverse order."
+ (interactive "P")
+ (gnus-group-sort-selected-groups 'gnus-group-sort-by-alphabet reverse))
-(defun gnus-group-sort-selected-groups-by-unread (&optional n reverse)
+(defun gnus-group-sort-selected-groups-by-unread (&optional reverse)
"Sort the group buffer by number of unread articles.
-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))
+If REVERSE, sort in reverse order."
+ (interactive "P")
+ (gnus-group-sort-selected-groups 'gnus-group-sort-by-unread reverse))
-(defun gnus-group-sort-selected-groups-by-level (&optional n reverse)
+(defun gnus-group-sort-selected-groups-by-level (&optional reverse)
"Sort the group buffer by group level.
-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))
+If REVERSE, sort in reverse order."
+ (interactive "P")
+ (gnus-group-sort-selected-groups 'gnus-group-sort-by-level reverse))
-(defun gnus-group-sort-selected-groups-by-score (&optional n reverse)
+(defun gnus-group-sort-selected-groups-by-score (&optional reverse)
"Sort the group buffer by group score.
-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))
+If REVERSE, sort in reverse order."
+ (interactive "P")
+ (gnus-group-sort-selected-groups 'gnus-group-sort-by-score reverse))
-(defun gnus-group-sort-selected-groups-by-rank (&optional n reverse)
+(defun gnus-group-sort-selected-groups-by-rank (&optional reverse)
"Sort the group buffer by group rank.
-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))
+If REVERSE, sort in reverse order."
+ (interactive "P")
+ (gnus-group-sort-selected-groups 'gnus-group-sort-by-rank reverse))
-(defun gnus-group-sort-selected-groups-by-method (&optional n reverse)
+(defun gnus-group-sort-selected-groups-by-method (&optional reverse)
"Sort the group buffer alphabetically by backend name.
-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))
+If REVERSE, sort in reverse order."
+ (interactive "P")
+ (gnus-group-sort-selected-groups 'gnus-group-sort-by-method reverse))
;;; Sorting predicates.
up is returned."
(interactive "P")
(let ((groups (gnus-group-process-prefix n))
- (ret 0)
- group)
+ (ret 0))
(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 (setq group (pop groups))
- (gnus-group-remove-mark group)
+ (while groups
;; Virtual groups have to be given special treatment.
- (let ((method (gnus-find-method-for-group group)))
+ (let ((method (gnus-find-method-for-group (car 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-group-real-name (car groups)) (nth 1 method) all)))
+ (gnus-group-remove-mark (car groups))
+ (if (>= (gnus-group-group-level) 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-goto-group (car groups))
+ (gnus-group-catchup (car groups) all))
(gnus-group-update-group-line)
- (setq ret (1+ ret)))))
+ (setq ret (1+ ret))))
+ (setq groups (cdr groups)))
(gnus-group-next-unread-group 1)
ret)))
or nil if no action could be taken."
(let* ((entry (gnus-gethash group gnus-newsrc-hashtb))
(num (car entry)))
- ;; Remove entries for this group.
- (nnmail-purge-split-history (gnus-group-real-name group))
;; Do the updating only if the newsgroup isn't killed.
(if (not (numberp (car entry)))
(gnus-message 1 "Can't catch up %s; non-active group" group)
(error "No groups to expire"))
(while (setq group (pop groups))
(gnus-group-remove-mark group)
- (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)))
(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 "Invalid level: %d" level))
+ (error "Illegal 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 (&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-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-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))
- (message "Killed group %s" group))
+ (if entry entry group) gnus-level-killed (if entry nil level)))
;; 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; invalid level: %d" level))))
+ (error "Can't kill; illegal 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)
- (gnus-agent nil)) ; Trick the agent into ignoring the active file.
+ (let ((gnus-read-active-file t))
(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")
- (require 'nnmail)
- (let ((gnus-inhibit-demon t)
- ;; Binding this variable will inhibit multiple fetchings
- ;; of the same mail source.
- (nnmail-fetched-sources (list t)))
+ (let ((gnus-inhibit-demon 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 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)
+ group method)
(while (setq group (pop groups))
(gnus-group-remove-mark group)
;; Bypass any previous denials from the server.
(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-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)
;; Print out all the groups.
(save-excursion
(pop-to-buffer "*Gnus Help*")
- (buffer-disable-undo)
+ (buffer-disable-undo (current-buffer))
(erase-buffer)
(setq groups (sort groups 'string<))
(while groups
(gnus-browse-foreign-server method))
(defun gnus-group-set-info (info &optional method-only-group part)
- (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)))
+ (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
- ;; This is a new group, so we just create it.
+ (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))
(save-excursion
(set-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)
- (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))))))
+ (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)))
marked m)
(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 (subtract-time (current-time) time)))
+ (list 0 0)))
+ (delta (gnus-time-minus (current-time) time)))
(+ (* (nth 0 delta) 65536.0)
(nth 1 delta))))
projects / elisp / gnus.git- / blobdiff