X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-group.el;h=4a7f06833a3b1090f9634638259c04b3c4392d54;hb=20d684cebd12bd0f93890a598a060981b52c97e9;hp=83b5a6eeed737d454427df5f75518c2311acd79e;hpb=fe70196e10cdd849981dbd014882fb20237d0740;p=gnus diff --git a/lisp/gnus-group.el b/lisp/gnus-group.el index 83b5a6eee..4a7f06833 100644 --- a/lisp/gnus-group.el +++ b/lisp/gnus-group.el @@ -1,35 +1,37 @@ ;;; gnus-group.el --- group mode commands for Gnus ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007 Free Software Foundation, Inc. +;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: ;;; Code: +;; For Emacs < 22.2. +(eval-and-compile + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + (eval-when-compile - (require 'cl) - (defvar tool-bar-mode)) + (require 'cl)) +(defvar tool-bar-mode) (require 'gnus) (require 'gnus-start) @@ -108,6 +110,18 @@ If nil, no groups are permanently visible." :group 'gnus-group-listing :type '(choice regexp (const nil))) +(defcustom gnus-safe-html-newsgroups "\\`nnrss[+:]" + "Groups in which links in html articles are considered all safe. +The value may be a regexp matching those groups, a list of group names, +or nil. This overrides `mm-w3m-safe-url-regexp' (which see). This is +effective only when emacs-w3m renders html articles, i.e., in the case +`mm-text-html-renderer' is set to `w3m'." + :version "23.2" + :group 'gnus-group-various + :type '(choice regexp + (repeat :tag "List of group names" (string :tag "Group")) + (const nil))) + (defcustom gnus-list-groups-with-ticked-articles t "*If non-nil, list groups that have only ticked articles. If nil, only list groups that have unread articles." @@ -382,6 +396,7 @@ score: The score of the group. ticked: The number of ticked articles." :group 'gnus-group-visual :type '(repeat (cons (sexp :tag "Form") face))) +(put 'gnus-group-highlight 'risky-local-variable t) (defcustom gnus-new-mail-mark ?% "Mark used for groups with new mail." @@ -419,6 +434,7 @@ score: The score of the group. ticked: The number of ticked articles." :group 'gnus-group-icons :type '(repeat (cons (sexp :tag "Form") file))) +(put 'gnus-group-icon-list 'risky-local-variable t) (defcustom gnus-group-name-charset-method-alist nil "Alist of method and the charset for group names. @@ -1025,7 +1041,7 @@ Pre-defined symbols include `gnus-group-tool-bar-gnome' and (const :tag "Retro look" gnus-group-tool-bar-retro) (repeat :tag "User defined list" gmm-tool-bar-item) (symbol)) - :version "23.0" ;; No Gnus + :version "23.1" ;; No Gnus :initialize 'custom-initialize-default :set 'gnus-group-tool-bar-update :group 'gnus-group) @@ -1068,7 +1084,7 @@ Pre-defined symbols include `gnus-group-tool-bar-gnome' and See `gmm-tool-bar-from-list' for the format of the list." :type '(repeat gmm-tool-bar-item) - :version "23.0" ;; No Gnus + :version "23.1" ;; No Gnus :initialize 'custom-initialize-default :set 'gnus-group-tool-bar-update :group 'gnus-group) @@ -1087,7 +1103,7 @@ See `gmm-tool-bar-from-list' for the format of the list." See `gmm-tool-bar-from-list' for the format of the list." :type '(repeat gmm-tool-bar-item) - :version "23.0" ;; No Gnus + :version "23.1" ;; No Gnus :initialize 'custom-initialize-default :set 'gnus-group-tool-bar-update :group 'gnus-group) @@ -1098,12 +1114,13 @@ These items are not displayed in the Gnus group mode tool bar. See `gmm-tool-bar-from-list' for the format of the list." :type 'gmm-tool-bar-zap-list - :version "23.0" ;; No Gnus + :version "23.1" ;; No Gnus :initialize 'custom-initialize-default :set 'gnus-group-tool-bar-update :group 'gnus-group) (defvar image-load-path) +(defvar tool-bar-map) (defun gnus-group-make-tool-bar (&optional force) "Make a group mode tool bar from `gnus-group-tool-bar'. @@ -1182,8 +1199,8 @@ The following commands are available: (goto-char (point-min)) (setq gnus-group-mark-positions (list (cons 'process (and (search-forward - (mm-string-as-multibyte "\200") nil t) - (- (point) 2)))))))) + (mm-string-to-multibyte "\200") nil t) + (- (point) (point-min) 1)))))))) (defun gnus-mouse-pick-group (e) "Enter the group under the mouse pointer." @@ -1218,7 +1235,10 @@ The following commands are available: (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 @@ -1650,6 +1670,24 @@ if it is a string, only list groups matching REGEXP." (ticked (gnus-range-length (cdr (assq 'tick marked)))) (group-age (gnus-group-timestamp-delta group)) (inhibit-read-only t)) + ;; FIXME: http://thread.gmane.org/gmane.emacs.gnus.general/65451/focus=65465 + ;; ====================================================================== + ;; From: Richard Stallman + ;; Subject: Re: Rewriting gnus-group-highlight-line (was: [...]) + ;; Cc: ding@gnus.org + ;; Date: Sat, 27 Oct 2007 19:41:20 -0400 + ;; Message-ID: + ;; + ;; [...] + ;; The kludge is that the alist elements contain expressions that refer + ;; to local variables with short names. Perhaps write your own tiny + ;; evaluator that handles just `and', `or', and numeric comparisons + ;; and just a few specific variables. + ;; ====================================================================== + ;; + ;; Similar for other evaluated variables. Grep for risky-local-variable + ;; to find them! -- rsteib + ;; ;; Eval the cars of the lists until we find a match. (while (and list (not (eval (caar list)))) @@ -2028,10 +2066,15 @@ and with point over the group in question." (defun gnus-group-read-group (&optional all no-article group select-articles) "Read news in this newsgroup. If the prefix argument ALL is non-nil, already read articles become -readable. IF ALL is a number, fetch this number of articles. If the -optional argument NO-ARTICLE is non-nil, no article will be -auto-selected upon group entry. If GROUP is non-nil, fetch that -group." +readable. + +If ALL is a positive number, fetch this number of the latest +articles in the group. If ALL is a negative number, fetch this +number of the earliest articles in the group. + +If the optional argument NO-ARTICLE is non-nil, no article will +be auto-selected upon group entry. If GROUP is non-nil, fetch +that group." (interactive "P") (let ((no-display (eq all 0)) (group (or group (gnus-group-group-name))) @@ -2110,28 +2153,84 @@ be permanent." (gnus-group-read-ephemeral-group (gnus-group-prefixed-name group method) method))) -(defun group-name-at-point () - (let ((regexp "[^-a-zA-Z+.:_]")) - (save-excursion - (buffer-substring - (progn - (re-search-backward regexp nil t) - (forward-char 1) - (point)) - (progn - (re-search-forward regexp nil t) - (forward-char -1) - (point)))))) +(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 "[][\C-@-\t\v-*,/:-@\\^`{-\C-?]*\ +\\(nn[a-z]+\\(?:\\+[^][\C-@-*,/:-@\\^`{-\C-?]+\\)?:\ +\[^][\C-@-*,./:-@\\^`{-\C-?]+\\(?:\\.[^][\C-@-*,./:-@\\^`{-\C-?]+\\)*\ +\\|[^][\C-@-*,./:-@\\^`{-\C-?]+\\(?:\\.[^][\C-@-*,./:-@\\^`{-\C-?]+\\)+\\)") + (start (point)) + (case-fold-search nil)) + (prog1 + (if (or (and (not (or (eobp) + (looking-at "[][\C-@-*,/;-@\\^`{-\C-?]"))) + (prog1 t + (skip-chars-backward "^][\C-@-\t\v-*,/;-@\\^`{-\C-?" + (point-at-bol)))) + (and (looking-at "[][\C-@-\t\v-*,/;-@\\^`{-\C-?]*$") + (prog1 t + (skip-chars-backward "][\C-@-\t\v-*,/;-@\\^`{-\C-?") + (skip-chars-backward "^][\C-@-\t\v-*,/;-@\\^`{-\C-?" + (point-at-bol)))) + (string-match "\\`[][\C-@-\t\v-*,/;-@\\^`{-\C-?]*\\'" + (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 "][\C-@-\t\v-*,/;-@\\^`{-\C-?") + (skip-chars-backward "^][\C-@-\t\v-*,/;-@\\^`{-\C-?" + (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 - nil nil nil nil - (group-name-at-point)))) - (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 (if articles nil t) nil group articles)) @@ -2191,10 +2290,7 @@ Return the name of the group if selection was successful." (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) @@ -2240,23 +2336,155 @@ Return the name of the group if selection was successful." (message "Quit reading the ephemeral group") nil))))) +(defcustom gnus-gmane-group-download-format + "http://download.gmane.org/%s/%s/%s" + "URL for downloading mbox files. +It must contain three \"%s\". They correspond to the group, the +minimal and maximal article numbers, respectively." + :group 'gnus-group-foreign + :version "23.1" ;; No Gnus + :type 'string) + +(autoload 'url-insert-file-contents "url-handlers") +;; FIXME: +;; - Add documentation, menu, key bindings, ... + +(defun gnus-read-ephemeral-gmane-group (group start &optional range) + "Read articles from Gmane group GROUP as an ephemeral group. +START is the first article. RANGE specifies how many articles +are fetched. The articles are downloaded via HTTP using the URL +specified by `gnus-gmane-group-download-format'." + ;; See for more information. + (interactive + (list + (gnus-group-completing-read "Gmane group: ") + (read-number "Start article number: ") + (read-number "How many articles: "))) + (unless range (setq range 500)) + (when (< range 1) + (error "Invalid range: %s" range)) + (let ((tmpfile (make-temp-file + (format "%s.start-%s.range-%s." group start range))) + (gnus-thread-sort-functions '(gnus-thread-sort-by-number))) + (with-temp-file tmpfile + (url-insert-file-contents + (format gnus-gmane-group-download-format + group start (+ start range))) + (write-region (point-min) (point-max) tmpfile) + (gnus-group-read-ephemeral-group + (format "%s.start-%s.range-%s" group start range) + `(nndoc ,tmpfile + (nndoc-article-type mbox)))) + (delete-file tmpfile))) + +(defun gnus-read-ephemeral-gmane-group-url (url) + "Create an ephemeral Gmane group from URL. + +Valid input formats include: +\"http://thread.gmane.org/gmane.foo.bar/12300/focus=12399\", +\"http://thread.gmane.org/gmane.foo.bar/12345/\", +\"http://article.gmane.org/gmane.foo.bar/12345/\", +\"http://news.gmane.org/group/gmane.foo.bar/thread=12345\"" + ;; - Feel free to add other useful Gmane URLs here! Maybe the URLs should + ;; be customizable? + ;; - The URLs should be added to `gnus-button-alist'. Probably we should + ;; prompt the user to decide: "View via `browse-url' or in Gnus? " + ;; (`gnus-read-ephemeral-gmane-group-url') + (interactive + (list (gnus-group-completing-read "Gmane URL: "))) + (let (group start range) + (cond + ;; URLs providing `group', `start' and `range': + ((string-match + ;; http://thread.gmane.org/gmane.emacs.devel/86326/focus=86525 + "^http://thread\.gmane\.org/\\([^/]+\\)/\\([0-9]+\\)/focus=\\([0-9]+\\)$" + url) + (setq group (match-string 1 url) + start (string-to-number (match-string 2 url)) + ;; Ensure that `range' is large enough to ensure focus article is + ;; included. + range (- (string-to-number (match-string 3 url)) + start -1))) + ;; URLs providing `group' and `start': + ((or (string-match + ;; http://article.gmane.org/gmane.comp.gnu.make.bugs/3584 + "^http://\\(?:thread\\|article\\|permalink\\)\.gmane\.org/\\([^/]+\\)/\\([0-9]+\\)" + url) + (string-match + ;; Don't advertise these in the doc string yet: + "^\\(?:nntp\\|news\\)://news\.gmane\.org/\\([^/]+\\)/\\([0-9]+\\)" + url) + (string-match + ;; http://news.gmane.org/group/gmane.emacs.gnus.general/thread=65099/force_load=t + "^http://news\.gmane\.org/group/\\([^/]+\\)/thread=\\([0-9]+\\)" + url)) + (setq group (match-string 1 url) + start (string-to-number (match-string 2 url)))) + (t + (error "Can't parse URL %s" url))) + (gnus-read-ephemeral-gmane-group group start range))) + +(defcustom gnus-bug-group-download-format-alist + '((emacs ;; Only a test bed yet: + . "http://emacsbugs.donarmstrong.com/cgi-bin/bugreport.cgi?mbox=yes;bug=%s") + (debian + . "http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=%s&mbox=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.1" ;; No Gnus + :type '(repeat (cons (symbol) (string :tag "URL format string")))) + +(defun gnus-read-ephemeral-bug-group (number mbox-url) + "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 (make-temp-file "gnus-temp-group-"))) + (with-temp-file tmpfile + (url-insert-file-contents (format mbox-url number)) + (write-region (point-min) (point-max) tmpfile) + (gnus-group-read-ephemeral-group + "gnus-read-ephemeral-bug" + `(nndoc ,tmpfile + (nndoc-article-type mbox)))) + (delete-file tmpfile))) + +(defun gnus-read-ephemeral-debian-bug-group (number) + "Browse Debian bug NUMBER as ephemeral group." + (interactive (list (read-string "Enter bug number: " + (thing-at-point 'word) nil))) + (gnus-read-ephemeral-bug-group + 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))) + (gnus-read-ephemeral-bug-group + number + (cdr (assoc 'emacs gnus-bug-group-download-format-alist)))) + (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) - (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)))) - '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")) @@ -2447,17 +2675,16 @@ If EXCLUDE-GROUP, do not go to that group." (defun gnus-group-make-group-simple (&optional group) "Add a new newsgroup. The user will be prompted for GROUP." - (interactive - (list (completing-read "Group: " gnus-active-hashtb - nil nil nil 'gnus-group-history))) - (gnus-group-make-group - (gnus-group-real-name group) - (gnus-group-server 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) +(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: ") @@ -2465,6 +2692,10 @@ ADDRESS." (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))) @@ -2555,14 +2786,19 @@ be removed from the server, even when it's empty." When used interactively, GROUP is the group under point and NEW-NAME will be prompted for." (interactive - (list - (gnus-group-group-name) - (progn - (unless (gnus-check-backend-function - 'request-rename-group (gnus-group-group-name)) - (error "This back end does not support renaming groups")) - (gnus-read-group "Rename group to: " - (gnus-group-real-name (gnus-group-group-name)))))) + (let ((group (gnus-group-group-name)) + method new-name) + (unless (gnus-check-backend-function 'request-rename-group group) + (error "This back end does not support renaming groups")) + (setq new-name (gnus-read-group + "Rename group to: " + (gnus-group-real-name (gnus-group-decoded-name group))) + method (gnus-info-method (gnus-get-info group))) + (list group (mm-encode-coding-string + new-name + (gnus-group-name-charset + method + (gnus-group-prefixed-name new-name method)))))) (unless (gnus-check-backend-function 'request-rename-group group) (error "This back end does not support renaming groups")) @@ -2581,29 +2817,34 @@ and NEW-NAME will be prompted for." (gnus-group-real-name new-name) (gnus-info-method (gnus-get-info group))))) - (when (gnus-active new-name) - (error "The group %s already exists" new-name)) + (let ((decoded-group (gnus-group-decoded-name group)) + (decoded-new-name (gnus-group-decoded-name new-name))) + (when (gnus-active new-name) + (error "The group %s already exists" decoded-new-name)) - (gnus-message 6 "Renaming group %s to %s..." group new-name) - (prog1 - (if (progn - (gnus-group-goto-group group) - (not (when (< (gnus-group-group-level) gnus-level-zombie) - (gnus-request-rename-group group new-name)))) - (gnus-error 3 "Couldn't rename group %s to %s" group new-name) - ;; We rename the group internally by killing it... - (gnus-group-kill-group) - ;; ... changing its name ... - (setcar (cdar gnus-list-of-killed-groups) new-name) - ;; ... and then yanking it. Magic! - (gnus-group-yank-group) - (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-message 6 "Renaming group %s to %s..." + decoded-group decoded-new-name) + (prog1 + (if (progn + (gnus-group-goto-group group) + (not (when (< (gnus-group-group-level) gnus-level-zombie) + (gnus-request-rename-group group new-name)))) + (gnus-error 3 "Couldn't rename group %s to %s" + decoded-group decoded-new-name) + ;; We rename the group internally by killing it... + (gnus-group-kill-group) + ;; ... changing its name ... + (setcar (cdar gnus-list-of-killed-groups) new-name) + ;; ... and then yanking it. Magic! + (gnus-group-yank-group) + (gnus-set-active new-name (gnus-active group)) + (gnus-message 6 "Renaming group %s to %s...done" + decoded-group decoded-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)))) (defun gnus-group-edit-group (group &optional part) "Edit the group on the current line." @@ -2696,7 +2937,10 @@ and NEW-NAME will be prompted for." (let ((entry (assoc (completing-read "Create group: " gnus-useful-groups nil t) gnus-useful-groups))) - (list (cadr entry) (caddr entry)))) + (list (cadr entry) + ;; Don't use `caddr' here since macros within the `interactive' + ;; form won't be expanded. + (car (cddr entry))))) (setq method (gnus-copy-sequence method)) (let (entry) (while (setq entry (memq (assq 'eval method) method)) @@ -2756,19 +3000,17 @@ If called with a prefix argument, ask for the file type." nil)))) (setq type found))) (setq file (expand-file-name file)) - (let ((name (gnus-generate-new-group-name - (gnus-group-prefixed-name - (file-name-nondirectory file) '(nndoc "")))) - (encodable (mm-coding-system-p 'utf-8))) + (let* ((name (gnus-generate-new-group-name + (gnus-group-prefixed-name + (file-name-nondirectory file) '(nndoc "")))) + (method (list 'nndoc file + (list 'nndoc-address file) + (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 - (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) - (list 'nndoc-address file) - (list 'nndoc-article-type (or type 'guess)))))) + (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) @@ -2809,8 +3051,8 @@ If SOLID (the prefix), create a solid group." (cons (current-buffer) (if (eq major-mode 'gnus-summary-mode) 'summary 'group)))))) +(defvar nnrss-group-alist) (eval-when-compile - (defvar nnrss-group-alist) (defun nnrss-discover-feed (arg)) (defun nnrss-save-server-data (arg))) (defun gnus-group-make-rss-group (&optional url) @@ -2822,25 +3064,32 @@ If there is, use Gnus to create an nnrss group" (setq url (read-from-minibuffer "URL to Search for RSS: "))) (let ((feedinfo (nnrss-discover-feed url))) (if feedinfo - (let ((title (gnus-newsgroup-savable-name - (read-from-minibuffer "Title: " - (gnus-newsgroup-savable-name - (or (cdr (assoc 'title - feedinfo)) - ""))))) - (desc (read-from-minibuffer "Description: " - (cdr (assoc 'description - feedinfo)))) - (href (cdr (assoc 'href feedinfo))) - (encodable (mm-coding-system-p 'utf-8))) - (when encodable + (let* ((title (gnus-newsgroup-savable-name + (read-from-minibuffer "Title: " + (gnus-newsgroup-savable-name + (mapconcat + 'identity + (split-string + (or (cdr (assoc 'title + feedinfo)) + "")) + " "))))) + (desc (read-from-minibuffer "Description: " + (mapconcat + 'identity + (split-string + (or (cdr (assoc 'description + feedinfo)) + "")) + " "))) + (href (cdr (assoc 'href feedinfo))) + (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)))) @@ -2922,6 +3171,8 @@ mail messages or news articles in files that have numeric names." (list 'nndir (gnus-group-real-name group) (list 'nndir-directory dir))))) (defvar nnkiboze-score-file) +(declare-function nnkiboze-score-file "nnkiboze" (group)) + (defun gnus-group-make-kiboze-group (group address scores) "Create an nnkiboze group. The user will be prompted for a name, a regexp to match groups, and @@ -3004,10 +3255,9 @@ score file entries for articles to include in the group." '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")) +(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." @@ -3534,12 +3784,8 @@ If given numerical prefix, toggle the N next groups." "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))) + (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) @@ -3926,7 +4172,7 @@ to use." 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 @@ -3954,7 +4200,7 @@ If given a prefix argument, prompt for a group." 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 @@ -4180,12 +4426,12 @@ The hook `gnus-suspend-gnus-hook' is called before actually suspending." (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)) - (with-current-buffer buf - (eq major-mode 'message-mode))) - (gnus-kill-buffer buf))) - (gnus-buffers)) + (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))) (setq gnus-backlog-articles nil) (gnus-kill-gnus-frames) (when group-buf @@ -4310,9 +4556,10 @@ and the second element is the address." (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-group-entry (gnus-group-prefixed-name @@ -4566,5 +4813,5 @@ Compacting group %s... (this may take a long time)" (provide 'gnus-group) -;;; arch-tag: 2eb5440f-0bca-4091-814c-e37817536af6 +;; arch-tag: 2eb5440f-0bca-4091-814c-e37817536af6 ;;; gnus-group.el ends here