;; 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)
+;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;;; Code:
(eval-when-compile
- (require 'cl)
- (defvar tool-bar-mode))
+ (require 'cl))
+(defvar tool-bar-mode)
(require 'gnus)
(require 'gnus-start)
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."
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.
(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: <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.
(while (and list
(not (eval (caar list))))
(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))
(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)
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"))
(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 encoded)
"Add a new newsgroup.
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"))
(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."
(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)
"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)
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
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
(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
projects / gnus / blobdiff