X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-group.el;h=d4857a09672913a76eddc8053839e2e7698ac3b5;hb=c7fe7899bca156591013b0f833d601f9f5d6e9c9;hp=97b25098c18f398081ddc905f88414e4ba576046;hpb=59c7a4ffdbad9aefa53d29302edcce6acdd4af36;p=gnus diff --git a/lisp/gnus-group.el b/lisp/gnus-group.el index 97b25098c..d4857a096 100644 --- a/lisp/gnus-group.el +++ b/lisp/gnus-group.el @@ -1,5 +1,5 @@ ;;; gnus-group.el --- group mode commands for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen @@ -37,6 +37,7 @@ (require 'gnus-win) (require 'gnus-undo) (require 'time-date) +(require 'gnus-ems) (defcustom gnus-group-archive-directory "*ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/" @@ -117,8 +118,8 @@ This function will be called with group info entries as the arguments for the groups to be sorted. Pre-made functions include `gnus-group-sort-by-alphabet', `gnus-group-sort-by-real-name', `gnus-group-sort-by-unread', `gnus-group-sort-by-level', -`gnus-group-sort-by-score', `gnus-group-sort-by-method', and -`gnus-group-sort-by-rank'. +`gnus-group-sort-by-score', `gnus-group-sort-by-method', +`gnus-group-sort-by-server', and `gnus-group-sort-by-rank'. This variable can also be a list of sorting functions. In that case, the most significant sort function should be the last function in the @@ -131,6 +132,7 @@ list." (function-item gnus-group-sort-by-level) (function-item gnus-group-sort-by-score) (function-item gnus-group-sort-by-method) + (function-item gnus-group-sort-by-server) (function-item gnus-group-sort-by-rank) (function :tag "other" nil))) @@ -204,6 +206,11 @@ with some simple extensions: :options '(gnus-topic-mode) :type 'hook) +;; Extracted from gnus-xmas-redefine in order to preserve user settings +(when (featurep 'xemacs) + (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add) + (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar)) + (defcustom gnus-group-menu-hook nil "Hook run after the creation of the group mode menu." :group 'gnus-group-various @@ -288,52 +295,52 @@ variable." (sexp :tag "Method")))) (defcustom gnus-group-highlight - '(;; News. - ((and (= unread 0) (not mailp) (eq level 1)) . + '(;; Mail. + ((and mailp (= unread 0) (eq level 1)) . + gnus-group-mail-1-empty-face) + ((and mailp (eq level 1)) . + gnus-group-mail-1-face) + ((and mailp (= unread 0) (eq level 2)) . + gnus-group-mail-2-empty-face) + ((and mailp (eq level 2)) . + gnus-group-mail-2-face) + ((and mailp (= unread 0) (eq level 3)) . + gnus-group-mail-3-empty-face) + ((and mailp (eq level 3)) . + gnus-group-mail-3-face) + ((and mailp (= unread 0)) . + gnus-group-mail-low-empty-face) + ((and mailp) . + gnus-group-mail-low-face) + ;; News. + ((and (= unread 0) (eq level 1)) . gnus-group-news-1-empty-face) - ((and (not mailp) (eq level 1)) . + ((and (eq level 1)) . gnus-group-news-1-face) - ((and (= unread 0) (not mailp) (eq level 2)) . + ((and (= unread 0) (eq level 2)) . gnus-group-news-2-empty-face) - ((and (not mailp) (eq level 2)) . + ((and (eq level 2)) . gnus-group-news-2-face) - ((and (= unread 0) (not mailp) (eq level 3)) . + ((and (= unread 0) (eq level 3)) . gnus-group-news-3-empty-face) - ((and (not mailp) (eq level 3)) . + ((and (eq level 3)) . gnus-group-news-3-face) - ((and (= unread 0) (not mailp) (eq level 4)) . + ((and (= unread 0) (eq level 4)) . gnus-group-news-4-empty-face) - ((and (not mailp) (eq level 4)) . + ((and (eq level 4)) . gnus-group-news-4-face) - ((and (= unread 0) (not mailp) (eq level 5)) . + ((and (= unread 0) (eq level 5)) . gnus-group-news-5-empty-face) - ((and (not mailp) (eq level 5)) . + ((and (eq level 5)) . gnus-group-news-5-face) - ((and (= unread 0) (not mailp) (eq level 6)) . + ((and (= unread 0) (eq level 6)) . gnus-group-news-6-empty-face) - ((and (not mailp) (eq level 6)) . + ((and (eq level 6)) . gnus-group-news-6-face) - ((and (= unread 0) (not mailp)) . + ((and (= unread 0)) . gnus-group-news-low-empty-face) - ((and (not mailp)) . - gnus-group-news-low-face) - ;; Mail. - ((and (= unread 0) (eq level 1)) . - gnus-group-mail-1-empty-face) - ((eq level 1) . - gnus-group-mail-1-face) - ((and (= unread 0) (eq level 2)) . - gnus-group-mail-2-empty-face) - ((eq level 2) . - gnus-group-mail-2-face) - ((and (= unread 0) (eq level 3)) . - gnus-group-mail-3-empty-face) - ((eq level 3) . - gnus-group-mail-3-face) - ((= unread 0) . - gnus-group-mail-low-empty-face) (t . - gnus-group-mail-low-face)) + gnus-group-news-low-face)) "*Controls the highlighting of group buffer lines. Below is a list of `Form'/`Face' pairs. When deciding how a a @@ -400,6 +407,7 @@ ticked: The number of ticked articles." For example: (((nntp \"news.com.cn\") . cn-gb-2312)) " + :version "21.1" :group 'gnus-charset :type '(repeat (cons (sexp :tag "Method") (symbol :tag "Charset")))) @@ -412,6 +420,20 @@ For example: :group 'gnus-charset :type '(repeat (cons (regexp :tag "Group") (symbol :tag "Charset")))) +(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." + :group 'gnus-group-various + :type '(choice (string :tag "Prompt string") + (const :tag "Empty" nil))) + +(defvar gnus-group-listing-limit 1000 + "*A limit of the number of groups when listing. +If the number of groups is larger than the limit, list them in a +simple manner.") + ;;; Internal variables (defvar gnus-group-sort-alist-function 'gnus-group-sort-flat @@ -689,21 +711,29 @@ For example: (easy-menu-define gnus-group-reading-menu gnus-group-mode-map "" - '("Group" + `("Group" ["Read" gnus-group-read-group (gnus-group-group-name)] ["Select" gnus-group-select-group (gnus-group-group-name)] ["See old articles" (gnus-group-select-group 'all) :keys "C-u SPC" :active (gnus-group-group-name)] - ["Catch up" gnus-group-catchup-current (gnus-group-group-name)] + ["Catch up" gnus-group-catchup-current :active (gnus-group-group-name) + ,@(if (featurep 'xemacs) nil + '(:help "Mark unread articles in the current group as read"))] ["Catch up all articles" gnus-group-catchup-current-all (gnus-group-group-name)] ["Check for new articles" gnus-group-get-new-news-this-group - (gnus-group-group-name)] + :active (gnus-group-group-name) + ,@(if (featurep 'xemacs) nil + '(:help "Check for new messages in current group"))] ["Toggle subscription" gnus-group-unsubscribe-current-group (gnus-group-group-name)] - ["Kill" gnus-group-kill-group (gnus-group-group-name)] + ["Kill" gnus-group-kill-group :active (gnus-group-group-name) + ,@(if (featurep 'xemacs) nil + '(:help "Kill (remove) current group"))] ["Yank" gnus-group-yank-group gnus-list-of-killed-groups] - ["Describe" gnus-group-describe-group (gnus-group-group-name)] + ["Describe" gnus-group-describe-group :active (gnus-group-group-name) + ,@(if (featurep 'xemacs) nil + '(:help "Display description of the current group"))] ["Fetch FAQ" gnus-group-fetch-faq (gnus-group-group-name)] ;; Actually one should check, if any of the marked groups gives t for ;; (gnus-check-backend-function 'request-expire-articles ...) @@ -819,7 +849,7 @@ For example: (easy-menu-define gnus-group-misc-menu gnus-group-mode-map "" - '("Misc" + `("Gnus" ("SOUP" ["Pack replies" nnsoup-pack-replies (fboundp 'nnsoup-request-group)] ["Send replies" gnus-soup-send-replies @@ -829,7 +859,10 @@ For example: ["Brew SOUP" gnus-group-brew-soup (fboundp 'gnus-soup-pack-packet)]) ["Send a mail" gnus-group-mail t] ["Post an article..." gnus-group-post-news t] - ["Check for new news" gnus-group-get-new-news t] + ["Check for new news" gnus-group-get-new-news + ,@(if (featurep 'xemacs) '(t) + '(:help "Get newly arrived articles")) + ] ["Activate all groups" gnus-activate-all-groups t] ["Restart Gnus" gnus-group-restart t] ["Read init file" gnus-group-read-init-file t] @@ -845,11 +878,42 @@ For example: ["Flush score cache" gnus-score-flush-cache t] ["Toggle topics" gnus-topic-mode t] ["Send a bug report" gnus-bug t] - ["Exit from Gnus" gnus-group-exit t] + ["Exit from Gnus" gnus-group-exit + ,@(if (featurep 'xemacs) '(t) + '(:help "Quit reading news"))] ["Exit without saving" gnus-group-quit t])) (gnus-run-hooks 'gnus-group-menu-hook))) +(defvar gnus-group-toolbar-map nil) + +;; 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)) + (setq gnus-group-toolbar-map + (let ((tool-bar-map (make-sparse-keymap)) + (load-path (mm-image-load-path))) + (tool-bar-add-item-from-menu + 'gnus-group-get-new-news "get-news" gnus-group-mode-map) + (tool-bar-add-item-from-menu + 'gnus-group-get-new-news-this-group "gnntg" gnus-group-mode-map) + (tool-bar-add-item-from-menu + 'gnus-group-catchup-current "catchup" gnus-group-mode-map) + (tool-bar-add-item-from-menu + 'gnus-group-describe-group "describe-group" gnus-group-mode-map) + (tool-bar-add-item "subscribe" 'gnus-group-subscribe 'subscribe + :help "Subscribe to the current group") + (tool-bar-add-item "unsubscribe" 'gnus-group-unsubscribe + 'unsubscribe + :help "Unsubscribe from the current group") + (tool-bar-add-item-from-menu + 'gnus-group-exit "exit-gnus" gnus-group-mode-map) + tool-bar-map))) + (if gnus-group-toolbar-map + (set (make-local-variable 'tool-bar-map) gnus-group-toolbar-map))) + (defun gnus-group-mode () "Major mode for reading news. @@ -868,9 +932,10 @@ The following commands are available: \\{gnus-group-mode-map}" (interactive) - (when (gnus-visual-p 'group-menu 'menu) - (gnus-group-make-menu-bar)) (kill-all-local-variables) + (when (gnus-visual-p 'group-menu 'menu) + (gnus-group-make-menu-bar) + (gnus-group-make-tool-bar)) (gnus-simplify-mode-line) (setq major-mode 'gnus-group-mode) (setq mode-name "Group") @@ -892,6 +957,7 @@ The following commands are available: (defun gnus-update-group-mark-positions () (save-excursion (let ((gnus-process-mark ?\200) + (gnus-group-update-hook nil) (gnus-group-marked '("dummy.group")) (gnus-active-hashtb (make-vector 10 0)) (topic "")) @@ -939,7 +1005,7 @@ The following commands are available: (let ((item (assoc method gnus-group-name-charset-method-alist)) (alist gnus-group-name-charset-group-alist) result) - (if item + (if item (cdr item) (while (setq item (pop alist)) (if (string-match (car item) group) @@ -1033,7 +1099,7 @@ If ALL (the prefix), also list groups that have no unread articles." (or (and gnus-group-listed-groups (null gnus-group-list-option) (member group gnus-group-listed-groups)) - (cond + (cond ((null gnus-group-listed-groups) test) ((null gnus-group-list-option) test) (t (and (member group gnus-group-listed-groups) @@ -1052,6 +1118,8 @@ if it is a string, only list groups matching REGEXP." (let ((buffer-read-only nil) (newsrc (cdr gnus-newsrc-alist)) (lowest (or lowest 1)) + (not-in-list (and gnus-group-listed-groups + (copy-sequence gnus-group-listed-groups))) info clevel unread group params) (erase-buffer) (when (or (< lowest gnus-level-zombie) @@ -1063,8 +1131,10 @@ if it is a string, only list groups matching REGEXP." params (gnus-info-params info) newsrc (cdr newsrc) unread (car (gnus-gethash group gnus-newsrc-hashtb))) - (and - (gnus-group-prepare-logic + (if not-in-list + (setq not-in-list (delete group not-in-list))) + (and + (gnus-group-prepare-logic group (and unread ; This group might be unchecked (or (not (stringp regexp)) @@ -1078,9 +1148,9 @@ if it is a string, only list groups matching REGEXP." (t (or (if (eq unread t) ; Unactivated? - gnus-group-list-inactive-groups + gnus-group-list-inactive-groups ; We list unactivated - (> unread 0)) + (> unread 0)) ; We list groups with unread articles (and gnus-list-groups-with-ticked-articles (cdr (assq 'tick (gnus-info-marks info)))) @@ -1093,19 +1163,24 @@ if it is a string, only list groups matching REGEXP." (gnus-group-insert-group-line group (gnus-info-level info) (gnus-info-marks info) unread (gnus-info-method info))))) - + ;; List dead groups. (if (or gnus-group-listed-groups - (and (>= level gnus-level-zombie) + (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie))) (gnus-group-prepare-flat-list-dead (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) gnus-level-zombie ?Z regexp)) + (if not-in-list + (dolist (group gnus-zombie-list) + (setq not-in-list (delete group not-in-list)))) (if (or gnus-group-listed-groups (and (>= level gnus-level-killed) (<= lowest gnus-level-killed))) (gnus-group-prepare-flat-list-dead - (setq gnus-killed-list (sort gnus-killed-list 'string<)) + (gnus-union + not-in-list + (setq gnus-killed-list (sort gnus-killed-list 'string<))) gnus-level-killed ?K regexp)) (gnus-group-set-mode-line) @@ -1118,23 +1193,38 @@ if it is a string, only list groups matching REGEXP." ;; suggested by Jack Vinson . It does ;; this by ignoring the group format specification altogether. (let (group) - (while groups - (setq group (pop groups)) - (when (gnus-group-prepare-logic - group - (or (not regexp) - (and (stringp regexp) (string-match regexp group)) - (and (functionp regexp) (funcall regexp group)))) - (gnus-add-text-properties - (point) (prog1 (1+ (point)) - (insert " " mark " *: " - (gnus-group-name-decode group - (gnus-group-name-charset - nil group)) - "\n")) - (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) - 'gnus-unread t - 'gnus-level level)))))) + (if (> (length groups) gnus-group-listing-limit) + (while groups + (setq group (pop groups)) + (when (gnus-group-prepare-logic + group + (or (not regexp) + (and (stringp regexp) (string-match regexp group)) + (and (functionp regexp) (funcall regexp group)))) + (gnus-add-text-properties + (point) (prog1 (1+ (point)) + (insert " " mark " *: " + (gnus-group-decoded-name group) + "\n")) + (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) + 'gnus-unread t + 'gnus-level level)))) + (while groups + (setq group (pop groups)) + (when (gnus-group-prepare-logic + group + (or (not regexp) + (and (stringp regexp) (string-match regexp group)) + (and (functionp regexp) (funcall regexp group)))) + (gnus-group-insert-group-line + group level nil + (let ((active (gnus-active group))) + (if active + (if (zerop (cdr active)) + 0 + (- (1+ (cdr active)) (car active))) + nil)) + (gnus-method-simplify (gnus-find-method-for-group group)))))))) (defun gnus-group-update-group-line () "Update the current line in the group buffer." @@ -1177,14 +1267,14 @@ if it is a string, only list groups matching REGEXP." 0 (- (1+ (cdr active)) (car active))) nil) - nil)))) + (gnus-method-simplify (gnus-find-method-for-group group)))))) (defun gnus-group-insert-group-line (gnus-tmp-group gnus-tmp-level gnus-tmp-marked number gnus-tmp-method) "Insert a group line in the group buffer." (let* ((gnus-tmp-method - (gnus-server-get-method gnus-tmp-group gnus-tmp-method)) + (gnus-server-get-method gnus-tmp-group gnus-tmp-method)) (group-name-charset (gnus-group-name-charset gnus-tmp-method gnus-tmp-group)) (gnus-tmp-active (gnus-active gnus-tmp-group)) @@ -1204,13 +1294,13 @@ if it is a string, only list groups matching REGEXP." ((<= gnus-tmp-level gnus-level-unsubscribed) ?U) ((= gnus-tmp-level gnus-level-zombie) ?Z) (t ?K))) - (gnus-tmp-qualified-group + (gnus-tmp-qualified-group (gnus-group-name-decode (gnus-group-real-name gnus-tmp-group) group-name-charset)) (gnus-tmp-newsgroup-description (if gnus-description-hashtb (or (gnus-group-name-decode - (gnus-gethash gnus-tmp-group gnus-description-hashtb) + (gnus-gethash gnus-tmp-group gnus-description-hashtb) group-name-charset) "") "")) (gnus-tmp-moderated @@ -1275,9 +1365,13 @@ if it is a string, only list groups matching REGEXP." (info (nth 2 entry)) (method (gnus-server-get-method group (gnus-info-method info))) (marked (gnus-info-marks info)) - (mailp (memq 'mail (assoc (symbol-name - (car (or method gnus-select-method))) - gnus-valid-select-methods))) + (mailp (apply 'append + (mapcar + (lambda (x) + (memq x (assoc (symbol-name + (car (or method gnus-select-method))) + gnus-valid-select-methods))) + '(mail post-mail)))) (level (or (gnus-info-level info) gnus-level-killed)) (score (or (gnus-info-score info) 0)) (ticked (gnus-range-length (cdr (assq 'tick marked)))) @@ -1683,6 +1777,7 @@ group." (defun gnus-group-select-group (&optional all) "Select this newsgroup. No article is selected automatically. +If the group is opened, just switch the summary buffer. If ALL is non-nil, already read articles become readable. If ALL is a number, fetch this number of articles." (interactive "P") @@ -1807,7 +1902,7 @@ Return the name of the group if selection was successful." (list (completing-read "Group: " gnus-active-hashtb nil (gnus-read-active-file-p) - nil + gnus-group-jump-to-group-prompt 'gnus-group-history))) (when (equal group "") @@ -1856,11 +1951,11 @@ If TEST-MARKED, the line must be marked." (test-marked (goto-char (point-min)) (let (found) - (while (and (not found) + (while (and (not found) (gnus-goto-char (text-property-any (point) (point-max) - 'gnus-group + 'gnus-group (gnus-intern-safe group gnus-active-hashtb)))) (if (gnus-group-mark-line-p) (setq found t) @@ -2148,7 +2243,17 @@ and NEW-NAME will be prompted for." (t "group info")) (gnus-group-decoded-name group)) `(lambda (form) - (gnus-group-edit-group-done ',part ,group form))))) + (gnus-group-edit-group-done ',part ,group form))) + (local-set-key + "\C-c\C-i" + (gnus-create-info-command + (cond + ((eq part 'method) + "(gnus)Select Methods") + ((eq part 'params) + "(gnus)Group Parameters") + (t + "(gnus)Group Info")))))) (defun gnus-group-edit-group-method (group) "Edit the select method of GROUP." @@ -2324,7 +2429,7 @@ If SOLID (the prefix), create a solid group." default-login 'gnus-group-warchive-login-history) user-mail-address)) (method - `(nnwarchive ,address + `(nnwarchive ,address (nnwarchive-type ,(intern type)) (nnwarchive-login ,login)))) (gnus-group-make-group group method))) @@ -2362,14 +2467,14 @@ mail messages or news articles in files that have numeric names." (while (or (not group) (gnus-gethash group gnus-newsrc-hashtb)) (setq group (gnus-group-prefixed-name - (concat (file-name-as-directory (directory-file-name dir)) - ext) + (expand-file-name ext dir) '(nndir ""))) (setq ext (format "<%d>" (setq i (1+ i))))) (gnus-group-make-group (gnus-group-real-name group) (list 'nndir (gnus-group-real-name group) (list 'nndir-directory dir))))) +(eval-when-compile (defvar nnkiboze-score-file)) (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 @@ -2572,6 +2677,12 @@ If REVERSE, sort in reverse order." (interactive "P") (gnus-group-sort-groups 'gnus-group-sort-by-method reverse)) +(defun gnus-group-sort-groups-by-server (&optional reverse) + "Sort the group buffer alphabetically by server name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-groups 'gnus-group-sort-by-server reverse)) + ;;; Selected group sorting. (defun gnus-group-sort-selected-groups (n func &optional reverse) @@ -2676,9 +2787,18 @@ sort in reverse order." (symbol-name (car (gnus-find-method-for-group (gnus-info-group info2) info2))))) +(defun gnus-group-sort-by-server (info1 info2) + "Sort alphabetically by server name." + (string< (gnus-method-to-server-name + (gnus-find-method-for-group + (gnus-info-group info1) info1)) + (gnus-method-to-server-name + (gnus-find-method-for-group + (gnus-info-group info2) info2)))) + (defun gnus-group-sort-by-score (info1 info2) "Sort by group score." - (< (gnus-info-score info1) (gnus-info-score info2))) + (> (gnus-info-score info1) (gnus-info-score info2))) (defun gnus-group-sort-by-rank (info1 info2) "Sort by level and score." @@ -2718,13 +2838,22 @@ sort in reverse order." (defun gnus-info-clear-data (info) "Clear all marks and read ranges from INFO." - (let ((group (gnus-info-group info))) + (let ((group (gnus-info-group info)) + action) + (dolist (el (gnus-info-marks info)) + (push `(,(cdr el) add (,(car el))) action)) + (push `(,(gnus-info-read info) add (read)) action) (gnus-undo-register `(progn + (gnus-request-set-mark ,group ',action) (gnus-info-set-marks ',info ',(gnus-info-marks info) t) (gnus-info-set-read ',info ',(gnus-info-read info)) (when (gnus-group-goto-group ,group) + (gnus-get-unread-articles-in-group ',info ',(gnus-active group) t) (gnus-group-update-group-line)))) + (setq action (mapcar (lambda (el) (list (nth 0 el) 'del (nth 2 el))) + action)) + (gnus-request-set-mark group action) (gnus-info-set-read info nil) (when (gnus-info-marks info) (gnus-info-set-marks info nil)))) @@ -3191,9 +3320,7 @@ entail asking the server for the groups." (gnus-add-text-properties (point) (prog1 (1+ (point)) (insert " *: " - (gnus-group-name-decode group - (gnus-group-name-charset - nil group)) + (gnus-group-decoded-name group) "\n")) (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) 'gnus-unread t @@ -3299,7 +3426,7 @@ to use." (when current-prefix-arg (completing-read "Faq dir: " (and (listp gnus-group-faq-directory) - (mapcar (lambda (file) (list file)) + (mapcar #'list gnus-group-faq-directory)))))) (unless group (error "No group name given")) @@ -3310,7 +3437,7 @@ to use." (while (and (not found) (setq dir (pop dirs))) (let ((name (gnus-group-real-name group))) - (setq file (concat (file-name-as-directory dir) name))) + (setq file (expand-file-name name dir))) (if (not (file-exists-p file)) (gnus-message 1 "No such file: %s" file) (let ((enable-local-variables nil)) @@ -3354,7 +3481,7 @@ to use." (lambda (group) (setq b (point)) (let ((charset (gnus-group-name-charset nil (symbol-name group)))) - (insert (format " *: %-20s %s\n" + (insert (format " *: %-20s %s\n" (gnus-group-name-decode (symbol-name group) charset) (gnus-group-name-decode @@ -3517,11 +3644,12 @@ In fact, cleanup buffers except for group mode buffer. The hook gnus-suspend-gnus-hook is called before actually suspending." (interactive) (gnus-run-hooks 'gnus-suspend-gnus-hook) + (gnus-offer-save-summaries) ;; Kill Gnus buffers except for group mode buffer. (let ((group-buf (get-buffer gnus-group-buffer))) (mapcar (lambda (buf) (unless (member buf (list group-buf gnus-dribble-buffer)) - (kill-buffer buf))) + (gnus-kill-buffer buf))) (gnus-buffers)) (gnus-kill-gnus-frames) (when group-buf @@ -3569,6 +3697,12 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting." (file-name-nondirectory gnus-current-startup-file)))) (gnus-run-hooks 'gnus-exit-gnus-hook) (gnus-configure-windows 'group t) + (when (and (gnus-buffer-live-p gnus-dribble-buffer) + (not (zerop (save-excursion + (set-buffer gnus-dribble-buffer) + (buffer-size))))) + (gnus-dribble-enter + ";;; Gnus was exited on purpose without saving the .newsrc files.")) (gnus-dribble-save) (gnus-close-backends) (gnus-clear-system) @@ -3658,7 +3792,8 @@ and the second element is the address." (setcar (nthcdr 2 entry) info) (when (and (not (eq (car entry) t)) (gnus-active (gnus-info-group info))) - (setcar entry (length (gnus-list-of-unread-articles (car info)))))) + (setcar entry (length + (gnus-list-of-unread-articles (car info)))))) (error "No such group: %s" (gnus-info-group info)))))) (defun gnus-group-set-method-info (group select-method) @@ -3693,6 +3828,16 @@ and the second element is the address." (sort (nconc (gnus-uncompress-range (cdr m)) (copy-sequence articles)) '<) t)))))) +(defun gnus-add-mark (group mark article) + "Mark ARTICLE in GROUP with MARK, whether the group is displayed or not." + (let ((buffer (gnus-summary-buffer-name group))) + (if (gnus-buffer-live-p buffer) + (save-excursion + (set-buffer (get-buffer buffer)) + (gnus-summary-add-mark article mark)) + (gnus-add-marked-articles group (cdr (assq mark gnus-article-mark-lists)) + (list article))))) + ;;; ;;; Group timestamps ;;; @@ -3714,7 +3859,7 @@ or `gnus-group-catchup-group-hook'." "Return the offset in seconds from the timestamp for GROUP to the current time, as a floating point number." (let* ((time (or (gnus-group-timestamp group) (list 0 0))) - (delta (subtract-time (current-time) time))) + (delta (subtract-time (current-time) time))) (+ (* (nth 0 delta) 65536.0) (nth 1 delta)))) @@ -3737,18 +3882,18 @@ This command may read the active file." (setq level (prefix-numeric-value level))) (when (or (not level) (>= level gnus-level-zombie)) (gnus-cache-open)) - (funcall gnus-group-prepare-function + (funcall gnus-group-prepare-function (or level gnus-level-subscribed) #'(lambda (info) (let ((marks (gnus-info-marks info))) (assq 'cache marks))) lowest #'(lambda (group) - (or (gnus-gethash group + (or (gnus-gethash group gnus-cache-active-hashtb) - ;; Cache active file might use "." + ;; Cache active file might use "." ;; instead of ":". - (gnus-gethash + (gnus-gethash (mapconcat 'identity (split-string group ":") ".") @@ -3768,7 +3913,7 @@ This command may read the active file." (setq level (prefix-numeric-value level))) (when (or (not level) (>= level gnus-level-zombie)) (gnus-cache-open)) - (funcall gnus-group-prepare-function + (funcall gnus-group-prepare-function (or level gnus-level-subscribed) #'(lambda (info) (let ((marks (gnus-info-marks info))) @@ -3782,7 +3927,7 @@ This command may read the active file." "Return a list of listed groups." (let (point groups) (goto-char (point-min)) - (while (setq point (text-property-not-all (point) (point-max) + (while (setq point (text-property-not-all (point) (point-max) 'gnus-group nil)) (goto-char point) (push (symbol-name (get-text-property point 'gnus-group)) groups) @@ -3796,7 +3941,9 @@ This command may read the active file." (gnus-group-list-mode gnus-group-list-mode) ;; Save it. func) (push last-command-event unread-command-events) - (push ?A unread-command-events) + (if (featurep 'xemacs) + (push (make-event 'key-press '(key ?A)) unread-command-events) + (push ?A unread-command-events)) (let (gnus-pick-mode keys) (setq keys (if (featurep 'xemacs) (events-to-keys (read-key-sequence nil)) @@ -3814,11 +3961,35 @@ This command may read the active file." (gnus-group-list-plus args))) (defun gnus-group-list-limit (&optional args) - "Flush groups from the current selection." + "List groups limited within the current selection." (interactive "P") (let ((gnus-group-list-option 'limit)) (gnus-group-list-plus args))) +(defun gnus-group-mark-article-read (group article) + "Mark ARTICLE read." + (gnus-activate-group group) + (let ((buffer (gnus-summary-buffer-name group)) + (mark gnus-read-mark)) + (unless + (and + (get-buffer buffer) + (with-current-buffer buffer + (when gnus-newsgroup-prepared + (when (and gnus-newsgroup-auto-expire + (memq mark gnus-auto-expirable-marks)) + (setq mark gnus-expirable-mark)) + (setq mark (gnus-request-update-mark + group article mark)) + (gnus-mark-article-as-read article mark) + (setq gnus-newsgroup-active (gnus-active group)) + t))) + (gnus-group-make-articles-read group + (list article)) + (when (gnus-group-auto-expirable-p group) + (gnus-add-marked-articles + group 'expire (list article)))))) + (provide 'gnus-group) ;;; gnus-group.el ends here