X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-group.el;h=fe44b7dbd53d1dacd20558fdd288c9869959a5eb;hb=2a2ef844ddbe24bd212011237d512cd97c3dc6b8;hp=813541c607b4479459d272824de4b13c6f4a439d;hpb=db8dc34eb29fd030c85975aeaf23b577850d6ac9;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-group.el b/lisp/gnus-group.el index 813541c..fe44b7d 100644 --- a/lisp/gnus-group.el +++ b/lisp/gnus-group.el @@ -39,6 +39,8 @@ (require 'time-date) (require 'gnus-ems) +(eval-when-compile (require 'mm-url)) + (defcustom gnus-group-archive-directory "*ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/" "*The address of the (ding) archives." @@ -159,6 +161,7 @@ with some simple extensions. %G Group name (string) %g Qualified group name (string) %c Short (collapsed) group name. See `gnus-group-uncollapsed-levels'. +%C Group comment (string) %D Group description (string) %s Select method (string) %o Moderated group (char, \"m\") @@ -174,10 +177,10 @@ with some simple extensions. %E Icon as defined by `gnus-group-icon-list'. %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 the - current header as argument. The function should return a string, which - will be inserted into the buffer just like information from any other - group specifier. + where X is the letter following %u. The function will be passed a + single dummy parameter as argument.. The function should return a + string, which will be inserted into the buffer just like information + from any other group specifier. Note that this format specification is not always respected. For reasons of efficiency, when listing killed groups, this specification @@ -192,7 +195,7 @@ of these specs, you must probably re-start Gnus to see them go into effect. General format specifiers can also be used. -See (gnus)Formatting Variables." +See Info node `(gnus)Formatting Variables'." :link '(custom-manual "(gnus)Formatting Variables") :group 'gnus-group-visual :type 'string) @@ -415,7 +418,7 @@ For example: (defcustom gnus-group-name-charset-group-alist (if (or (and (fboundp 'find-coding-system) (find-coding-system 'utf-8)) (and (fboundp 'coding-system-p) (coding-system-p 'utf-8))) - '((".*" . utf-8)) + '(("[^\000-\177]" . utf-8)) nil) "Alist of group regexp and the charset for group names. @@ -475,6 +478,7 @@ simple manner.") (?g gnus-tmp-group ?s) (?G gnus-tmp-qualified-group ?s) (?c (gnus-short-group-name gnus-tmp-group) ?s) + (?C gnus-tmp-comment ?s) (?D gnus-tmp-newsgroup-description ?s) (?o gnus-tmp-moderated ?c) (?O gnus-tmp-moderated-string ?s) @@ -645,7 +649,8 @@ simple manner.") "l" gnus-group-sort-groups-by-level "v" gnus-group-sort-groups-by-score "r" gnus-group-sort-groups-by-rank - "m" gnus-group-sort-groups-by-method) + "m" gnus-group-sort-groups-by-method + "n" gnus-group-sort-groups-by-real-name) (gnus-define-keys (gnus-group-sort-selected-map "P" gnus-group-group-map) "s" gnus-group-sort-selected-groups @@ -654,7 +659,8 @@ simple manner.") "l" gnus-group-sort-selected-groups-by-level "v" gnus-group-sort-selected-groups-by-score "r" gnus-group-sort-selected-groups-by-rank - "m" gnus-group-sort-selected-groups-by-method) + "m" gnus-group-sort-selected-groups-by-method + "n" gnus-group-sort-selected-groups-by-real-name) (gnus-define-keys (gnus-group-list-map "A" gnus-group-mode-map) "k" gnus-group-list-killed @@ -710,6 +716,8 @@ simple manner.") "f" gnus-score-flush-cache) (gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map) + "c" gnus-group-fetch-charter + "C" gnus-group-fetch-control "d" gnus-group-describe-group "f" gnus-group-fetch-faq "v" gnus-version) @@ -754,6 +762,12 @@ simple manner.") ,@(if (featurep 'xemacs) nil '(:help "Display description of the current group"))] ["Fetch FAQ" gnus-group-fetch-faq (gnus-group-group-name)] + ["Fetch charter" gnus-group-fetch-charter :active (gnus-group-group-name) + ,@(if (featurep 'xemacs) nil + '(:help "Display the charter 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 @@ -761,7 +775,7 @@ simple manner.") (gnus-check-backend-function 'request-expire-articles (gnus-group-group-name))) gnus-group-marked)] - ["Set group level" gnus-group-set-current-level + ["Set group level..." gnus-group-set-current-level (gnus-group-group-name)] ["Select quick" gnus-group-quick-select-group (gnus-group-group-name)] ["Customize" gnus-group-customize (gnus-group-group-name)] @@ -798,7 +812,8 @@ simple manner.") ["Sort by score" gnus-group-sort-groups-by-score t] ["Sort by level" gnus-group-sort-groups-by-level t] ["Sort by unread" gnus-group-sort-groups-by-unread t] - ["Sort by name" gnus-group-sort-groups-by-alphabet t]) + ["Sort by name" gnus-group-sort-groups-by-alphabet t] + ["Sort by real name" gnus-group-sort-groups-by-real-name t]) ("Sort process/prefixed" ["Default sort" gnus-group-sort-selected-groups (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] @@ -813,6 +828,8 @@ simple manner.") ["Sort by unread" gnus-group-sort-selected-groups-by-unread (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] ["Sort by name" gnus-group-sort-selected-groups-by-alphabet + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + ["Sort by real name" gnus-group-sort-selected-groups-by-real-name (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))]) ("Mark" ["Mark group" gnus-group-mark-group @@ -828,23 +845,23 @@ simple manner.") ["Execute command" gnus-group-universal-argument (or gnus-group-marked (gnus-group-group-name))]) ("Subscribe" - ["Subscribe to a group" gnus-group-unsubscribe-group t] + ["Subscribe to a group..." gnus-group-unsubscribe-group t] ["Kill all newsgroups in region" gnus-group-kill-region t] ["Kill all zombie groups" gnus-group-kill-all-zombies gnus-zombie-list] ["Kill all groups on level..." gnus-group-kill-level t]) ("Foreign groups" - ["Make a foreign group" gnus-group-make-group t] - ["Make a shimbun group" gnus-group-make-shimbun-group t] - ["Add a directory group" gnus-group-make-directory-group t] + ["Make a foreign group..." gnus-group-make-group t] + ["Make a shimbun group..." gnus-group-make-shimbun-group t] + ["Add a directory group..." gnus-group-make-directory-group t] ["Add the help group" gnus-group-make-help-group t] ["Add the archive group" gnus-group-make-archive-group t] - ["Make a doc group" gnus-group-make-doc-group t] - ["Make a web group" gnus-group-make-web-group t] - ["Make a kiboze group" gnus-group-make-kiboze-group t] - ["Make a virtual group" gnus-group-make-empty-virtual t] - ["Add a group to a virtual" gnus-group-add-to-virtual t] - ["Rename group" gnus-group-rename-group + ["Make a doc group..." gnus-group-make-doc-group t] + ["Make a web group..." gnus-group-make-web-group t] + ["Make a kiboze group..." gnus-group-make-kiboze-group t] + ["Make a virtual group..." gnus-group-make-empty-virtual t] + ["Add a group to a virtual..." gnus-group-add-to-virtual t] + ["Rename group..." gnus-group-rename-group (gnus-check-backend-function 'request-rename-group (gnus-group-group-name))] ["Delete group" gnus-group-delete-group @@ -858,7 +875,7 @@ simple manner.") ["Next unread same level" gnus-group-next-unread-group-same-level t] ["Previous unread same level" gnus-group-prev-unread-group-same-level t] - ["Jump to group" gnus-group-jump-to-group t] + ["Jump to group..." gnus-group-jump-to-group t] ["First unread group" gnus-group-first-unread-group t] ["Best unread group" gnus-group-best-unread-group t]) ("Sieve" @@ -894,7 +911,7 @@ simple manner.") ["Activate all groups" gnus-activate-all-groups t] ["Restart Gnus" gnus-group-restart t] ["Read init file" gnus-group-read-init-file t] - ["Browse foreign server" gnus-group-browse-foreign-server t] + ["Browse foreign server..." gnus-group-browse-foreign-server t] ["Enter server buffer" gnus-group-enter-server-mode t] ["Expire all expirable articles" gnus-group-expire-all-groups t] ["Generate any kiboze groups" nnkiboze-generate-groups t] @@ -917,9 +934,11 @@ simple manner.") ;; Emacs 21 tool bar. Should be no-op otherwise. (defun gnus-group-make-tool-bar () - (if (and (fboundp 'tool-bar-add-item-from-menu) - (default-value 'tool-bar-mode) - (not gnus-group-toolbar-map)) + (if (and + (condition-case nil (require 'tool-bar) (error nil)) + (fboundp 'tool-bar-add-item-from-menu) + (default-value 'tool-bar-mode) + (not gnus-group-toolbar-map)) (setq gnus-group-toolbar-map (let ((tool-bar-map (make-sparse-keymap)) (load-path (mm-image-load-path))) @@ -1042,8 +1061,7 @@ The following commands are available: result))) (defun gnus-group-name-decode (string charset) - (if (and string charset (featurep 'mule) - (not (mm-multibyte-string-p string))) + (if (and string charset (featurep 'mule)) (decode-coding-string string charset) string)) @@ -1051,6 +1069,35 @@ The following commands are available: (let ((charset (gnus-group-name-charset nil string))) (gnus-group-name-decode string charset))) +(defun gnus-group-name-encode (string charset) + (if (and string charset (featurep 'mule)) + (encode-coding-string string charset) + string)) + +(defun gnus-group-encoded-name (string) + (let ((charset (gnus-group-name-charset nil string))) + (gnus-group-name-encode string charset))) + +(defun gnus-group-completing-read-group-name + (prompt table &optional predicate require-match initial-contents history) + (if (vectorp table) + (mapatoms + (lambda (group) + (push (list (gnus-group-decoded-name (symbol-name group))) table)) + (prog1 + table + (setq table nil))) + (dolist (entry (prog1 + table + (setq table nil))) + (push (list (gnus-group-decoded-name (car entry))) table))) + (gnus-group-encoded-name + (completing-read + prompt table predicate + require-match + initial-contents + history))) + (defun gnus-group-list-groups (&optional level unread lowest) "List newsgroups with level LEVEL or lower that have unread articles. Default is all subscribed groups. @@ -1326,6 +1373,9 @@ if it is a string, only list groups matching REGEXP." (gnus-tmp-qualified-group (gnus-group-name-decode (gnus-group-real-name gnus-tmp-group) group-name-charset)) + (gnus-tmp-comment + (or (gnus-group-get-parameter gnus-tmp-group 'comment t) + gnus-tmp-group)) (gnus-tmp-newsgroup-description (if gnus-description-hashtb (or (gnus-group-name-decode @@ -1723,7 +1773,7 @@ Take into consideration N (the prefix) and the list of marked groups." (setq n (1- n)) (gnus-group-next-group way))) (nreverse groups))) - ((gnus-region-active-p) + ((and (gnus-region-active-p) (mark)) ;; Work on the region between point and mark. (let ((max (max (point) (mark))) groups) @@ -1854,13 +1904,14 @@ be permanent." (gnus-group-prefixed-name group method) method))) ;;;###autoload -(defun gnus-fetch-group (group) +(defun gnus-fetch-group (group &optional articles) "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 (list (gnus-group-completing-read-group-name + "Group name: " gnus-active-hashtb))) (unless (get-buffer gnus-group-buffer) (gnus-no-server)) - (gnus-group-read-group nil nil group)) + (gnus-group-read-group articles nil group)) ;;;###autoload (defun gnus-fetch-group-other-frame (group) @@ -1936,7 +1987,7 @@ Return the name of the group if selection was successful." (defun gnus-group-jump-to-group (group) "Jump to newsgroup GROUP." (interactive - (list (completing-read + (list (gnus-group-completing-read-group-name "Group: " gnus-active-hashtb nil (gnus-read-active-file-p) gnus-group-jump-to-group-prompt @@ -2198,7 +2249,8 @@ doing the deletion." (gnus-group-goto-group group) (gnus-group-kill-group 1 t) (gnus-sethash group nil gnus-active-hashtb) - (when gnus-cache-active-hashtb + (when (and (boundp 'gnus-cache-active-hashtb) + gnus-cache-active-hashtb) (gnus-sethash group nil gnus-cache-active-hashtb) (setq gnus-cache-active-altered t)) t)) @@ -2701,6 +2753,12 @@ If REVERSE, sort in reverse order." (interactive "P") (gnus-group-sort-groups 'gnus-group-sort-by-alphabet reverse)) +(defun gnus-group-sort-groups-by-real-name (&optional reverse) + "Sort the group buffer alphabetically by real (unprefixed) group name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-groups 'gnus-group-sort-by-real-name reverse)) + (defun gnus-group-sort-groups-by-unread (&optional reverse) "Sort the group buffer by number of unread articles. If REVERSE, sort in reverse order." @@ -2779,6 +2837,13 @@ sort in reverse order." (interactive (gnus-interactive "P\ny")) (gnus-group-sort-selected-groups n 'gnus-group-sort-by-alphabet reverse)) +(defun gnus-group-sort-selected-groups-by-real-name (&optional n reverse) + "Sort the group buffer alphabetically by real 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-real-name reverse)) + (defun gnus-group-sort-selected-groups-by-unread (&optional n reverse) "Sort the group buffer by number of unread articles. Obeys the process/prefix convention. If REVERSE (the symbolic prefix), @@ -2838,10 +2903,10 @@ sort in reverse order." (defun gnus-group-sort-by-method (info1 info2) "Sort alphabetically by backend name." - (string< (symbol-name (car (gnus-find-method-for-group - (gnus-info-group info1) info1))) - (symbol-name (car (gnus-find-method-for-group - (gnus-info-group info2) info2))))) + (string< (car (gnus-find-method-for-group + (gnus-info-group info1) info1)) + (car (gnus-find-method-for-group + (gnus-info-group info2) info2)))) (defun gnus-group-sort-by-server (info1 info2) "Sort alphabetically by server name." @@ -3121,7 +3186,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 (completing-read + (list (gnus-group-completing-read-group-name "Group: " gnus-active-hashtb nil (gnus-read-active-file-p) nil @@ -3487,7 +3552,7 @@ to use." (gnus-group-group-name) (when current-prefix-arg (completing-read - "Faq dir: " (and (listp gnus-group-faq-directory) + "FAQ dir: " (and (listp gnus-group-faq-directory) (mapcar #'list gnus-group-faq-directory)))))) (unless group @@ -3506,6 +3571,51 @@ to use." (find-file file) (setq found t)))))) +(defun gnus-group-fetch-charter (group) + "Fetch the charter for the current 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-group-name) + gnus-newsgroup-name))) + (unless group + (error "No group name given")) + (require 'mm-url) + (let ((name (mm-url-form-encode-xwfu (gnus-group-real-name group))) + url hierarchy) + (when (string-match "\\(^[^\\.]+\\)\\..*" name) + (setq hierarchy (match-string 1 name)) + (if (setq url (cdr (assoc hierarchy gnus-group-charter-alist))) + (browse-url (eval url)) + (gnus-group-fetch-control group))))) + +(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 + (completing-read "Group: " gnus-active-hashtb)) + (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 ".Z")) + (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 ".Z"))) + (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))) @@ -4055,7 +4165,7 @@ This command may read the active file." (unless (eq n article) (push n gnus-newsgroup-unselected)) (setq n (1+ n))) - (setq gnus-newsgroup-unselected + (setq gnus-newsgroup-unselected (nreverse gnus-newsgroup-unselected))))) (gnus-activate-group group) (gnus-group-make-articles-read group