diff options
Diffstat (limited to 'lisp/gnus/gnus-group.el')
| -rw-r--r-- | lisp/gnus/gnus-group.el | 239 |
1 files changed, 97 insertions, 142 deletions
diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 1cd16a4e043..53a4ca75042 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -38,7 +38,6 @@ (require 'gnus-undo) (require 'gmm-utils) (require 'time-date) -(require 'gnus-ems) (eval-when-compile (require 'mm-url) @@ -224,11 +223,6 @@ with some simple extensions: :group 'gnus-group-visual :type 'string) -;; 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 @@ -427,8 +421,7 @@ For example: :type '(repeat (cons (sexp :tag "Method") (symbol :tag "Charset")))) (defcustom gnus-group-name-charset-group-alist - (if (or (and (fboundp 'find-coding-system) (find-coding-system 'utf-8)) - (mm-coding-system-p 'utf-8)) + (if (mm-coding-system-p 'utf-8) '((".*" . utf-8)) nil) "Alist of group regexp and the charset for group names. @@ -535,10 +528,7 @@ simple manner.") (?O gnus-tmp-moderated-string ?s) (?p gnus-tmp-process-marked ?c) (?s gnus-tmp-news-server ?s) - (?n ,(if (featurep 'xemacs) - '(symbol-name gnus-tmp-news-method) - 'gnus-tmp-news-method) - ?s) + (?n gnus-tmp-news-method ?s) (?P gnus-group-indentation ?s) (?E gnus-tmp-group-icon ?s) (?B gnus-tmp-summary-live ?c) @@ -632,8 +622,8 @@ simple manner.") "\C-c\C-i" gnus-info-find-node "\M-e" gnus-group-edit-group-method "^" gnus-group-enter-server-mode - gnus-mouse-2 gnus-mouse-pick-group - [follow-link] mouse-face + [mouse-2] gnus-mouse-pick-group + [follow-link] 'mouse-face "<" beginning-of-buffer ">" end-of-buffer "\C-c\C-b" gnus-bug @@ -798,32 +788,26 @@ simple manner.") ["Catch up" gnus-group-catchup-current :included (not (gnus-topic-mode-p)) :active (gnus-group-group-name) - ,@(if (featurep 'xemacs) nil - '(:help "Mark unread articles in the current group as read"))] + :help "Mark unread articles in the current group as read"] ["Catch up " gnus-topic-catchup-articles :included (gnus-topic-mode-p) - ,@(if (featurep 'xemacs) nil - '(:help "Mark unread articles in the current group or topic as read"))] + :help "Mark unread articles in the current group or topic 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 :included (not (gnus-topic-mode-p)) :active (gnus-group-group-name) - ,@(if (featurep 'xemacs) nil - '(:help "Check for new messages in current group"))] + :help "Check for new messages in current group"] ["Check for new articles " gnus-topic-get-new-news-this-topic :included (gnus-topic-mode-p) - ,@(if (featurep 'xemacs) nil - '(:help "Check for new messages in current group or topic"))] + :help "Check for new messages in current group or topic"] ["Toggle subscription" gnus-group-unsubscribe-current-group (gnus-group-group-name)] ["Kill" gnus-group-kill-group :active (gnus-group-group-name) - ,@(if (featurep 'xemacs) nil - '(:help "Kill (remove) current group"))] + :help "Kill (remove) current group"] ["Yank" gnus-group-yank-group gnus-list-of-killed-groups] ["Describe" gnus-group-describe-group :active (gnus-group-group-name) - ,@(if (featurep 'xemacs) nil - '(:help "Display description of the current group"))] + :help "Display description of 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 @@ -905,14 +889,14 @@ simple manner.") (memq (gnus-group-group-name) gnus-group-marked))] ["Unmark all" gnus-group-unmark-all-groups gnus-group-marked] ["Mark regexp..." gnus-group-mark-regexp t] - ["Mark region" gnus-group-mark-region :active (gnus-mark-active-p)] + ["Mark region" gnus-group-mark-region :active mark-active] ["Mark buffer" gnus-group-mark-buffer t] ["Execute command" gnus-group-universal-argument (or gnus-group-marked (gnus-group-group-name))]) ("Subscribe" ["Subscribe to a group..." gnus-group-unsubscribe-group t] ["Kill all newsgroups in region" gnus-group-kill-region - :active (gnus-mark-active-p)] + :active mark-active] ["Kill all zombie groups" gnus-group-kill-all-zombies gnus-zombie-list] ["Kill all groups on level..." gnus-group-kill-level t]) @@ -960,13 +944,9 @@ simple manner.") ["Send a message (mail or news)" gnus-group-post-news t] ["Create a local message" gnus-group-news t] ["Check for new news" gnus-group-get-new-news - ,@(if (featurep 'xemacs) '(t) - '(:help "Get newly arrived articles")) - ] + :help "Get newly arrived articles"] ["Send queued messages" gnus-delay-send-queue - ,@(if (featurep 'xemacs) '(t) - '(:help "Send all messages that are scheduled to be sent now")) - ] + :help "Send all messages that are scheduled to be sent now"] ["Activate all groups" gnus-activate-all-groups t] ["Restart Gnus" gnus-group-restart t] ["Read init file" gnus-group-read-init-file t] @@ -981,9 +961,7 @@ simple manner.") ["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 - ,@(if (featurep 'xemacs) '(t) - '(:help "Quit reading news"))] + ["Exit from Gnus" gnus-group-exit :help "Quit reading news"] ["Exit without saving" gnus-group-quit t])) (gnus-run-hooks 'gnus-group-menu-hook))) @@ -1101,18 +1079,14 @@ See `gmm-tool-bar-from-list' for the format of the list." (defun gnus-group-make-tool-bar (&optional force) "Make a group mode tool bar from `gnus-group-tool-bar'. When FORCE, rebuild the tool bar." - (when (and (not (featurep 'xemacs)) - (boundp 'tool-bar-mode) + (when (and (boundp 'tool-bar-mode) tool-bar-mode (display-graphic-p) (or (not gnus-group-tool-bar-map) force)) (let* ((load-path - (gmm-image-load-path-for-library "gnus" - "gnus/toggle-subscription.xpm" - nil t)) - (image-load-path (cons (car load-path) - (when (boundp 'image-load-path) - image-load-path))) + (image-load-path-for-library + "gnus" "gnus/toggle-subscription.xpm" nil t)) + (image-load-path (cons (car load-path) image-load-path)) (map (gmm-tool-bar-from-list gnus-group-tool-bar gnus-group-tool-bar-zap-list 'gnus-group-mode-map))) @@ -1167,7 +1141,7 @@ The following commands are available: (goto-char (point-min)) (setq gnus-group-mark-positions (list (cons 'process (and (search-forward - (mm-string-to-multibyte "\200") nil t) + (string-to-multibyte "\200") nil t) (- (point) (point-min) 1)))))))) (defun gnus-mouse-pick-group (e) @@ -1229,8 +1203,8 @@ The following commands are available: (defun gnus-group-name-decode (string charset) ;; Fixme: Don't decode in unibyte mode. - (if (and string charset (featurep 'mule)) - (mm-decode-coding-string string charset) + (if (and string charset) + (decode-coding-string string charset) string)) (defun gnus-group-decoded-name (string) @@ -1394,7 +1368,7 @@ if it is a string, only list groups matching REGEXP." (when (or gnus-group-listed-groups (and (>= level gnus-level-killed) (<= lowest gnus-level-killed))) (gnus-group-prepare-flat-list-dead - (gnus-union + (cl-union not-in-list (setq gnus-killed-list (sort gnus-killed-list 'string<)) :test 'equal) @@ -1418,7 +1392,7 @@ if it is a string, only list groups matching REGEXP." (or (not regexp) (and (stringp regexp) (string-match regexp group)) (and (functionp regexp) (funcall regexp group)))) - (gnus-add-text-properties + (add-text-properties (point) (prog1 (1+ (point)) (insert " " mark " *: " (gnus-group-decoded-name group) @@ -1510,13 +1484,10 @@ if it is a string, only list groups matching REGEXP." ;; Date: Mon, 23 Jan 2006 19:59:13 +0100 ;; Message-ID: <v9acdmrcse.fsf@marauder.physik.uni-ulm.de> -(defcustom gnus-group-update-tool-bar - (and (not (featurep 'xemacs)) - (boundp 'tool-bar-mode) - tool-bar-mode - ;; Using `redraw-frame' (see `gnus-tool-bar-update') in Emacs might - ;; be confusing, so maybe we shouldn't call it by default. - (fboundp 'force-window-update)) +;; Using `redraw-frame' (see `gnus-tool-bar-update') in Emacs might +;; be confusing, so maybe we shouldn't call it by default. +(defcustom gnus-group-update-tool-bar (and (boundp 'tool-bar-mode) + tool-bar-mode) "Force updating the group buffer tool bar." :group 'gnus-group :version "22.1" @@ -1597,7 +1568,7 @@ if it is a string, only list groups matching REGEXP." gnus-tmp-header) ; passed as parameter to user-funcs. (beginning-of-line) (setq beg (point)) - (gnus-add-text-properties + (add-text-properties (point) (prog1 (1+ (point)) ;; Insert the text. @@ -1625,58 +1596,42 @@ if it is a string, only list groups matching REGEXP." (progn (unless (bound-and-true-p cursor-sensor-mode) (cursor-sensor-mode 1)) - (gnus-put-text-property beg end 'cursor-sensor-functions + (put-text-property beg end 'cursor-sensor-functions '(gnus-tool-bar-update))) - (gnus-put-text-property beg end 'point-entered + (put-text-property beg end 'point-entered #'gnus-tool-bar-update) - (gnus-put-text-property beg end 'point-left + (put-text-property beg end 'point-left #'gnus-tool-bar-update)))) (defun gnus-group-update-eval-form (group list) "Eval `car' of each element of LIST, and return the first that return t. Some value are bound so the form can use them." - (defvar group-age) (defvar ticked) (defvar score) (defvar level) - (defvar mailp) (defvar total) (defvar unread) (when list (let* ((entry (gnus-group-entry group)) - (unread (if (numberp (car entry)) (car entry) 0)) (active (gnus-active group)) - (total (if active (1+ (- (cdr active) (car active))) 0)) (info (nth 2 entry)) - (method (inline (gnus-server-get-method group (gnus-info-method info)))) + (method (inline (gnus-server-get-method + group (gnus-info-method info)))) (marked (gnus-info-marks info)) - (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)))) - (group-age (gnus-group-timestamp-delta group))) - ;; 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: <E1IlvHM-0006TS-7t@fencepost.gnu.org> - ;; - ;; [...] - ;; 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. + (env + (list + (cons 'unread (if (numberp (car entry)) (car entry) 0)) + (cons 'total (if active (1+ (- (cdr active) (car active))) 0)) + (cons 'mailp (apply + 'append + (mapcar + (lambda (x) + (memq x (assoc + (symbol-name + (car (or method gnus-select-method))) + gnus-valid-select-methods))) + '(mail post-mail)))) + (cons 'level (or (gnus-info-level info) gnus-level-killed)) + (cons 'score (or (gnus-info-score info) 0)) + (cons 'ticked (gnus-range-length (cdr (assq 'tick marked)))) + (cons 'group-age (gnus-group-timestamp-delta group))))) (while (and list - (not (eval (caar list)))) + (not (eval (caar list) env))) (setq list (cdr list))) list))) @@ -1687,12 +1642,12 @@ and ends at END." (let ((face (cdar (gnus-group-update-eval-form group gnus-group-highlight)))) - (unless (eq face (gnus-get-text-property-excluding-characters-with-faces beg 'face)) + (unless (eq face (gnus-get-text-property-excluding-characters-with-faces + beg 'face)) (let ((inhibit-read-only t)) (gnus-put-text-property-excluding-characters-with-faces beg end 'face - (if (boundp face) (symbol-value face) face))) - (gnus-extent-start-open beg)))) + (if (boundp face) (symbol-value face) face)))))) (defun gnus-group-get-icon (group) "Return an icon for GROUP according to `gnus-group-icon-list'." @@ -1800,8 +1755,7 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated." (mode-string (eval gformat))) ;; Say whether the dribble buffer has been modified. (setq mode-line-modified - (if modified (car gnus-mode-line-modified) - (cdr gnus-mode-line-modified))) + (if modified "**" "--")) ;; If the line is too long, we chop it off. (when (> (length mode-string) max-len) (setq mode-string (substring mode-string 0 (- max-len 4)))) @@ -2028,7 +1982,7 @@ Take into consideration N (the prefix) and the list of marked groups." (setq n (1- n)) (gnus-group-next-group way))) (nreverse groups))) - ((and (gnus-region-active-p) (mark)) + ((and transient-mark-mode mark-active (mark)) ;; Work on the region between point and mark. (let ((max (max (point) (mark))) groups) @@ -2240,9 +2194,9 @@ if it is not a list." (member group (mapcar 'symbol-name collection)) (symbol-value (intern-soft group collection))) (setq group - (mm-encode-coding-string + (encode-coding-string group (gnus-group-name-charset nil group)))) - (gnus-replace-in-string group "\n" ""))) + (replace-regexp-in-string "\n" "" group))) ;;;###autoload (defun gnus-fetch-group (group &optional articles) @@ -2402,7 +2356,7 @@ specified by `gnus-gmane-group-download-format'." (unless range (setq range 500)) (when (< range 1) (error "Invalid range: %s" range)) - (let ((tmpfile (mm-make-temp-file + (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 @@ -2488,21 +2442,25 @@ the bug number, and browsing the URL must return mbox output." (setq ids (string-to-number ids))) (unless (listp ids) (setq ids (list ids))) - (let ((tmpfile (mm-make-temp-file "gnus-temp-group-"))) + (let ((tmpfile (make-temp-file "gnus-temp-group-"))) (let ((coding-system-for-write 'binary) (coding-system-for-read 'binary)) (with-temp-file tmpfile (mm-disable-multibyte) (dolist (id ids) - (url-insert-file-contents (format mbox-url id))) + (let ((file (format "~/.emacs.d/debbugs-cache/%s" id))) + (if (and (not gnus-plugged) + (file-exists-p file)) + (insert-file-contents file) + (url-insert-file-contents (format mbox-url id))))) (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" (car ids) - (gnus-replace-in-string - (gnus-replace-in-string mbox-url "^http://" "") - "/.*$" "")))))) + (replace-regexp-in-string + "/.*$" "" + (replace-regexp-in-string "^http://" "" mbox-url))))))) (gnus-group-read-ephemeral-group (format "nndoc+ephemeral:bug#%s" (mapconcat 'number-to-string ids ",")) @@ -2762,7 +2720,7 @@ server." (when (stringp method) (setq method (or (gnus-server-to-method method) method))) (unless encoded - (setq name (mm-encode-coding-string + (setq name (encode-coding-string name (gnus-group-name-charset method name)))) (let* ((meth (gnus-method-simplify @@ -2880,7 +2838,7 @@ and NEW-NAME will be prompted for." "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 + (list group (encode-coding-string new-name (gnus-group-name-charset method @@ -2951,7 +2909,7 @@ and NEW-NAME will be prompted for." (gnus-info-params info)) (t info)) ;; The proper documentation. - (gnus-format-message + (format-message "Editing the %s for `%s'." (cond ((eq part 'method) "select method") @@ -3094,9 +3052,9 @@ If called with a prefix argument, ask for the file type." (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)) + (setcar (cdr method) (encode-coding-string file coding)) (gnus-group-make-group - (mm-encode-coding-string (gnus-group-real-name name) coding) + (encode-coding-string (gnus-group-real-name name) coding) method nil nil t))) (defvar nnweb-type-definition) @@ -3173,8 +3131,8 @@ If there is, use Gnus to create an nnrss group" (coding (gnus-group-name-charset '(nnrss "") title))) (when coding ;; Unify non-ASCII text. - (setq title (mm-decode-coding-string - (mm-encode-coding-string title coding) + (setq title (decode-coding-string + (encode-coding-string title coding) coding))) (gnus-group-make-group title '(nnrss "")) (push (list title href desc) nnrss-group-alist) @@ -3279,7 +3237,7 @@ mail messages or news articles in files that have numeric names." (error "%s is not an nnimap group" group)) (unless (setq acl (nnimap-acl-get mailbox (cadr method))) (error "Server does not support ACL's")) - (gnus-edit-form acl (gnus-format-message "\ + (gnus-edit-form acl (format-message "\ Editing the access control list for `%s'. An access control list is a list of (identifier . rights) elements. @@ -4040,7 +3998,7 @@ entail asking the server for the groups." (erase-buffer) (while groups (setq group (pop groups)) - (gnus-add-text-properties + (add-text-properties (point) (prog1 (1+ (point)) (insert " *: " (gnus-group-decoded-name group) @@ -4162,22 +4120,23 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." (gnus-read-all-descriptions-files))) (error "Couldn't request descriptions file")) (let ((buffer-read-only nil) - b) - (erase-buffer) + b groups) (mapatoms (lambda (group) - (setq b (point)) - (let ((charset (gnus-group-name-charset nil (symbol-name group)))) - (insert (format " *: %-20s %s\n" - (gnus-group-name-decode - (symbol-name group) charset) - (gnus-group-name-decode - (symbol-value group) charset)))) - (gnus-add-text-properties - b (1+ b) (list 'gnus-group group - 'gnus-unread t 'gnus-marked nil - 'gnus-level (1+ gnus-level-subscribed)))) + (push (symbol-name group) groups)) gnus-description-hashtb) + (setq groups (sort groups 'string<)) + (erase-buffer) + (dolist (group groups) + (setq b (point)) + (let ((charset (gnus-group-name-charset nil group))) + (insert (format " *: %-20s %s\n" + (gnus-group-name-decode group charset) + (gnus-group-name-decode group charset)))) + (add-text-properties + b (1+ b) (list 'gnus-group (intern group gnus-description-hashtb) + 'gnus-unread t 'gnus-marked nil + 'gnus-level (1+ gnus-level-subscribed)))) (goto-char (point-min)) (gnus-group-position-point))) @@ -4533,7 +4492,7 @@ and the second element is the address." (if force (if (null articles) (setcar (nthcdr 3 info) - (gnus-delete-alist type (car marked))) + (assq-delete-all type (car marked))) (setcdr m (gnus-compress-sequence articles t))) (setcdr m (gnus-compress-sequence (sort (nconc (gnus-uncompress-range (cdr m)) @@ -4571,7 +4530,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 (time-subtract (current-time) time))) (+ (* (nth 0 delta) 65536.0) (nth 1 delta)))) @@ -4675,14 +4634,10 @@ 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) - (if (featurep 'xemacs) - (push (make-event 'key-press '(key ?A)) unread-command-events) - (push ?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)) - (read-key-sequence nil))) - (setq func (lookup-key (current-local-map) keys))) + (setq keys (read-key-sequence nil) + func (lookup-key (current-local-map) keys))) (if (or (not func) (numberp func)) (ding) |