X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmm-decode.el;h=3cf9a0bd93b2d02947afb0e22cc2e9faa1bf664d;hb=eb0329fa73e586f00e881f7481e69dedfb972e1d;hp=4be1050822d1b5df2fbc6ec1f77889317b2c5408;hpb=e525f614f6566faec7dbe2f3fab6c0ba8062c503;p=gnus diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index 4be105082..3cf9a0bd9 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -1,5 +1,6 @@ ;;; mm-decode.el --- Functions for decoding MIME things -;; Copyright (C) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc. +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, +;; 2003 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko @@ -100,29 +101,23 @@ (cond ((locate-library "w3") 'w3) ((locate-library "w3m") 'w3m) ((executable-find "links") 'links) - ((executable-find "lynx") 'lynx)) + ((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." - :type '(choice (symbol w3) - (symbol w3m) - (symbol links) - (symbol lynx) - (function)) - :version "21.3" - :group 'mime-display) - -(defcustom mm-application-msword-renderer - (cond ((executable-find "catdoc") 'catdoc)) - "Render of application/msword contents. -It is one of defined renderer types, or a rendering function. -The defined renderer types are: -`catdoc' : using catdoc." - :type '(choice (symbol catdoc) +`lynx' : using lynx; +`html2text' : using html2text; +nil : using external viewer." + :type '(choice (const w3) + (const w3m) + (const links) + (const lynx) + (const html2text) + (const nil) (function)) :version "21.3" :group 'mime-display) @@ -133,14 +128,23 @@ 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. For emacs-w3m, the -value of the option `w3m-display-inline-images' will be bound with -this value. In addition, the variable `w3m-safe-url-regexp' will be -bound with the value nil if it is non-nil to make emacs-w3m show all -images, however this behavior may be changed in the future." +with tags. It has no effect on Emacs/w3. See also +the documentation for the option `mm-w3m-safe-url-regexp'." :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." + :type '(choice (regexp :tag "Regexp") + (const :tag "All URLs are safe" nil)) + :group 'mime-display) + (defcustom mm-inline-text-html-with-w3m-keymap t "If non-nil, use emacs-w3m command keys in the article buffer." :type 'boolean @@ -175,7 +179,7 @@ images, however this behavior may be changed in the future." mm-inline-image (lambda (handle) (mm-valid-and-fit-image-p 'xpm handle))) - ("image/x-pixmap" + ("image/x-xpixmap" mm-inline-image (lambda (handle) (mm-valid-and-fit-image-p 'xpm handle))) @@ -205,10 +209,6 @@ images, however this behavior may be changed in the future." (lambda (handle) (or (featurep 'vcard) (locate-library "vcard")))) - ("application/msword" - mm-inline-application-msword - (lambda (handle) - mm-application-msword-renderer)) ("message/delivery-status" mm-inline-text identity) ("message/rfc822" mm-inline-message identity) ("message/partial" mm-inline-partial identity) @@ -245,9 +245,10 @@ images, however this behavior may be changed in the future." (defcustom mm-inlined-types '("image/.*" "text/.*" "message/delivery-status" "message/rfc822" "message/partial" "message/external-body" "application/emacs-lisp" + "application/x-emacs-lisp" "application/pgp-signature" "application/x-pkcs7-signature" "application/pkcs7-signature" "application/x-pkcs7-mime" - "application/pkcs7-mime" "application/msword") + "application/pkcs7-mime") "List of media types that are to be displayed inline. See also `mm-inline-media-tests', which says how to display a media type inline." @@ -266,7 +267,8 @@ when selecting a different article." '("text/plain" "text/enriched" "text/richtext" "text/html" "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*" "message/rfc822" "text/x-patch" "application/pgp-signature" - "application/emacs-lisp" "application/x-pkcs7-signature" + "application/emacs-lisp" "application/x-emacs-lisp" + "application/x-pkcs7-signature" "application/pkcs7-signature" "application/x-pkcs7-mime" "application/pkcs7-mime") "A list of MIME types to be displayed automatically." @@ -306,9 +308,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) @@ -331,10 +335,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.") @@ -354,7 +358,6 @@ If not set, `default-directory' will be used." ;;; Internal variables. -(defvar mm-dissection-list nil) (defvar mm-last-shell-command "") (defvar mm-content-id-alist nil) (defvar mm-postponed-undisplay-list nil) @@ -551,16 +554,8 @@ for types in mm-keep-viewer-alive-types." (if (equal "text/plain" (car ctl)) (assoc 'format ctl) t)) - (let ((res (mm-make-handle - (mm-copy-to-buffer) ctl cte nil cdl description nil id))) - (push (car res) mm-dissection-list) - res))) - -(defun mm-remove-all-parts () - "Remove all MIME handles." - (interactive) - (mapcar 'mm-remove-part mm-dissection-list) - (setq mm-dissection-list nil)) + (mm-make-handle + (mm-copy-to-buffer) ctl cte nil cdl description nil id))) (defun mm-dissect-multipart (ctl) (goto-char (point-min)) @@ -580,7 +575,9 @@ for types in mm-keep-viewer-alive-types." (save-restriction (narrow-to-region start (point)) (setq parts (nconc (list (mm-dissect-buffer t)) parts))))) - (forward-line 2) + (end-of-line 2) + (or (looking-at boundary) + (forward-line 1)) (setq start (point))) (when (and start (< start end)) (save-excursion @@ -671,13 +668,13 @@ external if displayed external." (mm-handle-set-undisplayer handle mm))))) ;; The function is a string to be executed. (mm-insert-part handle) - (let* ((dir (make-temp-name - (expand-file-name "emm." mm-tmp-directory))) - (filename (or + (let* ((dir (mm-make-temp-file + (expand-file-name "emm." mm-tmp-directory) 'dir)) + (filename (or (mail-content-type-get (mm-handle-disposition handle) 'filename) - (mail-content-type-get - (mm-handle-type handle) 'name))) + (mail-content-type-get + (mm-handle-type handle) 'name))) (mime-info (mailcap-mime-info (mm-handle-media-type handle) t)) (needsterm (or (assoc "needsterm" mime-info) @@ -685,47 +682,45 @@ external if displayed external." (copiousoutput (assoc "copiousoutput" mime-info)) file buffer) ;; We create a private sub-directory where we store our files. - (make-directory dir) (set-file-modes dir 448) (if filename - (setq file (expand-file-name (file-name-nondirectory filename) - dir)) - (setq file (make-temp-name (expand-file-name "mm." dir)))) + (setq file (expand-file-name + (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 ((coding-system-for-write mm-binary-coding-system)) (write-region (point-min) (point-max) file nil 'nomesg)) (message "Viewing with %s" method) (cond (needsterm - (unwind-protect - (if window-system - (start-process "*display*" nil - mm-external-terminal-program - "-e" shell-file-name - shell-command-switch - (mm-mailcap-command - method file (mm-handle-type handle))) - (require 'term) - (require 'gnus-win) - (set-buffer - (setq buffer - (make-term "display" - shell-file-name - nil - shell-command-switch - (mm-mailcap-command - method file - (mm-handle-type handle))))) - (term-mode) - (term-char-mode) - (set-process-sentinel - (get-buffer-process buffer) - `(lambda (process state) - (if (eq 'exit (process-status process)) - (gnus-configure-windows - ',gnus-current-window-configuration)))) - (gnus-configure-windows 'display-term)) - (mm-handle-set-external-undisplayer handle (cons file buffer))) - (message "Displaying %s..." (format method file)) + (let ((command (mm-mailcap-command + method file (mm-handle-type handle)))) + (unwind-protect + (if window-system + (start-process "*display*" nil + mm-external-terminal-program + "-e" shell-file-name + shell-command-switch command) + (require 'term) + (require 'gnus-win) + (set-buffer + (setq buffer + (make-term "display" + shell-file-name + nil + shell-command-switch command))) + (term-mode) + (term-char-mode) + (set-process-sentinel + (get-buffer-process buffer) + `(lambda (process state) + (if (eq 'exit (process-status process)) + (gnus-configure-windows + ',gnus-current-window-configuration)))) + (gnus-configure-windows 'display-term)) + (mm-handle-set-external-undisplayer handle (cons file buffer))) + (message "Displaying %s..." command)) 'external) (copiousoutput (with-current-buffer outbuf @@ -752,17 +747,17 @@ external if displayed external." (ignore-errors (kill-buffer buffer)))))) 'inline) (t - (unwind-protect - (start-process "*display*" - (setq buffer - (generate-new-buffer " *mm*")) - shell-file-name - shell-command-switch - (mm-mailcap-command - method file (mm-handle-type handle))) - (mm-handle-set-external-undisplayer - handle (cons file buffer))) - (message "Displaying %s..." (format method file)) + (let ((command (mm-mailcap-command + method file (mm-handle-type handle)))) + (unwind-protect + (start-process "*display*" + (setq buffer + (generate-new-buffer " *mm*")) + shell-file-name + shell-command-switch command) + (mm-handle-set-external-undisplayer + handle (cons file buffer))) + (message "Displaying %s..." command)) 'external))))))) (defun mm-mailcap-command (method file type-list) @@ -770,7 +765,8 @@ external if displayed external." (beg 0) (uses-stdin t) out sub total) - (while (string-match "%{\\([^}]+\\)}\\|%s\\|%t\\|%%" method beg) + (while (string-match "%{\\([^}]+\\)}\\|'%s'\\|\"%s\"\\|%s\\|%t\\|%%" + method beg) (push (substring method beg (match-beginning 0)) out) (setq beg (match-end 0) total (match-string 0 method) @@ -778,7 +774,10 @@ external if displayed external." (cond ((string= total "%%") (push "%" out)) - ((string= total "%s") + ((or (string= total "%s") + ;; We do our own quoting. + (string= total "'%s'") + (string= total "\"%s\"")) (setq uses-stdin nil) (push (mm-quote-arg (gnus-map-function mm-path-name-rewrite-functions file)) out)) @@ -949,7 +948,7 @@ external if displayed external." "Return the contents of HANDLE as a string." (mm-with-unibyte-buffer (insert (with-current-buffer (mm-handle-buffer handle) - (mm-with-unibyte-current-buffer-mule4 + (mm-with-unibyte-current-buffer (buffer-string)))) (mm-decode-content-transfer-encoding (mm-handle-encoding handle) @@ -1020,9 +1019,8 @@ like underscores." (file-name-nondirectory filename)))) (setq file (read-file-name "Save MIME part to: " - (expand-file-name - (or filename name "") - (or mm-default-directory default-directory)))) + (or mm-default-directory default-directory) + nil nil (or filename name ""))) (setq mm-default-directory (file-name-directory file)) (and (or (not (file-exists-p file)) (yes-or-no-p (format "File %s already exists; overwrite? " @@ -1156,7 +1154,7 @@ be determined." ;; Avoid testing `make-glyph' since W3 may define ;; a bogus version of it. (if (fboundp 'create-image) - (create-image (buffer-string) + (create-image (buffer-string) (or (mm-image-type-from-buffer) (intern type)) 'data-p) @@ -1171,7 +1169,7 @@ be determined." ;; (without a ton of work) is to write them ;; out to a file, and then create a file ;; specifier. - (let ((file (make-temp-name + (let ((file (mm-make-temp-file (expand-file-name "emm.xbm" mm-tmp-directory)))) (unwind-protect @@ -1182,11 +1180,11 @@ be determined." (delete-file file))))) (t (make-glyph - (vector + (vector (or (mm-image-type-from-buffer) (intern type)) :data (buffer-string)))))) - + (defun mm-image-fit-p (handle) "Say whether the image in HANDLE will fit the current window." (let ((image (mm-get-image handle))) @@ -1266,7 +1264,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) @@ -1279,16 +1277,16 @@ 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) (defsubst mm-set-handle-multipart-parameter (handle parameter value) ;; HANDLE could be a CTL. - (if handle - (put-text-property 0 (length (car handle)) parameter value - (car handle)))) + (when handle + (put-text-property 0 (length (car handle)) parameter value + (car handle)))) (defun mm-possibly-verify-or-decrypt (parts ctl) (let ((type (car ctl)) @@ -1321,25 +1319,26 @@ If RECURSIVE, search recursively." protocols nil) (setq protocols (cdr protocols)))))) (setq func (nth 1 (assoc protocol mm-verify-function-alist))) - (if (cond - ((eq mm-verify-option 'never) nil) - ((eq mm-verify-option 'always) t) - ((eq mm-verify-option 'known) - (and func - (or (not (setq functest - (nth 3 (assoc protocol - mm-verify-function-alist)))) - (funcall functest parts ctl)))) - (t (y-or-n-p + (when (cond + ((eq mm-verify-option 'never) nil) + ((eq mm-verify-option 'always) t) + ((eq mm-verify-option 'known) + (and func + (or (not (setq functest + (nth 3 (assoc protocol + mm-verify-function-alist)))) + (funcall functest parts ctl)))) + (t + (y-or-n-p (format "Verify signed (%s) part? " (or (nth 2 (assoc protocol mm-verify-function-alist)) (format "protocol=%s" protocol)))))) - (save-excursion - (if func - (funcall func parts ctl) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details - (format "Unknown sign protocol (%s)" protocol)))))) + (save-excursion + (if func + (funcall func parts ctl) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (format "Unknown sign protocol (%s)" protocol)))))) ((equal subtype "encrypted") (unless (setq protocol (mm-handle-multipart-ctl-parameter ctl 'protocol)) @@ -1352,25 +1351,26 @@ If RECURSIVE, search recursively." parts nil) (setq parts (cdr parts)))))) (setq func (nth 1 (assoc protocol mm-decrypt-function-alist))) - (if (cond - ((eq mm-decrypt-option 'never) nil) - ((eq mm-decrypt-option 'always) t) - ((eq mm-decrypt-option 'known) - (and func - (or (not (setq functest - (nth 3 (assoc protocol - mm-decrypt-function-alist)))) - (funcall functest parts ctl)))) - (t (y-or-n-p + (when (cond + ((eq mm-decrypt-option 'never) nil) + ((eq mm-decrypt-option 'always) t) + ((eq mm-decrypt-option 'known) + (and func + (or (not (setq functest + (nth 3 (assoc protocol + mm-decrypt-function-alist)))) + (funcall functest parts ctl)))) + (t + (y-or-n-p (format "Decrypt (%s) part? " (or (nth 2 (assoc protocol mm-decrypt-function-alist)) (format "protocol=%s" protocol)))))) - (save-excursion - (if func - (setq parts (funcall func parts ctl)) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details - (format "Unknown encrypt protocol (%s)" protocol)))))) + (save-excursion + (if func + (setq parts (funcall func parts ctl)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (format "Unknown encrypt protocol (%s)" protocol)))))) (t nil)) parts))