;; 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,
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.
(defun gnus-group-name-charset (method group)
(if (null method)
(setq method (gnus-find-method-for-group group)))
- (let ((item (assoc method gnus-group-name-charset-method-alist))
+ (let ((item (or (assoc method gnus-group-name-charset-method-alist)
+ (and (consp method)
+ (assoc (list (car method) (cadr method))
+ gnus-group-name-charset-method-alist))))
(alist gnus-group-name-charset-group-alist)
result)
(if item
(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)
+(defun gnus-group-make-group (name &optional method address args encoded)
"Add a new newsgroup.
The user will be prompted for a NAME, for a select METHOD, and an
-ADDRESS."
+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."
(interactive
(list
(gnus-read-group "Group name: ")
(when (stringp method)
(setq method (or (gnus-server-to-method method) method)))
+ (unless encoded
+ (setq name (mm-encode-coding-string
+ name
+ (gnus-group-name-charset method name))))
(let* ((meth (gnus-method-simplify
(when (and method
(not (gnus-server-equal method gnus-select-method)))
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."
nil))))
(setq type found)))
(setq file (expand-file-name file))
- (let ((name (gnus-generate-new-group-name
- (gnus-group-prefixed-name
- (file-name-nondirectory file) '(nndoc ""))))
- (encodable (mm-coding-system-p 'utf-8)))
+ (let* ((name (gnus-generate-new-group-name
+ (gnus-group-prefixed-name
+ (file-name-nondirectory file) '(nndoc ""))))
+ (method (list 'nndoc file
+ (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))
(gnus-group-make-group
- (if encodable
- (mm-encode-coding-string (gnus-group-real-name name) 'utf-8)
- (gnus-group-real-name name))
- (list 'nndoc (if encodable
- (mm-encode-coding-string file 'utf-8)
- file)
- (list 'nndoc-address file)
- (list 'nndoc-article-type (or type 'guess))))))
+ (mm-encode-coding-string (gnus-group-real-name name) coding)
+ method nil nil t)))
(defvar nnweb-type-definition)
(defvar gnus-group-web-type-history nil)
(setq url (read-from-minibuffer "URL to Search for RSS: ")))
(let ((feedinfo (nnrss-discover-feed url)))
(if feedinfo
- (let ((title (gnus-newsgroup-savable-name
- (read-from-minibuffer "Title: "
- (gnus-newsgroup-savable-name
- (or (cdr (assoc 'title
- feedinfo))
- "")))))
- (desc (read-from-minibuffer "Description: "
- (cdr (assoc 'description
- feedinfo))))
- (href (cdr (assoc 'href feedinfo)))
- (encodable (mm-coding-system-p 'utf-8)))
- (when encodable
+ (let* ((title (gnus-newsgroup-savable-name
+ (read-from-minibuffer "Title: "
+ (gnus-newsgroup-savable-name
+ (or (cdr (assoc 'title
+ feedinfo))
+ "")))))
+ (desc (read-from-minibuffer "Description: "
+ (cdr (assoc 'description
+ feedinfo))))
+ (href (cdr (assoc 'href feedinfo)))
+ (coding (gnus-group-name-charset '(nnrss "") title)))
+ (when coding
;; Unify non-ASCII text.
(setq title (mm-decode-coding-string
- (mm-encode-coding-string title 'utf-8) 'utf-8)))
- (gnus-group-make-group (if encodable
- (mm-encode-coding-string title 'utf-8)
- title)
- '(nnrss ""))
+ (mm-encode-coding-string title coding)
+ coding)))
+ (gnus-group-make-group title '(nnrss ""))
(push (list title href desc) nnrss-group-alist)
(nnrss-save-server-data nil))
(error "No feeds found for %s" 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
(if (stringp method) method
(prin1-to-string (car method)))
(and (consp method)
- (nth 1 (gnus-info-method info))))
+ (nth 1 (gnus-info-method info)))
+ nil t)
;; It's a native group.
- (gnus-group-make-group (gnus-info-group info))))
+ (gnus-group-make-group (gnus-info-group info) nil nil nil t)))
(gnus-message 6 "Note: New group created")
(setq entry
(gnus-group-entry (gnus-group-prefixed-name
projects / gnus / blobdiff