Revision: emacs@sv.gnu.org/emacs--devo--0--patch-93

Merge from gnus--rel--5.10

Patches applied:

 * gnus--rel--5.10  (patch 30-34)

   - Merge from emacs--devo--0
   - Update from CVS

7 files changed, 206 insertions, 42 deletions

diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index adca02f5b95..4ac3982fb44 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -7,6 +7,39 @@
 
         * gnus-cus.el: Revert 2005-10-17 change.
 
+2006-02-16  Katsumi Yamaoka  <yamaoka@jpl.org>
+
+        * gnus-art.el (article-strip-banner): Use
+        gnus-extract-address-components instead of
+        mail-header-parse-addresses to make it work with non-ASCII text.
+
+        * rfc2231.el (rfc2231-parse-string): Attempt to parse parameter
+        values which are surrounded with \"...\"; make it never cause a
+        Lisp error; give up parsing of parameters if it failed in
+        extracting type.
+
+2006-02-15  Katsumi Yamaoka  <yamaoka@jpl.org>
+
+        * mm-util.el (mm-make-temp-file): Import the Emacs 22 version of
+        make-temp-file; make it work with Emacs 20 and XEmacs as well.
+
+        * mm-decode.el (mm-display-external): Use the 3rd arg of
+        mm-make-temp-file.
+        (mm-create-image-xemacs): Ditto.
+
+2006-02-14  Katsumi Yamaoka  <yamaoka@jpl.org>
+
+        * gnus-draft.el (gnus-draft-send): Replace message-narrow-to-head
+        with message-narrow-to-headers.
+        (gnus-draft-setup): Narrow to header to run message-fetch-field.
+        (gnus-draft-check-draft-articles): New function.
+        (gnus-draft-edit-message, gnus-draft-send-message): Use it.
+
+2006-02-13  Katsumi Yamaoka  <yamaoka@jpl.org>
+
+        * nnoo.el (nnoo-declare): Don't generate duplicate entries when
+        re-loading nn* modules.
+
 2006-02-10  Reiner Steib  <Reiner.Steib@gmx.de>
 
         * gnus.el: Remove bogus comment.
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index c15151729a0..0d9b5f4be5a 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -2608,6 +2608,9 @@ always hide."
           (article-really-strip-banner
            (gnus-parameter-banner gnus-newsgroup-name)))
         (when gnus-article-address-banner-alist
+          ;; Note that the From header is decoded here, so it is
+          ;; required that the *-extract-address-components function
+          ;; supports non-ASCII text.
           (article-really-strip-banner
            (let ((from (save-restriction
                          (widen)
@@ -2615,7 +2618,8 @@ always hide."
                          (mail-fetch-field "from"))))
              (when (and from
                         (setq from
-                              (caar (mail-header-parse-addresses from))))
+                              (cadr (funcall gnus-extract-address-components
+                                             from))))
                (catch 'found
                  (dolist (pair gnus-article-address-banner-alist)
                    (when (string-match (car pair) from)
diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el
index 0d250a3ad0b..f9ff9d7122e 100644
--- a/lisp/gnus/gnus-draft.el
+++ b/lisp/gnus/gnus-draft.el
@@ -98,6 +98,7 @@
   (interactive)
   (let ((article (gnus-summary-article-number))
         (group gnus-newsgroup-name))
+    (gnus-draft-check-draft-articles (list article))
     (gnus-summary-mark-as-read article gnus-canceled-mark)
     (gnus-draft-setup article group t)
     (set-buffer-modified-p t)
@@ -122,6 +123,7 @@
   (let* ((articles (gnus-summary-work-articles n))
          (total (length articles))
          article)
+    (gnus-draft-check-draft-articles articles)
     (while (setq article (pop articles))
       (gnus-summary-remove-process-mark article)
       (unless (memq article gnus-newsgroup-unsendable)
@@ -152,7 +154,7 @@
     ;; We read the meta-information that says how and where
     ;; this message is to be sent.
     (save-restriction
-      (message-narrow-to-head)
+      (message-narrow-to-headers)
       (when (re-search-forward
              (concat "^" (regexp-quote gnus-agent-target-move-group-header)
                      ":") nil t)
@@ -258,9 +260,12 @@
             (goto-char (point-min))
             (search-forward "\n\n")
             (forward-char -1)
+            (save-restriction
+              (narrow-to-region (point-min) (point))
+              (setq ga
+                    (message-fetch-field gnus-draft-meta-information-header)))
             (insert mail-header-separator)
             (forward-line 1)
-            (setq ga (message-fetch-field gnus-draft-meta-information-header))
             (message-set-auto-save-file-name))))
       (gnus-backlog-remove-article group narticle)
       (when (and ga
@@ -285,6 +290,32 @@
   "Say whether ARTICLE is sendable."
   (not (memq article gnus-newsgroup-unsendable)))
 
+(defun gnus-draft-check-draft-articles (articles)
+  "Check whether the draft articles ARTICLES are under edit."
+  (when (equal gnus-newsgroup-name "nndraft:drafts")
+    (let ((buffers (buffer-list))
+          file buffs buff)
+      (save-current-buffer
+        (while (and articles
+                    (not buff))
+          (setq file (nndraft-article-filename (pop articles))
+                buffs buffers)
+          (while buffs
+            (set-buffer (setq buff (pop buffs)))
+            (if (and buffer-file-name
+                     (string-equal (file-truename buffer-file-name)
+                                   (file-truename file))
+                     (buffer-modified-p))
+                (setq buffs nil)
+              (setq buff nil)))))
+      (when buff
+        (let* ((window (get-buffer-window buff t))
+               (frame (and window (window-frame window))))
+          (if frame
+              (gnus-select-frame-set-input-focus frame)
+            (pop-to-buffer buff t)))
+        (error "The draft %s is under edit" file)))))
+
 (provide 'gnus-draft)
 
 ;;; arch-tag: 3d92af58-8c97-4a5c-9db4-a98e85198022
diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el
index 996c934191c..fa77b7776f0 100644
--- a/lisp/gnus/mm-decode.el
+++ b/lisp/gnus/mm-decode.el
@@ -769,19 +769,18 @@ external if displayed external."
                           (gnus-map-function mm-file-name-rewrite-functions
                                              (file-name-nondirectory filename))
                           dir))
-            (setq file (mm-make-temp-file (expand-file-name "mm." dir)))
-            (let ((newname
-                   ;; Use nametemplate (defined in RFC1524) if it is
-                   ;; specified in mailcap.
-                   (if (assoc "nametemplate" mime-info)
-                       (format (cdr (assoc "nametemplate" mime-info)) file)
-                     ;; Add a suffix according to `mailcap-mime-extensions'.
-                     (concat file (car (rassoc (mm-handle-media-type handle)
-                                               mailcap-mime-extensions))))))
-              (unless (string-equal file newname)
-                (when (file-exists-p file)
-                  (rename-file file newname))
-                (setq file newname))))
+            ;; Use nametemplate (defined in RFC1524) if it is specified
+            ;; in mailcap.
+            (let ((suffix (cdr (assoc "nametemplate" mime-info))))
+              (if (and suffix
+                       (string-match "\\`%s\\(\\..+\\)\\'" suffix))
+                  (setq suffix (match-string 1 suffix))
+                ;; Otherwise, use a suffix according to
+                ;; `mailcap-mime-extensions'.
+                (setq suffix (car (rassoc (mm-handle-media-type handle)
+                                          mailcap-mime-extensions))))
+              (setq file (mm-make-temp-file (expand-file-name "mm." dir)
+                                            nil suffix))))
           (let ((coding-system-for-write mm-binary-coding-system))
             (write-region (point-min) (point-max) file nil 'nomesg))
           (message "Viewing with %s" method)
@@ -1312,8 +1311,8 @@ be determined."
     ;; out to a file, and then create a file
     ;; specifier.
     (let ((file (mm-make-temp-file
-                 (expand-file-name "emm.xbm"
-                                   mm-tmp-directory))))
+                 (expand-file-name "emm" mm-tmp-directory)
+                 nil ".xbm")))
       (unwind-protect
           (progn
             (write-region (point-min) (point-max) file)
diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el
index c8f59ec263f..9bdbc3c72b1 100644
--- a/lisp/gnus/mm-util.el
+++ b/lisp/gnus/mm-util.el
@@ -99,16 +99,6 @@
            (lambda (ch) (mm-string-as-multibyte (char-to-string ch)))
            string "")))
      (multibyte-string-p . ignore)
-     ;; It is not a MIME function, but some MIME functions use it.
-     (make-temp-file . (lambda (prefix &optional dir-flag)
-                         (let ((file (expand-file-name
-                                      (make-temp-name prefix)
-                                      (if (fboundp 'temp-directory)
-                                          (temp-directory)
-                                        temporary-file-directory))))
-                           (if dir-flag
-                               (make-directory file))
-                           file)))
      (insert-byte . insert-char)
      (multibyte-char-to-unibyte . identity))))
 
@@ -971,6 +961,77 @@ If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'."
            inhibit-file-name-handlers)))
     (write-region start end filename append visit lockname)))
 
+;; It is not a MIME function, but some MIME functions use it.
+(if (and (fboundp 'make-temp-file)
+         (ignore-errors
+           (let ((def (symbol-function 'make-temp-file)))
+             (and (byte-code-function-p def)
+                  (setq def (if (fboundp 'compiled-function-arglist)
+                                ;; XEmacs
+                                (eval (list 'compiled-function-arglist def))
+                              (aref def 0)))
+                  (>= (length def) 4)
+                  (eq (nth 3 def) 'suffix)))))
+    (defalias 'mm-make-temp-file 'make-temp-file)
+  ;; Stolen (and modified for Emacs 20 and XEmacs) from Emacs 22.
+  (defun mm-make-temp-file (prefix &optional dir-flag suffix)
+    "Create a temporary file.
+The returned file name (created by appending some random characters at the end
+of PREFIX, and expanding against `temporary-file-directory' if necessary),
+is guaranteed to point to a newly created empty file.
+You can then use `write-region' to write new data into the file.
+
+If DIR-FLAG is non-nil, create a new empty directory instead of a file.
+
+If SUFFIX is non-nil, add that at the end of the file name."
+    (let ((umask (default-file-modes))
+          file)
+      (unwind-protect
+          (progn
+            ;; Create temp files with strict access rights.  It's easy to
+            ;; loosen them later, whereas it's impossible to close the
+            ;; time-window of loose permissions otherwise.
+            (set-default-file-modes 448)
+            (while (condition-case err
+                       (progn
+                         (setq file
+                               (make-temp-name
+                                (expand-file-name
+                                 prefix
+                                 (if (fboundp 'temp-directory)
+                                     ;; XEmacs
+                                     (temp-directory)
+                                   temporary-file-directory))))
+                         (if suffix
+                             (setq file (concat file suffix)))
+                         (if dir-flag
+                             (make-directory file)
+                           (if (or (featurep 'xemacs)
+                                   (= emacs-major-version 20))
+                               ;; NOTE: This is unsafe if Emacs 20
+                               ;; users and XEmacs users don't use
+                               ;; a secure temp directory.
+                               (if (file-exists-p file)
+                                   (signal 'file-already-exists
+                                           (list "File exists" file))
+                                 (write-region "" nil file nil 'silent))
+                             (write-region "" nil file nil 'silent
+                                           nil 'excl)))
+                         nil)
+                     (file-already-exists t)
+                     ;; The Emacs 20 and XEmacs versions of
+                     ;; `make-directory' issue `file-error'.
+                     (file-error (or (and (or (featurep 'xemacs)
+                                              (= emacs-major-version 20))
+                                          (file-exists-p file))
+                                     (signal (car err) (cdr err)))))
+              ;; the file was somehow created by someone else between
+              ;; `make-temp-name' and `write-region', let's try again.
+              nil)
+            file)
+        ;; Reset the umask.
+        (set-default-file-modes umask)))))
+
 (defun mm-image-load-path (&optional package)
   (let (dir result)
     (dolist (path load-path (nreverse result))
diff --git a/lisp/gnus/nnoo.el b/lisp/gnus/nnoo.el
index 7a66b4c55aa..122183057b9 100644
--- a/lisp/gnus/nnoo.el
+++ b/lisp/gnus/nnoo.el
@@ -61,12 +61,16 @@
 
 (defmacro nnoo-declare (backend &rest parents)
   `(eval-and-compile
-     (push (list ',backend
-                 (mapcar (lambda (p) (list p)) ',parents)
-                 nil nil)
-           nnoo-definition-alist)
-     (push (list ',backend "*internal-non-initialized-backend*")
-           nnoo-state-alist)))
+     (if (assq ',backend nnoo-definition-alist)
+         (setcar (cdr (assq ',backend nnoo-definition-alist))
+                 (mapcar 'list ',parents))
+       (push (list ',backend
+                   (mapcar 'list ',parents)
+                   nil nil)
+             nnoo-definition-alist))
+     (unless (assq ',backend nnoo-state-alist)
+       (push (list ',backend "*internal-non-initialized-backend*")
+             nnoo-state-alist))))
 (put 'nnoo-declare 'lisp-indent-function 1)
 
 (defun nnoo-parents (backend)
diff --git a/lisp/gnus/rfc2231.el b/lisp/gnus/rfc2231.el
index 7b4cf2447f4..2099b20195d 100644
--- a/lisp/gnus/rfc2231.el
+++ b/lisp/gnus/rfc2231.el
@@ -47,15 +47,45 @@ The list will be on the form
  `(name (attribute . value) (attribute . value)...)'.
 
 If the optional SIGNAL-ERROR is non-nil, signal an error when this
-function fails in parsing of parameters."
+function fails in parsing of parameters.  Otherwise, this function
+must never cause a Lisp error."
   (with-temp-buffer
     (let ((ttoken (ietf-drums-token-to-list ietf-drums-text-token))
           (stoken (ietf-drums-token-to-list ietf-drums-tspecials))
           (ntoken (ietf-drums-token-to-list "0-9"))
           c type attribute encoded number prev-attribute vals
           prev-encoded parameters value)
-      (ietf-drums-init (mail-header-remove-whitespace
-                        (mail-header-remove-comments string)))
+      (ietf-drums-init
+       (condition-case nil
+           (mail-header-remove-whitespace
+            (mail-header-remove-comments string))
+         ;; The most likely cause of an error is unbalanced parentheses
+         ;; or double-quotes.  If all parentheses and double-quotes are
+         ;; quoted meaninglessly with backslashes, removing them might
+         ;; make it parseable.  Let's try...
+         (error
+          (let (mod)
+            (when (and (string-match "\\\\\"" string)
+                       (not (string-match "\\`\"\\|[^\\]\"" string)))
+              (setq string (mm-replace-in-string string "\\\\\"" "\"")
+                    mod t))
+            (when (and (string-match "\\\\(" string)
+                       (string-match "\\\\)" string)
+                       (not (string-match "\\`(\\|[^\\][()]" string)))
+              (setq string (mm-replace-in-string string "\\\\\\([()]\\)" "\\1")
+                    mod t))
+            (or (and mod
+                     (ignore-errors
+                       (mail-header-remove-whitespace
+                        (mail-header-remove-comments string))))
+                ;; Finally, attempt to extract only type.
+                (if (string-match
+                     (concat "\\`[\t\n ]*\\([^" ietf-drums-tspecials "\t\n ]+"
+                             "\\(/[^" ietf-drums-tspecials
+                             "\t\n ]+\\)?\\)\\([\t\n ;]\\|\\'\\)")
+                     string)
+                    (match-string 1 string)
+                  ""))))))
       (let ((table (copy-syntax-table ietf-drums-syntax-table)))
         (modify-syntax-entry ?\' "w" table)
         (modify-syntax-entry ?* " " table)
@@ -67,9 +97,12 @@ function fails in parsing of parameters."
         (set-syntax-table table))
       (setq c (char-after))
       (when (and (memq c ttoken)
-                 (not (memq c stoken)))
-        (setq type (downcase (buffer-substring
-                              (point) (progn (forward-sexp 1) (point)))))
+                 (not (memq c stoken))
+                 (setq type (ignore-errors
+                              (downcase
+                               (buffer-substring (point) (progn
+                                                           (forward-sexp 1)
+                                                           (point)))))))
         ;; Do the params
         (condition-case err
             (progn
@@ -180,8 +213,7 @@ function fails in parsing of parameters."
              ;;(message "%s" (error-message-string err))
              )))
 
-        (when type
-          `(,type ,@(nreverse parameters)))))))
+        (cons type (nreverse parameters))))))
 
 (defun rfc2231-decode-encoded-string (string)
   "Decode an RFC2231-encoded string.