Mercurial > emacs
changeset 68940:808f636eb13e
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
| author | Miles Bader <miles@gnu.org> |
|---|---|
| date | Fri, 17 Feb 2006 00:24:04 +0000 |
| parents | 2eed293b58ff |
| children | b41d1af1839d |
| files | lisp/gnus/ChangeLog lisp/gnus/gnus-art.el lisp/gnus/gnus-draft.el lisp/gnus/mm-decode.el lisp/gnus/mm-util.el lisp/gnus/nnoo.el lisp/gnus/rfc2231.el |
| diffstat | 7 files changed, 206 insertions(+), 42 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/gnus/ChangeLog Fri Feb 17 00:23:58 2006 +0000 +++ b/lisp/gnus/ChangeLog Fri Feb 17 00:24:04 2006 +0000 @@ -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.
--- a/lisp/gnus/gnus-art.el Fri Feb 17 00:23:58 2006 +0000 +++ b/lisp/gnus/gnus-art.el Fri Feb 17 00:24:04 2006 +0000 @@ -2608,6 +2608,9 @@ (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 @@ (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)
--- a/lisp/gnus/gnus-draft.el Fri Feb 17 00:23:58 2006 +0000 +++ b/lisp/gnus/gnus-draft.el Fri Feb 17 00:24:04 2006 +0000 @@ -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
--- a/lisp/gnus/mm-decode.el Fri Feb 17 00:23:58 2006 +0000 +++ b/lisp/gnus/mm-decode.el Fri Feb 17 00:24:04 2006 +0000 @@ -769,19 +769,18 @@ (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 @@ ;; 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)
--- a/lisp/gnus/mm-util.el Fri Feb 17 00:23:58 2006 +0000 +++ b/lisp/gnus/mm-util.el Fri Feb 17 00:24:04 2006 +0000 @@ -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 @@ 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))
--- a/lisp/gnus/nnoo.el Fri Feb 17 00:23:58 2006 +0000 +++ b/lisp/gnus/nnoo.el Fri Feb 17 00:24:04 2006 +0000 @@ -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)
--- a/lisp/gnus/rfc2231.el Fri Feb 17 00:23:58 2006 +0000 +++ b/lisp/gnus/rfc2231.el Fri Feb 17 00:24:04 2006 +0000 @@ -47,15 +47,45 @@ `(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 @@ (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 @@ ;;(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.