[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] Changes to emacs/lisp/gnus/gnus-group.el,v
|
From: |
Miles Bader |
|
Subject: |
[Emacs-diffs] Changes to emacs/lisp/gnus/gnus-group.el,v |
|
Date: |
Sun, 28 Oct 2007 09:18:43 +0000 |
CVSROOT: /cvsroot/emacs
Module name: emacs
Changes by: Miles Bader <miles> 07/10/28 09:18:40
Index: lisp/gnus/gnus-group.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/gnus/gnus-group.el,v
retrieving revision 1.60
retrieving revision 1.61
diff -u -b -r1.60 -r1.61
--- lisp/gnus/gnus-group.el 27 Oct 2007 09:07:09 -0000 1.60
+++ lisp/gnus/gnus-group.el 28 Oct 2007 09:18:25 -0000 1.61
@@ -47,7 +47,11 @@
(require 'mm-url)
(let ((features (cons 'gnus-group features)))
(require 'gnus-sum))
- (defvar gnus-cache-active-hashtb))
+ (unless (boundp 'gnus-cache-active-hashtb)
+ (defvar gnus-cache-active-hashtb nil)))
+
+(autoload 'gnus-agent-total-fetched-for "gnus-agent")
+(autoload 'gnus-cache-total-fetched-for "gnus-cache")
(defcustom gnus-group-archive-directory
"/address@hidden:/pub/emacs/ding-list/"
@@ -61,7 +65,7 @@
:group 'gnus-group-foreign
:type 'directory)
-(defcustom gnus-no-groups-message "No gnus is bad news"
+(defcustom gnus-no-groups-message "No Gnus is good news"
"*Message displayed by Gnus when no groups are available."
:group 'gnus-start
:type 'string)
@@ -151,7 +155,7 @@
(function-item gnus-group-sort-by-rank)
(function :tag "other" nil))))
-(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y:%B%(%g%)%l %O\n"
+(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y:%B%(%g%)%O\n"
"*Format of group lines.
It works along the same lines as a normal formatting string,
with some simple extensions.
@@ -179,11 +183,11 @@
%O Moderated group (string, \"(m)\" or \"\")
%P Topic indentation (string)
%m Whether there is new(ish) mail in the group (char, \"%\")
-%l Whether there are GroupLens predictions for this group (string)
%n Select from where (string)
%z A string that look like `<%s:%n>' if a foreign select method is used
%d The date the group was last entered.
%E Icon as defined by `gnus-group-icon-list'.
+%F The disk space used by the articles fetched by both the cache and agent.
%u User defined specifier. The next character in the format string should
be a letter. Gnus will call the function gnus-user-format-function-X,
where X is the letter following %u. The function will be passed a
@@ -198,10 +202,10 @@
groups.
If you use %o or %O, reading the active file will be slower and quite
-a bit of extra memory will be used. %D will also worsen performance.
-Also note that if you change the format specification to include any
-of these specs, you must probably re-start Gnus to see them go into
-effect.
+a bit of extra memory will be used. %D and %F will also worsen
+performance. Also note that if you change the format specification to
+include any of these specs, you must probably re-start Gnus to see
+them go into effect.
General format specifiers can also be used.
See Info node `(gnus)Formatting Variables'."
@@ -440,13 +444,20 @@
(defcustom gnus-group-jump-to-group-prompt nil
"Default prompt for `gnus-group-jump-to-group'.
-If non-nil, the value should be a string, e.g. \"nnml:\",
-in which case `gnus-group-jump-to-group' offers \"Group: nnml:\"
-in the minibuffer prompt."
+
+If non-nil, the value should be a string or an alist. If it is a string,
+e.g. \"nnml:\", in which case `gnus-group-jump-to-group' offers \"Group:
+nnml:\" in the minibuffer prompt.
+
+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)))
+ (const :tag "Empty" nil)
+ (repeat (cons (integer :tag "Argument")
+ (string :tag "Prompt string")))))
(defvar gnus-group-listing-limit 1000
"*A limit of the number of groups when listing.
@@ -512,11 +523,12 @@
(?P gnus-group-indentation ?s)
(?E gnus-tmp-group-icon ?s)
(?B gnus-tmp-summary-live ?c)
- (?l gnus-tmp-grouplens ?s)
(?z gnus-tmp-news-method-string ?s)
(?m (gnus-group-new-mail gnus-tmp-group) ?c)
(?d (gnus-group-timestamp-string gnus-tmp-group) ?s)
- (?u gnus-tmp-user-defined ?s)))
+ (?u gnus-tmp-user-defined ?s)
+ (?F (gnus-total-fetched-for gnus-tmp-group) ?s)
+ ))
(defvar gnus-group-mode-line-format-alist
`((?S gnus-tmp-news-server ?s)
@@ -648,6 +660,7 @@
"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)
@@ -730,7 +743,8 @@
"?" gnus-group-list-plus)
(gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map)
- "f" gnus-score-flush-cache)
+ "f" gnus-score-flush-cache
+ "e" gnus-score-edit-all-score)
(gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map)
"c" gnus-group-fetch-charter
@@ -825,6 +839,8 @@
(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))
@@ -1010,7 +1026,7 @@
(const :tag "Retro look" gnus-group-tool-bar-retro)
(repeat :tag "User defined list" gmm-tool-bar-item)
(symbol))
- :version "22.1" ;; Gnus 5.10.9
+ :version "23.0" ;; No Gnus
:initialize 'custom-initialize-default
:set 'gnus-group-tool-bar-update
:group 'gnus-group)
@@ -1053,7 +1069,7 @@
See `gmm-tool-bar-from-list' for the format of the list."
:type '(repeat gmm-tool-bar-item)
- :version "22.1" ;; Gnus 5.10.9
+ :version "23.0" ;; No Gnus
:initialize 'custom-initialize-default
:set 'gnus-group-tool-bar-update
:group 'gnus-group)
@@ -1072,7 +1088,7 @@
See `gmm-tool-bar-from-list' for the format of the list."
:type '(repeat gmm-tool-bar-item)
- :version "22.1" ;; Gnus 5.10.9
+ :version "23.0" ;; No Gnus
:initialize 'custom-initialize-default
:set 'gnus-group-tool-bar-update
:group 'gnus-group)
@@ -1083,7 +1099,7 @@
See `gmm-tool-bar-from-list' for the format of the list."
:type 'gmm-tool-bar-zap-list
- :version "22.1" ;; Gnus 5.10.9
+ :version "23.0" ;; No Gnus
:initialize 'custom-initialize-default
:set 'gnus-group-tool-bar-update
:group 'gnus-group)
@@ -1143,7 +1159,8 @@
(use-local-map gnus-group-mode-map)
(buffer-disable-undo)
(setq truncate-lines t)
- (setq buffer-read-only t)
+ (setq buffer-read-only t
+ show-trailing-whitespace nil)
(gnus-set-default-directory)
(gnus-update-format-specifications nil 'group 'group-mode)
(gnus-update-group-mark-positions)
@@ -1202,7 +1219,10 @@
(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
@@ -1244,7 +1264,7 @@
(gnus-group-setup-buffer)
(gnus-update-format-specifications nil 'group 'group-mode)
(let ((case-fold-search nil)
- (props (text-properties-at (gnus-point-at-bol)))
+ (props (text-properties-at (point-at-bol)))
(empty (= (point-min) (point-max)))
(group (gnus-group-group-name))
number)
@@ -1276,7 +1296,7 @@
(point-min) (point-max)
'gnus-group (gnus-intern-safe
group gnus-active-hashtb))))
- (let ((newsrc (cdddr (gnus-gethash group gnus-newsrc-hashtb))))
+ (let ((newsrc (cdddr (gnus-group-entry group))))
(while (and newsrc
(not (gnus-goto-char
(text-property-any
@@ -1331,7 +1351,7 @@
group (gnus-info-group info)
params (gnus-info-params info)
newsrc (cdr newsrc)
- unread (car (gnus-gethash group gnus-newsrc-hashtb)))
+ unread (gnus-group-unread group))
(when not-in-list
(setq not-in-list (delete group not-in-list)))
(when (gnus-group-prepare-logic
@@ -1431,7 +1451,7 @@
"Update the current line in the group buffer."
(let* ((buffer-read-only nil)
(group (gnus-group-group-name))
- (entry (and group (gnus-gethash group gnus-newsrc-hashtb)))
+ (entry (and group (gnus-group-entry group)))
gnus-group-indentation)
(when group
(and entry
@@ -1448,7 +1468,7 @@
(defun gnus-group-insert-group-line-info (group)
"Insert GROUP on the current line."
- (let ((entry (gnus-gethash group gnus-newsrc-hashtb))
+ (let ((entry (gnus-group-entry group))
(gnus-group-indentation (gnus-group-group-indentation))
active info)
(if entry
@@ -1575,10 +1595,6 @@
(gnus-tmp-process-marked
(if (member gnus-tmp-group gnus-group-marked)
gnus-process-mark ? ))
- (gnus-tmp-grouplens
- (or (and gnus-use-grouplens
- (bbb-grouplens-group-p gnus-tmp-group))
- ""))
(buffer-read-only nil)
beg end
header gnus-tmp-header) ; passed as parameter to user-funcs.
@@ -1615,7 +1631,7 @@
"Highlight the current line according to `gnus-group-highlight'."
(let* ((list gnus-group-highlight)
(p (point))
- (end (gnus-point-at-eol))
+ (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))
@@ -1666,7 +1682,7 @@
(loc (point-min))
found buffer-read-only)
;; Enter the current status into the dribble buffer.
- (let ((entry (gnus-gethash group gnus-newsrc-hashtb)))
+ (let ((entry (gnus-group-entry group)))
(when (and entry
(not (gnus-ephemeral-group-p group)))
(gnus-dribble-enter
@@ -1691,7 +1707,7 @@
;; 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-gethash group gnus-newsrc-hashtb))))
+ (let ((entry (cddr (gnus-group-entry group))))
(while (and entry (car entry)
(not
(gnus-goto-char
@@ -1751,24 +1767,24 @@
(defun gnus-group-group-name ()
"Get the name of the newsgroup on the current line."
- (let ((group (get-text-property (gnus-point-at-bol) 'gnus-group)))
+ (let ((group (get-text-property (point-at-bol) 'gnus-group)))
(when group
(symbol-name group))))
(defun gnus-group-group-level ()
"Get the level of the newsgroup on the current line."
- (get-text-property (gnus-point-at-bol) 'gnus-level))
+ (get-text-property (point-at-bol) 'gnus-level))
(defun gnus-group-group-indentation ()
"Get the indentation of the newsgroup on the current line."
- (or (get-text-property (gnus-point-at-bol) 'gnus-indentation)
+ (or (get-text-property (point-at-bol) 'gnus-indentation)
(and gnus-group-indentation-function
(funcall gnus-group-indentation-function))
""))
(defun gnus-group-group-unread ()
"Get the number of unread articles of the newsgroup on the current line."
- (get-text-property (gnus-point-at-bol) 'gnus-unread))
+ (get-text-property (point-at-bol) 'gnus-unread))
(defun gnus-group-new-mail (group)
(if (nnmail-new-mail-p (gnus-group-real-name group))
@@ -1826,6 +1842,18 @@
(goto-char (or pos beg))
(and pos t))))
+(defun gnus-total-fetched-for (group)
+ (let* ((size-in-cache (or (gnus-cache-total-fetched-for group) 0))
+ (size-in-agent (or (gnus-agent-total-fetched-for group) 0))
+ (size (+ size-in-cache size-in-agent))
+ (suffix '("B" "K" "M" "G"))
+ (scale 1024.0)
+ (cutoff scale))
+ (while (> size cutoff)
+ (setq size (/ size scale)
+ suffix (cdr suffix)))
+ (format "%5.1f%s" size (car suffix))))
+
;;; Gnus group mode commands
;; Group marking.
@@ -1847,15 +1875,14 @@
;; Go to the mark position.
(beginning-of-line)
(forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2))
- (subst-char-in-region
- (point) (1+ (point)) (char-after)
+ (delete-char 1)
(if unmark
(progn
(setq gnus-group-marked (delete group gnus-group-marked))
- ? )
+ (insert-char ? 1 t))
(setq gnus-group-marked
(cons group (delete group gnus-group-marked)))
- gnus-process-mark)))
+ (insert-char gnus-process-mark 1 t)))
(unless no-advance
(gnus-group-next-group 1))
(decf n))
@@ -1871,10 +1898,8 @@
(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)))))
+ (mapc 'gnus-group-remove-mark gnus-group-marked))
(gnus-group-position-point))
(defun gnus-group-mark-region (unmark beg end)
@@ -2020,8 +2045,7 @@
(unless group
(error "No group on current line"))
(setq marked (gnus-info-marks
- (nth 2 (setq entry (gnus-gethash
- group gnus-newsrc-hashtb)))))
+ (nth 2 (setq entry (gnus-group-entry group)))))
;; This group might be a dead group. In that case we have to get
;; the number of unread articles from `gnus-active-hashtb'.
(setq number
@@ -2051,11 +2075,11 @@
(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."
@@ -2066,7 +2090,7 @@
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."
@@ -2090,14 +2114,86 @@
(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 "address@hidden,/:address@hidden
+\\(nn[a-z]+\\(?:address@hidden,/:address@hidden)?:\
address@hidden,./:address@hidden(?:address@hidden,./:address@hidden)*\
+\\|address@hidden,./:address@hidden(?:address@hidden,./:address@hidden)+\\)")
+ (start (point))
+ (case-fold-search nil))
+ (prog1
+ (if (or (and (not (or (eobp)
+ (looking-at "address@hidden,/;address@hidden")))
+ (prog1 t
+ (skip-chars-backward "address@hidden,/;address@hidden"
+ (point-at-bol))))
+ (and (looking-at "address@hidden,/;address@hidden")
+ (prog1 t
+ (skip-chars-backward "address@hidden,/;address@hidden")
+ (skip-chars-backward "address@hidden,/;address@hidden"
+ (point-at-bol))))
+ (string-match "address@hidden,/;address@hidden'"
+ (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 "address@hidden,/;address@hidden")
+ (skip-chars-backward "address@hidden,/;address@hidden"
+ (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 (prompt &optional collection predicate
+ require-match initial-input hist def
+ &rest args)
+ "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."
+ (let (group)
+ (mapatoms (lambda (symbol)
+ (setq group (symbol-name symbol))
+ (set (intern (if (string-match "[^\000-\177]" group)
+ (gnus-group-decoded-name group)
+ group)
+ collection)
+ group))
+ (prog1
+ (or collection
+ (setq collection (or gnus-active-hashtb [0])))
+ (setq collection (gnus-make-hashtable (length collection)))))
+ (setq group (apply 'completing-read prompt collection predicate
+ require-match initial-input
+ (or hist 'gnus-group-history)
+ def args))
+ (or (prog1
+ (symbol-value (intern-soft group collection))
+ (setq collection nil))
+ (mm-encode-coding-string group (gnus-group-name-charset nil 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 "Group name: "
+ 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)
@@ -2155,10 +2251,7 @@
(interactive
(list
;; (gnus-read-group "Group name: ")
- (completing-read
- "Group: " gnus-active-hashtb
- nil nil nil
- 'gnus-group-history)
+ (gnus-group-completing-read "Group: ")
(gnus-read-method "From method: ")))
;; Transform the select method into a unique server.
(when (stringp method)
@@ -2204,15 +2297,20 @@
(message "Quit reading the ephemeral group")
nil)))))
-(defun gnus-group-jump-to-group (group)
- "Jump to newsgroup GROUP."
+(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)
- gnus-group-jump-to-group-prompt
- 'gnus-group-history))))
+ (list (gnus-group-completing-read
+ "Group: " 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"))
@@ -2360,6 +2458,25 @@
(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)
@@ -2381,10 +2498,19 @@
(interactive)
(gnus-enter-server-buffer))
-(defun gnus-group-make-group (name &optional method address args)
+(defun gnus-group-make-group-simple (&optional group)
+ "Add a new newsgroup.
+The user will be prompted for GROUP."
+ (interactive (list (gnus-group-completing-read "Group: ")))
+ (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 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."
(interactive
(list
(gnus-read-group "Group name: ")
@@ -2392,6 +2518,10 @@
(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)))
@@ -2399,15 +2529,14 @@
method))))
(nname (if method (gnus-group-prefixed-name name meth) name))
backend info)
- (when (gnus-gethash nname gnus-newsrc-hashtb)
+ (when (gnus-group-entry 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))
gnus-level-default-subscribed gnus-level-killed
(and (gnus-group-group-name)
- (gnus-gethash (gnus-group-group-name)
- gnus-newsrc-hashtb))
+ (gnus-group-entry (gnus-group-group-name)))
t)
;; Make it active.
(gnus-set-active nname (cons 1 0))
@@ -2474,7 +2603,7 @@
(gnus-message 6 "Deleting group %s...done" group-decoded)
(gnus-group-goto-group group)
(gnus-group-kill-group 1 t)
- (gnus-sethash group nil gnus-active-hashtb)
+ (gnus-set-active group nil)
t)))
(gnus-group-position-point)))
@@ -2641,7 +2770,7 @@
(interactive)
(let ((name (gnus-group-prefixed-name "gnus-help" '(nndoc "gnus-help")))
(file (nnheader-find-etc-directory "gnus-tut.txt" t)))
- (if (gnus-gethash name gnus-newsrc-hashtb)
+ (if (gnus-group-entry name)
(cond ((eq noerror nil)
(error "Documentation group already exists"))
((eq noerror t)
@@ -2684,19 +2813,17 @@
nil))))
(setq type found)))
(setq file (expand-file-name file))
- (let ((name (gnus-generate-new-group-name
+ (let* ((name (gnus-generate-new-group-name
(gnus-group-prefixed-name
(file-name-nondirectory file) '(nndoc ""))))
- (encodable (mm-coding-system-p 'utf-8)))
- (gnus-group-make-group
- (if encodable
- (mm-encode-coding-string (gnus-group-real-name name) 'utf-8)
- (gnus-group-real-name name))
- (list 'nndoc (if encodable
- (mm-encode-coding-string file 'utf-8)
- file)
+ (method (list 'nndoc file
(list 'nndoc-address file)
- (list 'nndoc-article-type (or type 'guess))))))
+ (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
+ (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)
@@ -2750,7 +2877,7 @@
(setq url (read-from-minibuffer "URL to Search for RSS: ")))
(let ((feedinfo (nnrss-discover-feed url)))
(if feedinfo
- (let ((title (gnus-newsgroup-savable-name
+ (let* ((title (gnus-newsgroup-savable-name
(read-from-minibuffer "Title: "
(gnus-newsgroup-savable-name
(or (cdr (assoc 'title
@@ -2760,15 +2887,13 @@
(cdr (assoc 'description
feedinfo))))
(href (cdr (assoc 'href feedinfo)))
- (encodable (mm-coding-system-p 'utf-8)))
- (when encodable
+ (coding (gnus-group-name-charset '(nnrss "") title)))
+ (when coding
;; Unify non-ASCII text.
(setq title (mm-decode-coding-string
- (mm-encode-coding-string title 'utf-8) 'utf-8)))
- (gnus-group-make-group (if encodable
- (mm-encode-coding-string title 'utf-8)
- title)
- '(nnrss ""))
+ (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))))
@@ -2815,7 +2940,7 @@
(interactive "P")
(let ((group (gnus-group-prefixed-name
(if all "ding.archives" "ding.recent") '(nndir ""))))
- (when (gnus-gethash group gnus-newsrc-hashtb)
+ (when (gnus-group-entry group)
(error "Archive group already exists"))
(gnus-group-make-group
(gnus-group-real-name group)
@@ -2839,7 +2964,7 @@
(let ((ext "")
(i 0)
group)
- (while (or (not group) (gnus-gethash group gnus-newsrc-hashtb))
+ (while (or (not group) (gnus-group-entry group))
(setq group
(gnus-group-prefixed-name
(expand-file-name ext dir)
@@ -2858,7 +2983,7 @@
(list
(read-string "nnkiboze group name: ")
(read-string "Source groups (regexp): ")
- (let ((headers (mapcar (lambda (group) (list group))
+ (let ((headers (mapcar 'list
'("subject" "from" "number" "date" "message-id"
"references" "chars" "lines" "xref"
"followup" "all" "body" "head")))
@@ -2909,7 +3034,7 @@
(let* ((method (list 'nnvirtual "^$"))
(pgroup (gnus-group-prefixed-name group method)))
;; Check whether it exists already.
- (when (gnus-gethash pgroup gnus-newsrc-hashtb)
+ (when (gnus-group-entry pgroup)
(error "Group %s already exists" pgroup))
;; Subscribe the new group after the group on the current line.
(gnus-subscribe-group pgroup (gnus-group-group-name) method)
@@ -3081,7 +3206,7 @@
(let (entries infos)
;; First find all the group entries for these groups.
(while groups
- (push (nthcdr 2 (gnus-gethash (pop groups) gnus-newsrc-hashtb))
+ (push (nthcdr 2 (gnus-group-entry (pop groups)))
entries))
;; Then sort the infos.
(setq infos
@@ -3162,8 +3287,8 @@
(defun gnus-group-sort-by-unread (info1 info2)
"Sort by number of unread articles."
- (let ((n1 (car (gnus-gethash (gnus-info-group info1) gnus-newsrc-hashtb)))
- (n2 (car (gnus-gethash (gnus-info-group info2) gnus-newsrc-hashtb))))
+ (let ((n1 (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))))
@@ -3283,12 +3408,14 @@
(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
+ (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)
+ (gnus-group-update-group-line))
+ (t
(setq ret (1+ ret)))))
(gnus-group-next-unread-group 1)
ret)))
@@ -3304,9 +3431,9 @@
If ALL is non-nil, all articles are marked as read.
The return value is the number of articles that were marked as read,
or nil if no action could be taken."
- (let* ((entry (gnus-gethash group gnus-newsrc-hashtb))
+ (let* ((entry (gnus-group-entry group))
(num (car entry))
- (marks (nth 3 (nth 2 entry)))
+ (marks (gnus-info-marks (nth 2 entry)))
(unread (gnus-sequence-of-unread-articles group)))
;; Remove entries for this group.
(nnmail-purge-split-history (gnus-group-real-name group))
@@ -3327,9 +3454,11 @@
(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-range-map
+ (lambda (article)
(gnus-add-marked-articles group 'expire (list
article))
- (gnus-request-set-mark group (list (list (list
article) 'add '(expire)))))
+ (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))
@@ -3412,9 +3541,7 @@
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))
+ (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)
@@ -3422,7 +3549,7 @@
level)
(gnus-group-change-level
group level (or (gnus-group-group-level) gnus-level-killed))
- (gnus-group-update-group-line)))
+ (gnus-group-update-group-line))
(gnus-group-position-point))
(defun gnus-group-unsubscribe (&optional n)
@@ -3460,13 +3587,9 @@
"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)))
- (let ((newsrc (gnus-gethash group gnus-newsrc-hashtb)))
+ (interactive (list (gnus-group-completing-read
+ "Group: " nil nil (gnus-read-active-file-p))))
+ (let ((newsrc (gnus-group-entry group)))
(cond
((string-match "^[ \t]*$" group)
(error "Empty group name"))
@@ -3490,7 +3613,7 @@
gnus-level-zombie)
gnus-level-killed)
(when (gnus-group-group-name)
- (gnus-gethash (gnus-group-group-name) gnus-newsrc-hashtb)))
+ (gnus-group-entry (gnus-group-group-name))))
(unless silent
(gnus-group-update-group group)))
(t (error "No such newsgroup: %s" group)))
@@ -3529,12 +3652,10 @@
(count-lines
(progn
(goto-char begin)
- (beginning-of-line)
- (point))
+ (point-at-bol))
(progn
(goto-char end)
- (beginning-of-line)
- (point))))))
+ (point-at-bol))))))
(goto-char begin)
(beginning-of-line) ;Important when LINES < 1
(gnus-group-kill-group lines)))
@@ -3558,7 +3679,7 @@
(setq level (gnus-group-group-level))
(gnus-delete-line)
(when (and (not discard)
- (setq entry (gnus-gethash group gnus-newsrc-hashtb)))
+ (setq entry (gnus-group-entry group)))
(gnus-undo-register
`(progn
(gnus-group-goto-group ,(gnus-group-group-name))
@@ -3581,7 +3702,7 @@
(funcall gnus-group-change-level-function
group gnus-level-killed 3))
(cond
- ((setq entry (gnus-gethash group gnus-newsrc-hashtb))
+ ((setq entry (gnus-group-entry group))
(push (cons (car entry) (nth 2 entry))
gnus-list-of-killed-groups)
(setcdr (cdr entry) (cdddr entry)))
@@ -3614,7 +3735,7 @@
(setq prev (gnus-group-group-name))
(gnus-group-change-level
info (gnus-info-level (cdr info)) gnus-level-killed
- (and prev (gnus-gethash prev gnus-newsrc-hashtb))
+ (and prev (gnus-group-entry prev))
t)
(gnus-group-insert-group-line-info group)
(gnus-undo-register
@@ -3773,6 +3894,7 @@
(gnus-get-unread-articles arg))
(let ((gnus-read-active-file (if arg nil gnus-read-active-file)))
(gnus-get-unread-articles arg)))
+ (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)))))
@@ -3797,15 +3919,17 @@
(gnus-group-remove-mark group)
;; Bypass any previous denials from the server.
(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)
+ (if (gnus-activate-group group (if dont-scan nil 'scan) nil method)
+ (let ((info (gnus-get-info group))
+ (active (gnus-active group)))
+ (when info
+ (gnus-request-update-info info method))
+ (gnus-get-unread-articles-in-group info active)
(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)))
+ method (gnus-group-real-name group) active))
(gnus-group-update-group group))
(if (eq (gnus-server-status (gnus-find-method-for-group group))
'denied)
@@ -3851,7 +3975,7 @@
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 "Group: "))
(gnus-group-group-name)
gnus-newsgroup-name)))
(unless group
@@ -3879,7 +4003,7 @@
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 "Group: "))
(gnus-group-group-name)
gnus-newsgroup-name)))
(unless group
@@ -4105,14 +4229,12 @@
(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))
- (progn
- (save-excursion
- (set-buffer buf)
- (eq major-mode 'message-mode))))
+ (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)))
- (gnus-buffers))
(setq gnus-backlog-articles nil)
(gnus-kill-gnus-frames)
(when group-buf
@@ -4196,17 +4318,15 @@
;; Suggested by address@hidden
(completing-read
"Address: "
- (mapcar (lambda (server) (list server))
- gnus-secondary-servers)))
+ (mapcar 'list gnus-secondary-servers)))
;; We got a server name.
how))))
(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))
+ (let* ((entry (gnus-group-entry
+ (or method-only-group (gnus-info-group info))))
(part-info info)
(info (if method-only-group (nth 2 entry) info))
method)
@@ -4239,15 +4359,15 @@
(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-gethash (gnus-group-prefixed-name
+ (gnus-group-entry (gnus-group-prefixed-name
(gnus-group-real-name (gnus-info-group info))
- (or (gnus-info-method info) gnus-select-method))
- gnus-newsrc-hashtb))))
+ (or (gnus-info-method info)
gnus-select-method))))))
;; Whether it was a new group or not, we now have the entry, so we
;; can do the update.
(if entry
@@ -4460,6 +4580,40 @@
(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