X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-group.el;h=5ece14571637e73937302c5bcd4b32ce37936091;hb=0007de6d40db139c025a8b2cba9ef04ee4837608;hp=482d8e9231ee53cabcefb7cbcf8e054fbfa71794;hpb=3c29b35cee3b56d145859456d72c0a3cd30496ed;p=gnus diff --git a/lisp/gnus-group.el b/lisp/gnus-group.el index 482d8e923..5ece14571 100644 --- a/lisp/gnus-group.el +++ b/lisp/gnus-group.el @@ -25,7 +25,7 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) @@ -55,6 +55,8 @@ (autoload 'gnus-agent-total-fetched-for "gnus-agent") (autoload 'gnus-cache-total-fetched-for "gnus-cache") +(autoload 'gnus-group-make-nnir-group "nnir") + (defcustom gnus-no-groups-message "No Gnus is good news" "*Message displayed by Gnus when no groups are available." :group 'gnus-start @@ -117,10 +119,11 @@ If nil, only list groups that have unread articles." :type 'boolean) (defcustom gnus-group-default-list-level gnus-level-subscribed - "*Default listing level. + "Default listing level. Ignored if `gnus-group-use-permanent-levels' is non-nil." :group 'gnus-group-listing - :type 'integer) + :type '(choice (integer :tag "Level") + (function :tag "Function returning level"))) (defcustom gnus-group-list-inactive-groups t "*If non-nil, inactive groups will be listed." @@ -548,8 +551,6 @@ simple manner.") (defvar gnus-group-list-mode nil) -(defvar gnus-group-icon-cache nil) - (defvar gnus-group-listed-groups nil) (defvar gnus-group-list-option nil) @@ -655,6 +656,7 @@ simple manner.") "D" gnus-group-enter-directory "f" gnus-group-make-doc-group "w" gnus-group-make-web-group + "G" gnus-group-make-nnir-group "M" gnus-group-read-ephemeral-group "r" gnus-group-rename-group "R" gnus-group-make-rss-group @@ -739,7 +741,6 @@ simple manner.") "e" gnus-score-edit-all-score) (gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map) - "C" gnus-group-fetch-control "d" gnus-group-describe-group "v" gnus-version) @@ -759,7 +760,6 @@ simple manner.") (symbol-value 'gnus-topic-mode))) (defun gnus-group-make-menu-bar () - (gnus-turn-off-edit-menu 'group) (unless (boundp 'gnus-group-reading-menu) (easy-menu-define @@ -806,10 +806,6 @@ simple manner.") ["Describe" gnus-group-describe-group :active (gnus-group-group-name) ,@(if (featurep 'xemacs) nil '(:help "Display description of the current group"))] - ["Fetch control message" gnus-group-fetch-control - :active (gnus-group-group-name) - ,@(if (featurep 'xemacs) nil - '(:help "Display the archived control message for the current group"))] ;; Actually one should check, if any of the marked groups gives t for ;; (gnus-check-backend-function 'request-expire-articles ...) ["Expire articles" gnus-group-expire-articles @@ -907,6 +903,7 @@ simple manner.") ["Add the help group" gnus-group-make-help-group t] ["Make a doc group..." gnus-group-make-doc-group t] ["Make a web group..." gnus-group-make-web-group t] + ["Make a search group..." gnus-group-make-nnir-group t] ["Make a virtual group..." gnus-group-make-empty-virtual t] ["Add a group to a virtual..." gnus-group-add-to-virtual t] ["Make an ephemeral group..." gnus-group-read-ephemeral-group t] @@ -1088,8 +1085,7 @@ When FORCE, rebuild the tool bar." (when (and (not (featurep 'xemacs)) (boundp 'tool-bar-mode) tool-bar-mode - ;; The Gnus 5.10.6 code checked (default-value 'tool-bar-mode). - ;; Why? --rsteib + (display-graphic-p) (or (not gnus-group-tool-bar-map) force)) (let* ((load-path (gmm-image-load-path-for-library "gnus" @@ -1168,6 +1164,12 @@ The following commands are available: (mouse-set-point e) (gnus-group-read-group nil)) +(defun gnus-group-default-list-level () + "Return the real value for `gnus-group-default-list-level'." + (if (functionp gnus-group-default-list-level) + (funcall gnus-group-default-list-level) + gnus-group-default-list-level)) + ;; Look at LEVEL and find out what the level is really supposed to be. ;; If LEVEL is non-nil, LEVEL will be returned, if not, what happens ;; will depend on whether `gnus-group-use-permanent-levels' is used. @@ -1177,20 +1179,18 @@ The following commands are available: (or (setq gnus-group-use-permanent-levels (or level (if (numberp gnus-group-use-permanent-levels) gnus-group-use-permanent-levels - (or gnus-group-default-list-level + (or (gnus-group-default-list-level) gnus-level-subscribed)))) - gnus-group-default-list-level gnus-level-subscribed)) + (gnus-group-default-list-level) gnus-level-subscribed)) (number-or-nil level) (t - (or level gnus-group-default-list-level gnus-level-subscribed)))) + (or level (gnus-group-default-list-level) gnus-level-subscribed)))) (defun gnus-group-setup-buffer () (set-buffer (gnus-get-buffer-create gnus-group-buffer)) (unless (eq major-mode 'gnus-group-mode) - (gnus-group-mode) - (when gnus-carpal - (gnus-carpal-setup-buffer 'group)))) + (gnus-group-mode))) (defun gnus-group-name-charset (method group) (if (null method) @@ -1231,7 +1231,7 @@ Also see the `gnus-group-use-permanent-levels' variable." (prefix-numeric-value current-prefix-arg) (or (gnus-group-default-level nil t) - gnus-group-default-list-level + (gnus-group-default-list-level) gnus-level-subscribed)))) (unless level (setq level (car gnus-group-list-mode) @@ -1552,7 +1552,7 @@ if it is a string, only list groups matching REGEXP." ?m ? )) (gnus-tmp-moderated-string (if (eq gnus-tmp-moderated ?m) "(m)" "")) - (gnus-tmp-group-icon (gnus-group-get-icon gnus-tmp-qualified-group)) + (gnus-tmp-group-icon (gnus-group-get-icon gnus-tmp-group)) (gnus-tmp-news-server (or (cadr gnus-tmp-method) "")) (gnus-tmp-news-method (or (car gnus-tmp-method) "")) (gnus-tmp-news-method-string @@ -1601,9 +1601,7 @@ if it is a string, only list groups matching REGEXP." (when (inline (gnus-visual-p 'group-highlight 'highlight)) (gnus-group-highlight-line gnus-tmp-group beg end)) (gnus-run-hooks 'gnus-group-update-hook) - (forward-line) - ;; Allow XEmacs to remove front-sticky text properties. - (gnus-group-remove-excess-properties))) + (forward-line))) (defun gnus-group-update-eval-form (group list) "Eval `car' of each element of LIST, and return the first that return t. @@ -1892,7 +1890,7 @@ If FIRST-TOO, the current line is also eligible as a target." (unless no-advance (gnus-group-next-group 1)) (decf n)) - (gnus-summary-position-point) + (gnus-group-position-point) n)) (defun gnus-group-unmark-group (n) @@ -2166,44 +2164,49 @@ be permanent." group))) (goto-char start))))) -(defun gnus-group-completing-read (prompt &optional collection predicate - require-match initial-input hist def - &rest args) +(defun gnus-group-completing-read (&optional prompt collection + require-match initial-input hist + def) "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 ((completion-styles (and (boundp 'completion-styles) - completion-styles)) - group) - (push 'substring completion-styles) - (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))))) +respectively if they are omitted. Regards COLLECTION as a hash table +if it is not a list." + (or collection (setq collection gnus-active-hashtb)) + (let (choices group) + (if (listp collection) + (dolist (symbol collection) + (setq group (symbol-name symbol)) + (push (if (string-match "[^\000-\177]" group) + (gnus-group-decoded-name group) + group) + choices)) + (mapatoms (lambda (symbol) + (setq group (symbol-name symbol)) + (push (if (string-match "[^\000-\177]" group) + (gnus-group-decoded-name group) + group) + choices)) + collection)) + (setq group (gnus-completing-read (or prompt "Group") (nreverse choices) + require-match initial-input + (or hist 'gnus-group-history) + def)) + (unless (if (listp collection) + (member group (mapcar 'symbol-name collection)) + (symbol-value (intern-soft group collection))) + (setq group + (mm-encode-coding-string + group (gnus-group-name-charset nil group)))) + (gnus-replace-in-string group "\n" ""))) ;;;###autoload (defun gnus-fetch-group (group &optional articles) "Start Gnus if necessary and enter GROUP. If ARTICLES, display those articles. Returns whether the fetching was successful or not." - (interactive (list (gnus-group-completing-read "Group name: " - nil nil nil + (interactive (list (gnus-group-completing-read nil + nil nil (gnus-group-name-at-point)))) (unless (gnus-alive-p) (gnus-no-server)) @@ -2222,8 +2225,6 @@ Returns whether the fetching was successful or not." (other-frame 1)))) (gnus-fetch-group group)) -(defvar gnus-ephemeral-group-server 0) - (defcustom gnus-large-ephemeral-newsgroup 200 "The number of articles which indicates a large ephemeral newsgroup. Same as `gnus-large-newsgroup', but only used for ephemeral newsgroups. @@ -2265,8 +2266,8 @@ Return the name of the group if selection was successful." (interactive (list ;; (gnus-read-group "Group name: ") - (gnus-group-completing-read "Group: ") - (gnus-read-method "From method: "))) + (gnus-group-completing-read) + (gnus-read-method "From method"))) ;; Transform the select method into a unique server. (when (stringp method) (setq method (gnus-server-to-method method))) @@ -2332,7 +2333,7 @@ specified by `gnus-gmane-group-download-format'." ;; See for more information. (interactive (list - (gnus-group-completing-read "Gmane group: ") + (gnus-group-completing-read "Gmane group") (read-number "Start article number: ") (read-number "How many articles: "))) (unless range (setq range 500)) @@ -2366,7 +2367,7 @@ Valid input formats include: ;; 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: "))) + (list (gnus-group-completing-read "Gmane URL"))) (let (group start range) (cond ;; URLs providing `group', `start' and `range': @@ -2422,6 +2423,14 @@ the bug number, and browsing the URL must return mbox output." (let ((tmpfile (mm-make-temp-file "gnus-temp-group-"))) (with-temp-file tmpfile (url-insert-file-contents (format mbox-url number)) + (goto-char (point-min)) + ;; Add the debbugs address so that we can respond to reports easily. + (while (re-search-forward "^To: " nil t) + (end-of-line) + (insert (format ", %s@%s" number + (gnus-replace-in-string + (gnus-replace-in-string mbox-url "^http://" "") + "/.*$" "")))) (write-region (point-min) (point-max) tmpfile) (gnus-group-read-ephemeral-group "gnus-read-ephemeral-bug" @@ -2452,13 +2461,13 @@ If PROMPT (the prefix) is a number, use the prompt specified in `gnus-group-jump-to-group-prompt'." (interactive (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))))))) + 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")) @@ -2649,7 +2658,7 @@ 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 (gnus-group-completing-read "Group: "))) + (interactive (list (gnus-group-completing-read))) (gnus-group-make-group (gnus-group-real-name group) (gnus-group-server group) nil nil t)) @@ -2658,11 +2667,14 @@ The user will be prompted for GROUP." "Add a new newsgroup. The user will be prompted for a NAME, for a select METHOD, and an 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." +even if it contains non-ASCII characters) unless ENCODED is non-nil. + +If the backend supports it, the group will also be created on the +server." (interactive (list (gnus-read-group "Group name: ") - (gnus-read-method "From method: "))) + (gnus-read-method "From method"))) (when (stringp method) (setq method (or (gnus-server-to-method method) method))) @@ -2908,8 +2920,9 @@ and NEW-NAME will be prompted for." (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) + (let ((entry (assoc (gnus-completing-read "Create group" + (mapcar 'car gnus-useful-groups) + t) gnus-useful-groups))) (list (cadr entry) ;; Don't use `caddr' here since macros within the `interactive' @@ -3001,11 +3014,11 @@ If SOLID (the prefix), create a solid group." (symbol-name (caar nnweb-type-definition)))) (type (gnus-string-or - (completing-read - (format "Search engine type (default %s): " default-type) - (mapcar (lambda (elem) (list (symbol-name (car elem)))) + (gnus-completing-read + "Search engine type" + (mapcar (lambda (elem) (symbol-name (car elem))) nnweb-type-definition) - nil t nil 'gnus-group-web-type-history) + t nil 'gnus-group-web-type-history) default-type)) (search (read-string @@ -3018,7 +3031,7 @@ If SOLID (the prefix), create a solid group." (nnweb-ephemeral-p t)))) (if solid (progn - (gnus-pull 'nnweb-ephemeral-p method) + (gnus-alist-pull 'nnweb-ephemeral-p method) (gnus-group-make-group group method)) (gnus-group-read-ephemeral-group group method t @@ -3096,8 +3109,8 @@ mail messages or news articles in files that have numeric names." "Add the current group to a virtual group." (interactive (list current-prefix-arg - (completing-read "Add to virtual group: " gnus-newsrc-hashtb nil t - "nnvirtual:"))) + (gnus-group-completing-read "Add to virtual group" + nil t "nnvirtual:"))) (unless (eq (car (gnus-find-method-for-group vgroup)) 'nnvirtual) (error "%s is not an nnvirtual group" vgroup)) (gnus-close-group vgroup) @@ -3668,7 +3681,7 @@ If given numerical prefix, toggle the N next groups." Killed newsgroups are subscribed. If SILENT, don't try to update the group line." (interactive (list (gnus-group-completing-read - "Group: " nil nil (gnus-read-active-file-p)))) + nil nil (gnus-read-active-file-p)))) (let ((newsrc (gnus-group-entry group))) (cond ((string-match "^[ \t]*$" group) @@ -3950,14 +3963,6 @@ re-scanning. If ARG is non-nil and not a number, this will force (unless gnus-slave (gnus-master-read-slave-newsrc)) - ;; We might read in new NoCeM messages here. - (when (and gnus-use-nocem - (or (and (numberp gnus-use-nocem) - (numberp arg) - (>= arg gnus-use-nocem)) - (not arg))) - (gnus-nocem-scan-groups)) - (gnus-get-unread-articles arg) ;; If the user wants it, we scan for new groups. @@ -3978,7 +3983,7 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." (let* ((groups (gnus-group-process-prefix n)) (ret (if (numberp n) (- n (length groups)) 0)) (beg (unless n - (point))) + (point-marker))) group method (gnus-inhibit-demon t) ;; Binding this variable will inhibit multiple fetchings @@ -4009,35 +4014,9 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." (goto-char beg)) (when gnus-goto-next-group-when-activating (gnus-group-next-unread-group 1 t)) - (gnus-summary-position-point) + (gnus-group-position-point) ret)) -(defun gnus-group-fetch-control (group) - "Fetch the archived control messages for the current group. -If given a prefix argument, prompt for a group." - (interactive - (list (or (when current-prefix-arg - (gnus-group-completing-read "Group: ")) - (gnus-group-group-name) - gnus-newsgroup-name))) - (unless group - (error "No group name given")) - (let ((name (gnus-group-real-name group)) - hierarchy) - (when (string-match "\\(^[^\\.]+\\)\\..*" name) - (setq hierarchy (match-string 1 name)) - (if gnus-group-fetch-control-use-browse-url - (browse-url (concat "ftp://ftp.isc.org/usenet/control/" - hierarchy "/" name ".gz")) - (let ((enable-local-variables nil)) - (gnus-group-read-ephemeral-group - group - `(nndoc ,group (nndoc-address - ,(find-file-noselect - (concat "/ftp@ftp.isc.org:/usenet/control/" - hierarchy "/" name ".gz"))) - (nndoc-article-type mbox)) t nil nil)))))) - (defun gnus-group-describe-group (force &optional group) "Display a description of the current newsgroup." (interactive (list current-prefix-arg (gnus-group-group-name))) @@ -4207,8 +4186,14 @@ 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)) + (let ((new-groups (gnus-find-new-newsgroups (or arg 1))) + current-group) + (gnus-group-list-groups) + (setq current-group (gnus-group-group-name)) + (dolist (group new-groups) + (gnus-group-jump-to-group group)) + (when current-group + (gnus-group-jump-to-group current-group)))) (defun gnus-group-edit-global-kill (&optional article group) "Edit the global kill file. @@ -4318,18 +4303,19 @@ If called interactively, this function will ask for a select method If not, METHOD should be a list where the first element is the method and the second element is the address." (interactive - (list (let ((how (completing-read - "Which back end: " - (append gnus-valid-select-methods gnus-server-alist) - nil t (cons "nntp" 0) 'gnus-method-history))) + (list (let ((how (gnus-completing-read + "Which back end" + (mapcar 'car (append gnus-valid-select-methods + gnus-server-alist)) + t (cons "nntp" 0) 'gnus-method-history))) ;; We either got a back end name or a virtual server name. ;; If the first, we also need an address. (if (assoc how gnus-valid-select-methods) (list (intern how) ;; Suggested by mapjph@bath.ac.uk. - (completing-read - "Address: " - (mapcar 'list gnus-secondary-servers))) + (gnus-completing-read + "Address" + gnus-secondary-servers)) ;; We got a server name. how)))) (gnus-browse-foreign-server method))