X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmm-decode.el;h=5d7f013eaac243da396a9ab162a590116232d04f;hb=18a84c10a7e5ab2e9609ff14da3dc3a3e60b9803;hp=f347a5c62e3a8b6ea5b4739ef8e44f4de991d5ec;hpb=4e6ed4bd8e175ab78acf62b8f5e9a8af0e703992;p=gnus diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index f347a5c62..5d7f013ea 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -1,6 +1,6 @@ ;;; mm-decode.el --- Functions for decoding MIME things -;; Copyright (C) 1998, 1999, 2000, 2001, 2002, -;; 2003 Free Software Foundation, Inc. +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko @@ -100,20 +100,23 @@ (defcustom mm-text-html-renderer (cond ((locate-library "w3") 'w3) ((locate-library "w3m") 'w3m) + ((executable-find "w3m") 'w3m-standalone) ((executable-find "links") 'links) ((executable-find "lynx") 'lynx) (t 'html2text)) "Render of HTML contents. It is one of defined renderer types, or a rendering function. The defined renderer types are: -`w3' : using Emacs/W3; -`w3m' : using emacs-w3m; -`links': using links; -`lynx' : using lynx; -`html2text' : using html2text; -nil : using external viewer." +`w3' : use Emacs/W3; +`w3m' : use emacs-w3m; +`w3m-standalone': use w3m; +`links': use links; +`lynx' : use lynx; +`html2text' : use html2text; +nil : use external viewer." :type '(choice (const w3) (const w3m) + (const w3m-standalone) (const links) (const lynx) (const html2text) @@ -127,20 +130,24 @@ nil : using external viewer." It is suggested to customize `mm-text-html-renderer' instead.") (defcustom mm-inline-text-html-with-images nil - "If non-nil, Gnus will allow retrieving images in the HTML contents -with tags. It has no effect on Emacs/w3. See also -the documentation for the option `mm-w3m-safe-url-regexp'." + "If non-nil, Gnus will allow retrieving images in HTML contents with +the tags. It has no effect on Emacs/w3. See also the +documentation for the `mm-w3m-safe-url-regexp' variable." :type 'boolean :group 'mime-display) (defcustom mm-w3m-safe-url-regexp "\\`cid:" - "Regexp that matches safe url names. Some HTML mails might have a -trick of spammers using tags. It is likely to be intended to -verify whether you have read the mail. You can prevent your personal -informations from leaking by setting this to the regexp which matches -the safe url names. The value of the variable `w3m-safe-url-regexp' -will be bound with this value. You may set this value to nil if you -consider all the urls to be safe." + "Regexp matching URLs which are considered to be safe. +Some HTML mails might contain a nasty trick used by spammers, using +the tag which is far more evil than the [Click Here!] button. +It is most likely intended to check whether the ominous spam mail has +reached your eyes or not, in which case the spammer knows for sure +that your email address is valid. It is done by embedding an +identifier string into a URL that you might automatically retrieve +when displaying the image. The default value is \"\\\\`cid:\" which only +matches parts embedded to the Multipart/Related type MIME contents and +Gnus will never connect to the spammer's site arbitrarily. You may +set this variable to nil if you consider all urls to be safe." :type '(choice (regexp :tag "Regexp") (const :tag "All URLs are safe" nil)) :group 'mime-display) @@ -150,8 +157,20 @@ consider all the urls to be safe." :type 'boolean :group 'mime-display) +(defcustom mm-enable-external t + "Indicate whether external MIME handlers should be used. + +If t, all defined external MIME handlers are used. If nil, files are saved by +`mailcap-save-binary-file'. If it is the symbol `ask', you are prompted +before the external MIME handler is invoked." + :version "21.4" + :type '(choice (const :tag "Always" t) + (const :tag "Never" nil) + (const :tag "Ask" ask)) + :group 'mime-display) + (defcustom mm-inline-media-tests - '(("image/jpeg" + '(("image/p?jpeg" mm-inline-image (lambda (handle) (mm-valid-and-fit-image-p 'jpeg handle))) @@ -237,7 +256,7 @@ consider all the urls to be safe." ;; Default to displaying as text (".*" mm-inline-text mm-readable-p)) "Alist of media types/tests saying whether types can be displayed inline." - :type '(repeat (list (string :tag "MIME type") + :type '(repeat (list (regexp :tag "MIME type") (function :tag "Display function") (function :tag "Display test"))) :group 'mime-display) @@ -308,9 +327,11 @@ to: :group 'mime-display) (defcustom mm-tmp-directory - (cond ((fboundp 'temp-directory) (temp-directory)) - ((boundp 'temporary-file-directory) temporary-file-directory) - ("/tmp/")) + (if (fboundp 'temp-directory) + (temp-directory) + (if (boundp 'temporary-file-directory) + temporary-file-directory + "/tmp/")) "Where mm will store its temporary files." :type 'directory :group 'mime-display) @@ -320,11 +341,14 @@ to: :type 'boolean :group 'mime-display) -(defvar mm-file-name-rewrite-functions nil +(defvar mm-file-name-rewrite-functions + '(mm-file-name-delete-control mm-file-name-delete-gotchas) "*List of functions used for rewriting file names of MIME parts. Each function takes a file name as input and returns a file name. Ready-made functions include +`mm-file-name-delete-control' +`mm-file-name-delete-gotchas' `mm-file-name-delete-whitespace', `mm-file-name-trim-whitespace', `mm-file-name-collapse-whitespace', @@ -333,10 +357,10 @@ Ready-made functions include `upcase-initials'.") (defvar mm-path-name-rewrite-functions nil - "*List of functions used for rewriting path names of MIME parts. -This is used when viewing parts externally , and is meant for -transforming the path name so that non-compliant programs can -find the file where it's saved. + "*List of functions for rewriting the full file names of MIME parts. +This is used when viewing parts externally, and is meant for +transforming the absolute name so that non-compliant programs can find +the file where it's saved. Each function takes a file name as input and returns a file name.") @@ -349,6 +373,11 @@ If not set, `default-directory' will be used." :type '(choice directory (const :tag "Default" nil)) :group 'mime-display) +(defcustom mm-attachment-file-modes 384 + "Set the mode bits of saved attachments to this integer." + :type 'integer + :group 'mime-display) + (defcustom mm-external-terminal-program "xterm" "The program to start an external terminal." :type 'string @@ -382,7 +411,7 @@ If not set, `default-directory' will be used." (defcustom mm-verify-option 'never "Option of verifying signed parts. `never', not verify; `always', always verify; -`known', only verify known protocols. Otherwise, ask user." +`known', only verify known protocols. Otherwise, ask user." :type '(choice (item always) (item never) (item :tag "only known protocols" known) @@ -400,7 +429,7 @@ If not set, `default-directory' will be used." (defcustom mm-decrypt-option nil "Option of decrypting encrypted parts. `never', not decrypt; `always', always decrypt; -`known', only decrypt known protocols. Otherwise, ask user." +`known', only decrypt known protocols. Otherwise, ask user." :type '(choice (item always) (item never) (item :tag "only known protocols" known) @@ -456,8 +485,9 @@ The original alist is not modified. See also `destructive-alist-to-plist'." (throw 'found t)))))) (defun mm-handle-set-external-undisplayer (handle function) - "Set the undisplayer for this handle; postpone undisplaying of viewers -for types in mm-keep-viewer-alive-types." + "Set the undisplayer for HANDLE to FUNCTION. +Postpone undisplaying of viewers for types in +`mm-keep-viewer-alive-types'." (if (mm-keep-viewer-alive-p handle) (let ((new-handle (copy-sequence handle))) (mm-handle-set-undisplayer new-handle function) @@ -513,7 +543,8 @@ for types in mm-keep-viewer-alive-types." ((equal type "multipart") (let ((mm-dissect-default-type (if (equal subtype "digest") "message/rfc822" - "text/plain"))) + "text/plain")) + (start (cdr (assq 'start (cdr ctl))))) (add-text-properties 0 (length (car ctl)) (mm-alist-to-plist (cdr ctl)) (car ctl)) @@ -523,10 +554,9 @@ for types in mm-keep-viewer-alive-types." ;; the mm-handle API so we simply store the multipart buffert ;; name as a text property of the "multipart/whatever" string. (add-text-properties 0 (length (car ctl)) - (list 'buffer (mm-copy-to-buffer)) - (car ctl)) - (add-text-properties 0 (length (car ctl)) - (list 'from from) + (list 'buffer (mm-copy-to-buffer) + 'from from + 'start start) (car ctl)) (cons (car ctl) (mm-dissect-multipart ctl)))) (t @@ -615,7 +645,13 @@ external if displayed external." (if (mm-handle-displayed-p handle) (mm-remove-part handle) (let* ((type (mm-handle-media-type handle)) - (method (mailcap-mime-info type))) + (method (mailcap-mime-info type)) + (filename (or (mail-content-type-get + (mm-handle-disposition handle) 'filename) + (mail-content-type-get + (mm-handle-type handle) 'name) + "")) + (external mm-enable-external)) (if (and (mm-inlinable-p handle) (mm-inlined-p handle)) (progn @@ -630,8 +666,27 @@ external if displayed external." (forward-line 1) (mm-insert-inline handle (mm-get-part handle)) 'inline) - (mm-display-external - handle (or method 'mailcap-save-binary-file))))))))) + (if (and method ;; If nil, we always use "save". + (stringp method) ;; 'mailcap-save-binary-file + (or (eq mm-enable-external t) + (and (eq mm-enable-external 'ask) + (y-or-n-p + (concat + "Display part (" type + ") using external program" + ;; Can non-string method ever happen? + (if (stringp method) + (concat + " \"" (format method filename) "\"") + "") + "? "))))) + (setq external t) + (setq external nil)) + (if external + (mm-display-external + handle (or method 'mailcap-save-binary-file)) + (mm-display-external + handle 'mailcap-save-binary-file))))))))) (defun mm-display-external (handle method) "Display HANDLE using METHOD." @@ -652,7 +707,8 @@ external if displayed external." (mm-set-buffer-file-coding-system mm-binary-coding-system) (insert-buffer-substring cur) (goto-char (point-min)) - (message "Viewing with %s" method) + (when method + (message "Viewing with %s" method)) (let ((mm (current-buffer)) (non-viewer (assq 'non-viewer (mailcap-mime-info @@ -840,9 +896,18 @@ external if displayed external." (funcall object)) ;; Externally displayed part. ((consp object) + (condition-case () + (while (get-buffer-process (cdr object)) + (interrupt-process (get-buffer-process (cdr object))) + (message "Waiting for external displayer to die...") + (sit-for 1)) + (quit) + (error)) + (ignore-errors (and (cdr object) (kill-buffer (cdr object)))) + (message "Waiting for external displayer to die...done") (ignore-errors (delete-file (car object))) - (ignore-errors (delete-directory (file-name-directory (car object)))) - (ignore-errors (and (cdr object) (kill-buffer (cdr object))))) + (ignore-errors (delete-directory (file-name-directory + (car object))))) ((bufferp object) (when (buffer-live-p object) (kill-buffer object))))) @@ -999,13 +1064,22 @@ external if displayed external." (defun mm-file-name-replace-whitespace (file-name) "Replace whitespace characters in FILE-NAME with underscores. -Set `mm-file-name-replace-whitespace' to any other string if you do not -like underscores." +Set the option `mm-file-name-replace-whitespace' to any other +string if you do not like underscores." (let ((s (or mm-file-name-replace-whitespace "_"))) (while (string-match "\\s-" file-name) (setq file-name (replace-match s t t file-name)))) file-name) +(defun mm-file-name-delete-control (filename) + "Delete control characters from FILENAME." + (gnus-replace-in-string filename "[\x00-\x1f\x7f]" "")) + +(defun mm-file-name-delete-gotchas (filename) + "Delete shell gotchas from FILENAME." + (setq filename (gnus-replace-in-string filename "[<>|]" "")) + (gnus-replace-in-string filename "^[.-]+" "")) + (defun mm-save-part (handle) "Write HANDLE to a file." (let* ((name (mail-content-type-get (mm-handle-type handle) 'name)) @@ -1031,13 +1105,17 @@ like underscores." (mm-with-unibyte-buffer (mm-insert-part handle) (let ((coding-system-for-write 'binary) + (current-file-modes (default-file-modes)) ;; Don't re-compress .gz & al. Arguably we should make ;; `file-name-handler-alist' nil, but that would chop ;; ange-ftp, which is reasonable to use here. (inhibit-file-name-operation 'write-region) (inhibit-file-name-handlers (cons 'jka-compr-handler inhibit-file-name-handlers))) - (write-region (point-min) (point-max) file)))) + (set-default-file-modes mm-attachment-file-modes) + (unwind-protect + (write-region (point-min) (point-max) file) + (set-default-file-modes current-file-modes))))) (defun mm-pipe-part (handle) "Pipe HANDLE to a process." @@ -1262,7 +1340,7 @@ If RECURSIVE, search recursively." (if notp (not (equal (car ctl) type)) (equal (car ctl) type))) - (setq result (buffer-substring (point-min) (point-max))))))) + (setq result (buffer-string)))))) (forward-line 1) (setq start (point))) (when (and (not result) start) @@ -1275,7 +1353,7 @@ If RECURSIVE, search recursively." (if notp (not (equal (car ctl) type)) (equal (car ctl) type))) - (setq result (buffer-substring (point-min) (point-max))))))) + (setq result (buffer-string)))))) result)) (defvar mm-security-handle nil)