* mm-util.el (mm-charset-eval-alist): Mark as risky local variable.

[gnus] / lisp / gnus-group.el

diff --git a/lisp/gnus-group.el b/lisp/gnus-group.el
index e0bfd9c..97eb37a 100644 (file)
--- a/lisp/gnus-group.el
+++ b/lisp/gnus-group.el
@@ -10,7 +10,7 @@
 
 ;; 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
 
 ;; 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,
 ;; any later version.
 
 ;; GNU Emacs is distributed in the hope that it will be useful,


@@ -382,6 +382,7 @@ score: The score of the group.
 ticked: The number of ticked articles."
   :group 'gnus-group-visual
   :type '(repeat (cons (sexp :tag "Form") face)))
 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."
 
 (defcustom gnus-new-mail-mark ?%
   "Mark used for groups with new mail."


@@ -419,6 +420,7 @@ score: The score of the group.
 ticked: The number of ticked articles."
   :group 'gnus-group-icons
   :type '(repeat (cons (sexp :tag "Form") file)))
 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.
 
 (defcustom gnus-group-name-charset-method-alist nil
   "Alist of method and the charset for group names.


@@ -2113,28 +2115,84 @@ be permanent."
     (gnus-group-read-ephemeral-group
      (gnus-group-prefixed-name group method) method)))
 
     (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."
 
 ;;;###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))
 
     (gnus-no-server))
   (gnus-group-read-group (if articles nil t) nil group articles))
 


@@ -2194,10 +2252,7 @@ Return the name of the group if selection was successful."
   (interactive
    (list
     ;; (gnus-read-group "Group name: ")
   (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)
     (gnus-read-method "From method: ")))
   ;; Transform the select method into a unique server.
   (when (stringp method)


@@ -2249,17 +2304,14 @@ Return the name of the group if selection was successful."
 If PROMPT (the prefix) is a number, use the prompt specified in
 `gnus-group-jump-to-group-prompt'."
   (interactive
 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"))
 
   (when (equal group "")
     (error "Empty group name"))


@@ -2450,17 +2502,16 @@ If EXCLUDE-GROUP, do not go to that group."
 (defun gnus-group-make-group-simple (&optional group)
   "Add a new newsgroup.
 The user will be prompted for GROUP."
 (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
   "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: ")
   (interactive
    (list
     (gnus-read-group "Group name: ")


@@ -2468,6 +2519,10 @@ ADDRESS."
 
   (when (stringp method)
     (setq method (or (gnus-server-to-method method) method)))
 
   (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)))
   (let* ((meth (gnus-method-simplify
                (when (and method
                           (not (gnus-server-equal method gnus-select-method)))


@@ -2759,19 +2814,17 @@ If called with a prefix argument, ask for the file type."
                             nil))))
       (setq type found)))
   (setq file (expand-file-name file))
                             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
     (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)
 
 (defvar nnweb-type-definition)
 (defvar gnus-group-web-type-history nil)


@@ -2825,25 +2878,23 @@ If there is, use Gnus to create an nnrss group"
       (setq url (read-from-minibuffer "URL to Search for RSS: ")))
   (let ((feedinfo (nnrss-discover-feed url)))
     (if feedinfo
       (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
            ;; 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))))
          (push (list title href desc) nnrss-group-alist)
          (nnrss-save-server-data nil))
       (error "No feeds found for %s" url))))


@@ -3537,12 +3588,8 @@ If given numerical prefix, toggle the N next groups."
   "Toggle subscription to GROUP.
 Killed newsgroups are subscribed.  If SILENT, don't try to update the
 group line."
   "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)
   (let ((newsrc (gnus-group-entry group)))
     (cond
      ((string-match "^[ \t]*$" group)


@@ -3929,7 +3976,7 @@ to use."
 If given a prefix argument, prompt for a group."
   (interactive
    (list (or (when current-prefix-arg
 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-group-group-name)
             gnus-newsgroup-name)))
   (unless group


@@ -3957,7 +4004,7 @@ If given a prefix argument, prompt for a group."
 If given a prefix argument, prompt for a group."
   (interactive
    (list (or (when current-prefix-arg
 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-group-group-name)
             gnus-newsgroup-name)))
   (unless group


@@ -4183,12 +4230,12 @@ The hook `gnus-suspend-gnus-hook' is called before actually suspending."
   (gnus-offer-save-summaries)
   ;; Kill Gnus buffers except for group mode buffer.
   (let ((group-buf (get-buffer gnus-group-buffer)))
   (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
     (setq gnus-backlog-articles nil)
     (gnus-kill-gnus-frames)
     (when group-buf


@@ -4313,9 +4360,10 @@ and the second element is the address."
                 (if (stringp method) method
                   (prin1-to-string (car method)))
                 (and (consp method)
                 (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.
              ;; 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
          (gnus-message 6 "Note: New group created")
          (setq entry
                (gnus-group-entry (gnus-group-prefixed-name