/[emacs]/emacs/lisp/gnus/mm-decode.el
ViewVC logotype

Diff of /emacs/lisp/gnus/mm-decode.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.13.6.1 by handa, Fri Mar 12 00:02:59 2004 UTC revision 1.13.6.2 by miles, Thu Sep 9 09:36:26 2004 UTC
# Line 1  Line 1 
1  ;;; mm-decode.el --- functions for decoding MIME things  ;;; mm-decode.el --- Functions for decoding MIME things
2  ;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.  ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004
3    ;;        Free Software Foundation, Inc.
4    
5  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6  ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>  ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
# Line 27  Line 28 
28  (require 'mail-parse)  (require 'mail-parse)
29  (require 'mailcap)  (require 'mailcap)
30  (require 'mm-bodies)  (require 'mm-bodies)
31  (eval-when-compile (require 'cl))  (eval-when-compile (require 'cl)
32                       (require 'term))
33    
34  (eval-and-compile  (eval-and-compile
35      (autoload 'executable-find "executable")
36    (autoload 'mm-inline-partial "mm-partial")    (autoload 'mm-inline-partial "mm-partial")
37      (autoload 'mm-inline-external-body "mm-extern")
38    (autoload 'mm-insert-inline "mm-view"))    (autoload 'mm-insert-inline "mm-view"))
39    
40    (add-hook 'gnus-exit-gnus-hook 'mm-destroy-postponed-undisplay-list)
41    
42  (defgroup mime-display ()  (defgroup mime-display ()
43    "Display of MIME in mail and news articles."    "Display of MIME in mail and news articles."
44    :link '(custom-manual "(emacs-mime)Customization")    :link '(custom-manual "(emacs-mime)Display Customization")
45    :version "21.1"    :version "21.1"
46    :group 'mail    :group 'mail
47    :group 'news    :group 'news
48    :group 'multimedia)    :group 'multimedia)
49    
50    (defgroup mime-security ()
51      "MIME security in mail and news articles."
52      :link '(custom-manual "(emacs-mime)Display Customization")
53      :group 'mail
54      :group 'news
55      :group 'multimedia)
56    
57  ;;; Convenience macros.  ;;; Convenience macros.
58    
59  (defmacro mm-handle-buffer (handle)  (defmacro mm-handle-buffer (handle)
# Line 71  Line 84 
84    `(setcar (nthcdr 6 ,handle) ,contents))    `(setcar (nthcdr 6 ,handle) ,contents))
85  (defmacro mm-handle-id (handle)  (defmacro mm-handle-id (handle)
86    `(nth 7 ,handle))    `(nth 7 ,handle))
87    (defmacro mm-handle-multipart-original-buffer (handle)
88      `(get-text-property 0 'buffer (car ,handle)))
89    (defmacro mm-handle-multipart-from (handle)
90      `(get-text-property 0 'from (car ,handle)))
91    (defmacro mm-handle-multipart-ctl-parameter (handle parameter)
92      `(get-text-property 0 ,parameter (car ,handle)))
93    
94  (defmacro mm-make-handle (&optional buffer type encoding undisplayer  (defmacro mm-make-handle (&optional buffer type encoding undisplayer
95                                      disposition description cache                                      disposition description cache
96                                      id)                                      id)
97    `(list ,buffer ,type ,encoding ,undisplayer    `(list ,buffer ,type ,encoding ,undisplayer
98           ,disposition ,description ,cache ,id))           ,disposition ,description ,cache ,id))
99    
100    (defcustom mm-text-html-renderer
101      (cond ((locate-library "w3") 'w3)
102            ((executable-find "w3m") (if (locate-library "w3m")
103                                         'w3m
104                                       'w3m-standalone))
105            ((executable-find "links") 'links)
106            ((executable-find "lynx") 'lynx)
107            (t 'html2text))
108      "Render of HTML contents.
109    It is one of defined renderer types, or a rendering function.
110    The defined renderer types are:
111    `w3'   : use Emacs/W3;
112    `w3m'  : use emacs-w3m;
113    `w3m-standalone': use w3m;
114    `links': use links;
115    `lynx' : use lynx;
116    `html2text' : use html2text;
117    nil    : use external viewer."
118      :type '(choice (const w3)
119                     (const w3m)
120                     (const w3m-standalone)
121                     (const links)
122                     (const lynx)
123                     (const html2text)
124                     (const nil)
125                     (function))
126      :version "21.3"
127      :group 'mime-display)
128    
129    (defvar mm-inline-text-html-renderer nil
130      "Function used for rendering inline HTML contents.
131    It is suggested to customize `mm-text-html-renderer' instead.")
132    
133    (defcustom mm-inline-text-html-with-images nil
134      "If non-nil, Gnus will allow retrieving images in HTML contents with
135    the <img> tags.  It has no effect on Emacs/w3.  See also the
136    documentation for the `mm-w3m-safe-url-regexp' variable."
137      :type 'boolean
138      :group 'mime-display)
139    
140    (defcustom mm-w3m-safe-url-regexp "\\`cid:"
141      "Regexp matching URLs which are considered to be safe.
142    Some HTML mails might contain a nasty trick used by spammers, using
143    the <img> tag which is far more evil than the [Click Here!] button.
144    It is most likely intended to check whether the ominous spam mail has
145    reached your eyes or not, in which case the spammer knows for sure
146    that your email address is valid.  It is done by embedding an
147    identifier string into a URL that you might automatically retrieve
148    when displaying the image.  The default value is \"\\\\`cid:\" which only
149    matches parts embedded to the Multipart/Related type MIME contents and
150    Gnus will never connect to the spammer's site arbitrarily.  You may
151    set this variable to nil if you consider all urls to be safe."
152      :type '(choice (regexp :tag "Regexp")
153                     (const :tag "All URLs are safe" nil))
154      :group 'mime-display)
155    
156    (defcustom mm-inline-text-html-with-w3m-keymap t
157      "If non-nil, use emacs-w3m command keys in the article buffer."
158      :type 'boolean
159      :group 'mime-display)
160    
161    (defcustom mm-enable-external t
162      "Indicate whether external MIME handlers should be used.
163    
164    If t, all defined external MIME handlers are used.  If nil, files are saved by
165    `mailcap-save-binary-file'.  If it is the symbol `ask', you are prompted
166    before the external MIME handler is invoked."
167      :version "21.4"
168      :type '(choice (const :tag "Always" t)
169                     (const :tag "Never" nil)
170                     (const :tag "Ask" ask))
171      :group 'mime-display)
172    
173  (defcustom mm-inline-media-tests  (defcustom mm-inline-media-tests
174    '(("image/jpeg"    '(("image/p?jpeg"
175       mm-inline-image       mm-inline-image
176       (lambda (handle)       (lambda (handle)
177         (mm-valid-and-fit-image-p 'jpeg handle)))         (mm-valid-and-fit-image-p 'jpeg handle)))
# Line 106  Line 199 
199       mm-inline-image       mm-inline-image
200       (lambda (handle)       (lambda (handle)
201         (mm-valid-and-fit-image-p 'xpm handle)))         (mm-valid-and-fit-image-p 'xpm handle)))
202      ("image/x-pixmap"      ("image/x-xpixmap"
203       mm-inline-image       mm-inline-image
204       (lambda (handle)       (lambda (handle)
205         (mm-valid-and-fit-image-p 'xpm handle)))         (mm-valid-and-fit-image-p 'xpm handle)))
# Line 125  Line 218 
218       (lambda (handle)       (lambda (handle)
219         (locate-library "diff-mode")))         (locate-library "diff-mode")))
220      ("application/emacs-lisp" mm-display-elisp-inline identity)      ("application/emacs-lisp" mm-display-elisp-inline identity)
221        ("application/x-emacs-lisp" mm-display-elisp-inline identity)
222      ("text/html"      ("text/html"
223       mm-inline-text       mm-inline-text-html
224       (lambda (handle)       (lambda (handle)
225         (locate-library "w3")))         (or mm-inline-text-html-renderer
226               mm-text-html-renderer)))
227      ("text/x-vcard"      ("text/x-vcard"
228       mm-inline-text       mm-inline-text-vcard
229       (lambda (handle)       (lambda (handle)
230         (or (featurep 'vcard)         (or (featurep 'vcard)
231             (locate-library "vcard"))))             (locate-library "vcard"))))
232      ("message/delivery-status" mm-inline-text identity)      ("message/delivery-status" mm-inline-text identity)
233      ("message/rfc822" mm-inline-message identity)      ("message/rfc822" mm-inline-message identity)
234      ("message/partial" mm-inline-partial identity)      ("message/partial" mm-inline-partial identity)
235        ("message/external-body" mm-inline-external-body identity)
236      ("text/.*" mm-inline-text identity)      ("text/.*" mm-inline-text identity)
237      ("audio/wav" mm-inline-audio      ("audio/wav" mm-inline-audio
238       (lambda (handle)       (lambda (handle)
# Line 148  Line 244 
244         (and (or (featurep 'nas-sound) (featurep 'native-sound))         (and (or (featurep 'nas-sound) (featurep 'native-sound))
245              (device-sound-enabled-p))))              (device-sound-enabled-p))))
246      ("application/pgp-signature" ignore identity)      ("application/pgp-signature" ignore identity)
247        ("application/x-pkcs7-signature" ignore identity)
248        ("application/pkcs7-signature" ignore identity)
249        ("application/x-pkcs7-mime" ignore identity)
250        ("application/pkcs7-mime" ignore identity)
251      ("multipart/alternative" ignore identity)      ("multipart/alternative" ignore identity)
252      ("multipart/mixed" ignore identity)      ("multipart/mixed" ignore identity)
253      ("multipart/related" ignore identity))      ("multipart/related" ignore identity)
254        ;; Disable audio and image
255        ("audio/.*" ignore ignore)
256        ("image/.*" ignore ignore)
257        ;; Default to displaying as text
258        (".*" mm-inline-text mm-readable-p))
259    "Alist of media types/tests saying whether types can be displayed inline."    "Alist of media types/tests saying whether types can be displayed inline."
260    :type '(repeat (list (string :tag "MIME type")    :type '(repeat (list (regexp :tag "MIME type")
261                         (function :tag "Display function")                         (function :tag "Display function")
262                         (function :tag "Display test")))                         (function :tag "Display test")))
263    :group 'mime-display)    :group 'mime-display)
264    
265  (defcustom mm-inlined-types  (defcustom mm-inlined-types
266    '("image/.*" "text/.*" "message/delivery-status" "message/rfc822"    '("image/.*" "text/.*" "message/delivery-status" "message/rfc822"
267      "message/partial" "application/emacs-lisp"      "message/partial" "message/external-body" "application/emacs-lisp"
268      "application/pgp-signature")      "application/x-emacs-lisp"
269    "List of media types that are to be displayed inline."      "application/pgp-signature" "application/x-pkcs7-signature"
270        "application/pkcs7-signature" "application/x-pkcs7-mime"
271        "application/pkcs7-mime")
272      "List of media types that are to be displayed inline.
273    See also `mm-inline-media-tests', which says how to display a media
274    type inline."
275      :type '(repeat string)
276      :group 'mime-display)
277    
278    (defcustom mm-keep-viewer-alive-types
279      '("application/postscript" "application/msword" "application/vnd.ms-excel"
280        "application/pdf" "application/x-dvi")
281      "List of media types for which the external viewer will not be killed
282    when selecting a different article."
283    :type '(repeat string)    :type '(repeat string)
284    :group 'mime-display)    :group 'mime-display)
285    
# Line 169  Line 287 
287    '("text/plain" "text/enriched" "text/richtext" "text/html"    '("text/plain" "text/enriched" "text/richtext" "text/html"
288      "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*"      "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*"
289      "message/rfc822" "text/x-patch" "application/pgp-signature"      "message/rfc822" "text/x-patch" "application/pgp-signature"
290      "application/emacs-lisp")      "application/emacs-lisp" "application/x-emacs-lisp"
291        "application/x-pkcs7-signature"
292        "application/pkcs7-signature" "application/x-pkcs7-mime"
293        "application/pkcs7-mime")
294    "A list of MIME types to be displayed automatically."    "A list of MIME types to be displayed automatically."
295    :type '(repeat string)    :type '(repeat string)
296    :group 'mime-display)    :group 'mime-display)
297    
298  (defcustom mm-attachment-override-types '("text/x-vcard")  (defcustom mm-attachment-override-types '("text/x-vcard"
299                                              "application/pkcs7-mime"
300                                              "application/x-pkcs7-mime"
301                                              "application/pkcs7-signature"
302                                              "application/x-pkcs7-signature")
303    "Types to have \"attachment\" ignored if they can be displayed inline."    "Types to have \"attachment\" ignored if they can be displayed inline."
304    :type '(repeat string)    :type '(repeat string)
305    :group 'mime-display)    :group 'mime-display)
# Line 202  to: Line 327  to:
327    :type '(repeat string)    :type '(repeat string)
328    :group 'mime-display)    :group 'mime-display)
329    
330  (defvar mm-tmp-directory  (defcustom mm-tmp-directory
331    (cond ((fboundp 'temp-directory) (temp-directory))    (if (fboundp 'temp-directory)
332          ((boundp 'temporary-file-directory) temporary-file-directory)        (temp-directory)
333          ("/tmp/"))      (if (boundp 'temporary-file-directory)
334    "Where mm will store its temporary files.")          temporary-file-directory
335          "/tmp/"))
336      "Where mm will store its temporary files."
337      :type 'directory
338      :group 'mime-display)
339    
340  (defcustom mm-inline-large-images nil  (defcustom mm-inline-large-images nil
341    "If non-nil, then all images fit in the buffer."    "If non-nil, then all images fit in the buffer."
342    :type 'boolean    :type 'boolean
343    :group 'mime-display)    :group 'mime-display)
344    
345    (defvar mm-file-name-rewrite-functions
346      '(mm-file-name-delete-control mm-file-name-delete-gotchas)
347      "*List of functions used for rewriting file names of MIME parts.
348    Each function takes a file name as input and returns a file name.
349    
350    Ready-made functions include
351    `mm-file-name-delete-control'
352    `mm-file-name-delete-gotchas'
353    `mm-file-name-delete-whitespace',
354    `mm-file-name-trim-whitespace',
355    `mm-file-name-collapse-whitespace',
356    `mm-file-name-replace-whitespace',
357    `capitalize', `downcase', `upcase', and
358    `upcase-initials'.")
359    
360    (defvar mm-path-name-rewrite-functions nil
361      "*List of functions for rewriting the full file names of MIME parts.
362    This is used when viewing parts externally, and is meant for
363    transforming the absolute name so that non-compliant programs can find
364    the file where it's saved.
365    
366    Each function takes a file name as input and returns a file name.")
367    
368    (defvar mm-file-name-replace-whitespace nil
369      "String used for replacing whitespace characters; default is `\"_\"'.")
370    
371    (defcustom mm-default-directory nil
372      "The default directory where mm will save files.
373    If not set, `default-directory' will be used."
374      :type '(choice directory (const :tag "Default" nil))
375      :group 'mime-display)
376    
377    (defcustom mm-attachment-file-modes 384
378      "Set the mode bits of saved attachments to this integer."
379      :type 'integer
380      :group 'mime-display)
381    
382    (defcustom mm-external-terminal-program "xterm"
383      "The program to start an external terminal."
384      :type 'string
385      :group 'mime-display)
386    
387  ;;; Internal variables.  ;;; Internal variables.
388    
 (defvar mm-dissection-list nil)  
389  (defvar mm-last-shell-command "")  (defvar mm-last-shell-command "")
390  (defvar mm-content-id-alist nil)  (defvar mm-content-id-alist nil)
391    (defvar mm-postponed-undisplay-list nil)
392    
393  ;; According to RFC2046, in particular, in a digest, the default  ;; According to RFC2046, in particular, in a digest, the default
394  ;; Content-Type value for a body part is changed from "text/plain" to  ;; Content-Type value for a body part is changed from "text/plain" to
395  ;; "message/rfc822".  ;; "message/rfc822".
396  (defvar mm-dissect-default-type "text/plain")  (defvar mm-dissect-default-type "text/plain")
397    
398    (autoload 'mml2015-verify "mml2015")
399    (autoload 'mml2015-verify-test "mml2015")
400    (autoload 'mml-smime-verify "mml-smime")
401    (autoload 'mml-smime-verify-test "mml-smime")
402    
403    (defvar mm-verify-function-alist
404      '(("application/pgp-signature" mml2015-verify "PGP" mml2015-verify-test)
405        ("application/x-gnus-pgp-signature" mm-uu-pgp-signed-extract-1 "PGP"
406         mm-uu-pgp-signed-test)
407        ("application/pkcs7-signature" mml-smime-verify "S/MIME"
408         mml-smime-verify-test)
409        ("application/x-pkcs7-signature" mml-smime-verify "S/MIME"
410         mml-smime-verify-test)))
411    
412    (defcustom mm-verify-option 'never
413      "Option of verifying signed parts.
414    `never', not verify; `always', always verify;
415    `known', only verify known protocols.  Otherwise, ask user."
416      :type '(choice (item always)
417                     (item never)
418                     (item :tag "only known protocols" known)
419                     (item :tag "ask" nil))
420      :group 'mime-security)
421    
422    (autoload 'mml2015-decrypt "mml2015")
423    (autoload 'mml2015-decrypt-test "mml2015")
424    
425    (defvar mm-decrypt-function-alist
426      '(("application/pgp-encrypted" mml2015-decrypt "PGP" mml2015-decrypt-test)
427        ("application/x-gnus-pgp-encrypted" mm-uu-pgp-encrypted-extract-1 "PGP"
428         mm-uu-pgp-encrypted-test)))
429    
430    (defcustom mm-decrypt-option nil
431      "Option of decrypting encrypted parts.
432    `never', not decrypt; `always', always decrypt;
433    `known', only decrypt known protocols.  Otherwise, ask user."
434      :type '(choice (item always)
435                     (item never)
436                     (item :tag "only known protocols" known)
437                     (item :tag "ask" nil))
438      :group 'mime-security)
439    
440    (defvar mm-viewer-completion-map
441      (let ((map (make-sparse-keymap 'mm-viewer-completion-map)))
442        (set-keymap-parent map minibuffer-local-completion-map)
443        map)
444      "Keymap for input viewer with completion.")
445    
446    ;; Should we bind other key to minibuffer-complete-word?
447    (define-key mm-viewer-completion-map " " 'self-insert-command)
448    
449  (defvar mm-viewer-completion-map  (defvar mm-viewer-completion-map
450    (let ((map (make-sparse-keymap 'mm-viewer-completion-map)))    (let ((map (make-sparse-keymap 'mm-viewer-completion-map)))
451      (set-keymap-parent map minibuffer-local-completion-map)      (set-keymap-parent map minibuffer-local-completion-map)
# Line 235  to: Line 457  to:
457    
458  ;;; The functions.  ;;; The functions.
459    
460  (defun mm-dissect-buffer (&optional no-strict-mime)  (defun mm-alist-to-plist (alist)
461      "Convert association list ALIST into the equivalent property-list form.
462    The plist is returned.  This converts from
463    
464    \((a . 1) (b . 2) (c . 3))
465    
466    into
467    
468    \(a 1 b 2 c 3)
469    
470    The original alist is not modified.  See also `destructive-alist-to-plist'."
471      (let (plist)
472        (while alist
473          (let ((el (car alist)))
474            (setq plist (cons (cdr el) (cons (car el) plist))))
475          (setq alist (cdr alist)))
476        (nreverse plist)))
477    
478    (defun mm-keep-viewer-alive-p (handle)
479      "Say whether external viewer for HANDLE should stay alive."
480      (let ((types mm-keep-viewer-alive-types)
481            (type (mm-handle-media-type handle))
482            ty)
483        (catch 'found
484          (while (setq ty (pop types))
485            (when (string-match ty type)
486              (throw 'found t))))))
487    
488    (defun mm-handle-set-external-undisplayer (handle function)
489      "Set the undisplayer for HANDLE to FUNCTION.
490    Postpone undisplaying of viewers for types in
491    `mm-keep-viewer-alive-types'."
492      (if (mm-keep-viewer-alive-p handle)
493          (let ((new-handle (copy-sequence handle)))
494            (mm-handle-set-undisplayer new-handle function)
495            (mm-handle-set-undisplayer handle nil)
496            (push new-handle mm-postponed-undisplay-list))
497        (mm-handle-set-undisplayer handle function)))
498    
499    (defun mm-destroy-postponed-undisplay-list ()
500      (when mm-postponed-undisplay-list
501        (message "Destroying external MIME viewers")
502        (mm-destroy-parts mm-postponed-undisplay-list)))
503    
504    (defun mm-dissect-buffer (&optional no-strict-mime loose-mime)
505    "Dissect the current buffer and return a list of MIME handles."    "Dissect the current buffer and return a list of MIME handles."
506    (save-excursion    (save-excursion
507      (let (ct ctl type subtype cte cd description id result)      (let (ct ctl type subtype cte cd description id result from)
508        (save-restriction        (save-restriction
509          (mail-narrow-to-head)          (mail-narrow-to-head)
510          (when (or no-strict-mime          (when (or no-strict-mime
511                      loose-mime
512                    (mail-fetch-field "mime-version"))                    (mail-fetch-field "mime-version"))
513            (setq ct (mail-fetch-field "content-type")            (setq ct (mail-fetch-field "content-type")
514                  ctl (ignore-errors (mail-header-parse-content-type ct))                  ctl (ignore-errors (mail-header-parse-content-type ct))
515                  cte (mail-fetch-field "content-transfer-encoding")                  cte (mail-fetch-field "content-transfer-encoding")
516                  cd (mail-fetch-field "content-disposition")                  cd (mail-fetch-field "content-disposition")
517                  description (mail-fetch-field "content-description")                  description (mail-fetch-field "content-description")
518                  id (mail-fetch-field "content-id"))))                  from (mail-fetch-field "from")
519                    id (mail-fetch-field "content-id"))
520              ;; FIXME: In some circumstances, this code is running within
521              ;; an unibyte macro.  mail-extract-address-components
522              ;; creates unibyte buffers. This `if', though not a perfect
523              ;; solution, avoids most of them.
524              (if from
525                  (setq from (cadr (mail-extract-address-components from))))))
526        (when cte        (when cte
527          (setq cte (mail-header-strip cte)))          (setq cte (mail-header-strip cte)))
528        (if (or (not ctl)        (if (or (not ctl)
# Line 270  to: Line 544  to:
544            ((equal type "multipart")            ((equal type "multipart")
545             (let ((mm-dissect-default-type (if (equal subtype "digest")             (let ((mm-dissect-default-type (if (equal subtype "digest")
546                                                "message/rfc822"                                                "message/rfc822"
547                                              "text/plain")))                                              "text/plain"))
548                     (start (cdr (assq 'start (cdr ctl)))))
549                 (add-text-properties 0 (length (car ctl))
550                                      (mm-alist-to-plist (cdr ctl)) (car ctl))
551    
552                 ;; what really needs to be done here is a way to link a
553                 ;; MIME handle back to it's parent MIME handle (in a multilevel
554                 ;; MIME article).  That would probably require changing
555                 ;; the mm-handle API so we simply store the multipart buffert
556                 ;; name as a text property of the "multipart/whatever" string.
557                 (add-text-properties 0 (length (car ctl))
558                                      (list 'buffer (mm-copy-to-buffer)
559                                            'from from
560                                            'start start)
561                                      (car ctl))
562               (cons (car ctl) (mm-dissect-multipart ctl))))               (cons (car ctl) (mm-dissect-multipart ctl))))
563            (t            (t
564             (mm-dissect-singlepart             (mm-possibly-verify-or-decrypt
565              ctl              (mm-dissect-singlepart
566              (and cte (intern (downcase (mail-header-remove-whitespace               ctl
567                                          (mail-header-remove-comments               (and cte (intern (downcase (mail-header-remove-whitespace
568                                           cte)))))                                           (mail-header-remove-comments
569              no-strict-mime                                            cte)))))
570              (and cd (ignore-errors (mail-header-parse-content-disposition cd)))               no-strict-mime
571              description id))))               (and cd (ignore-errors
572                           (mail-header-parse-content-disposition cd)))
573                 description id)
574                ctl))))
575          (when id          (when id
576            (when (string-match " *<\\(.*\\)> *" id)            (when (string-match " *<\\(.*\\)> *" id)
577              (setq id (match-string 1 id)))              (setq id (match-string 1 id)))
# Line 292  to: Line 583  to:
583              (if (equal "text/plain" (car ctl))              (if (equal "text/plain" (car ctl))
584                  (assoc 'format ctl)                  (assoc 'format ctl)
585                t))                t))
586      (let ((res (mm-make-handle      (mm-make-handle
587                  (mm-copy-to-buffer) ctl cte nil cdl description nil id)))       (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))  
588    
589  (defun mm-dissect-multipart (ctl)  (defun mm-dissect-multipart (ctl)
590    (goto-char (point-min))    (goto-char (point-min))
# Line 321  to: Line 604  to:
604            (save-restriction            (save-restriction
605              (narrow-to-region start (point))              (narrow-to-region start (point))
606              (setq parts (nconc (list (mm-dissect-buffer t)) parts)))))              (setq parts (nconc (list (mm-dissect-buffer t)) parts)))))
607        (forward-line 2)        (end-of-line 2)
608          (or (looking-at boundary)
609              (forward-line 1))
610        (setq start (point)))        (setq start (point)))
611      (when (and start (< start end))      (when (and start (< start end))
612        (save-excursion        (save-excursion
613          (save-restriction          (save-restriction
614            (narrow-to-region start end)            (narrow-to-region start end)
615            (setq parts (nconc (list (mm-dissect-buffer t)) parts)))))            (setq parts (nconc (list (mm-dissect-buffer t)) parts)))))
616      (nreverse parts)))      (mm-possibly-verify-or-decrypt (nreverse parts) ctl)))
617    
618  (defun mm-copy-to-buffer ()  (defun mm-copy-to-buffer ()
619    "Copy the contents of the current buffer to a fresh buffer."    "Copy the contents of the current buffer to a fresh buffer."
# Line 342  to: Line 627  to:
627        (insert-buffer-substring obuf beg)        (insert-buffer-substring obuf beg)
628        (current-buffer))))        (current-buffer))))
629    
630    (defun mm-display-parts (handle &optional no-default)
631      (if (stringp (car handle))
632          (mapcar 'mm-display-parts (cdr handle))
633        (if (bufferp (car handle))
634            (save-restriction
635              (narrow-to-region (point) (point))
636              (mm-display-part handle)
637              (goto-char (point-max)))
638          (mapcar 'mm-display-parts handle))))
639    
640  (defun mm-display-part (handle &optional no-default)  (defun mm-display-part (handle &optional no-default)
641    "Display the MIME part represented by HANDLE.    "Display the MIME part represented by HANDLE.
642  Returns nil if the part is removed; inline if displayed inline;  Returns nil if the part is removed; inline if displayed inline;
# Line 351  external if displayed external." Line 646  external if displayed external."
646      (if (mm-handle-displayed-p handle)      (if (mm-handle-displayed-p handle)
647          (mm-remove-part handle)          (mm-remove-part handle)
648        (let* ((type (mm-handle-media-type handle))        (let* ((type (mm-handle-media-type handle))
649               (method (mailcap-mime-info type)))               (method (mailcap-mime-info type))
650          (if (mm-inlined-p handle)               (filename (or (mail-content-type-get
651                                (mm-handle-disposition handle) 'filename)
652                               (mail-content-type-get
653                                (mm-handle-type handle) 'name)
654                               "<file>"))
655                 (external mm-enable-external))
656            (if (and (mm-inlinable-p handle)
657                     (mm-inlined-p handle))
658              (progn              (progn
659                (forward-line 1)                (forward-line 1)
660                (mm-display-inline handle)                (mm-display-inline handle)
# Line 365  external if displayed external." Line 667  external if displayed external."
667                    (forward-line 1)                    (forward-line 1)
668                    (mm-insert-inline handle (mm-get-part handle))                    (mm-insert-inline handle (mm-get-part handle))
669                    'inline)                    'inline)
670                (mm-display-external                (if (and method ;; If nil, we always use "save".
671                 handle (or method 'mailcap-save-binary-file)))))))))                         (stringp method) ;; 'mailcap-save-binary-file
672                           (or (eq mm-enable-external t)
673                               (and (eq mm-enable-external 'ask)
674                                    (y-or-n-p
675                                     (concat
676                                      "Display part (" type
677                                      ") using external program"
678                                      ;; Can non-string method ever happen?
679                                      (if (stringp method)
680                                          (concat
681                                           " \"" (format method filename) "\"")
682                                        "")
683                                      "? ")))))
684                      (setq external t)
685                    (setq external nil))
686                  (if external
687                      (mm-display-external
688                       handle (or method 'mailcap-save-binary-file))
689                    (mm-display-external
690                     handle 'mailcap-save-binary-file)))))))))
691    
692  (defun mm-display-external (handle method)  (defun mm-display-external (handle method)
693    "Display HANDLE using METHOD."    "Display HANDLE using METHOD."
# Line 383  external if displayed external." Line 704  external if displayed external."
704                  (when win                  (when win
705                    (select-window win)))                    (select-window win)))
706                (switch-to-buffer (generate-new-buffer " *mm*")))                (switch-to-buffer (generate-new-buffer " *mm*")))
707                (buffer-disable-undo)
708              (mm-set-buffer-file-coding-system mm-binary-coding-system)              (mm-set-buffer-file-coding-system mm-binary-coding-system)
709              (insert-buffer-substring cur)              (insert-buffer-substring cur)
710              (goto-char (point-min))              (goto-char (point-min))
711              (message "Viewing with %s" method)              (when method
712                  (message "Viewing with %s" method))
713              (let ((mm (current-buffer))              (let ((mm (current-buffer))
714                    (non-viewer (assq 'non-viewer                    (non-viewer (assq 'non-viewer
715                                      (mailcap-mime-info                                      (mailcap-mime-info
# Line 400  external if displayed external." Line 723  external if displayed external."
723                    (mm-handle-set-undisplayer handle mm)))))                    (mm-handle-set-undisplayer handle mm)))))
724          ;; The function is a string to be executed.          ;; The function is a string to be executed.
725          (mm-insert-part handle)          (mm-insert-part handle)
726          (let* ((dir (mm-make-temp-file          (let* ((dir (mm-make-temp-file
727                       (expand-file-name "emm." mm-tmp-directory) 'dir))                       (expand-file-name "emm." mm-tmp-directory) 'dir))
728                 (filename (mail-content-type-get                 (filename (or
729                            (mm-handle-disposition handle) 'filename))                            (mail-content-type-get
730                               (mm-handle-disposition handle) 'filename)
731                              (mail-content-type-get
732                               (mm-handle-type handle) 'name)))
733                 (mime-info (mailcap-mime-info                 (mime-info (mailcap-mime-info
734                             (mm-handle-media-type handle) t))                             (mm-handle-media-type handle) t))
735                 (needsterm (or (assoc "needsterm" mime-info)                 (needsterm (or (assoc "needsterm" mime-info)
# Line 413  external if displayed external." Line 739  external if displayed external."
739            ;; We create a private sub-directory where we store our files.            ;; We create a private sub-directory where we store our files.
740            (set-file-modes dir 448)            (set-file-modes dir 448)
741            (if filename            (if filename
742                (setq file (expand-file-name (file-name-nondirectory filename)                (setq file (expand-file-name
743                                             dir))                            (gnus-map-function mm-file-name-rewrite-functions
744                                                 (file-name-nondirectory filename))
745                              dir))
746              (setq file (mm-make-temp-file (expand-file-name "mm." dir))))              (setq file (mm-make-temp-file (expand-file-name "mm." dir))))
747            (let ((coding-system-for-write mm-binary-coding-system))            (let ((coding-system-for-write mm-binary-coding-system))
748              (write-region (point-min) (point-max) file nil 'nomesg))              (write-region (point-min) (point-max) file nil 'nomesg))
749            (message "Viewing with %s" method)            (message "Viewing with %s" method)
750            (cond (needsterm            (cond
751                   (unwind-protect             (needsterm
752                       (start-process "*display*" nil              (let ((command (mm-mailcap-command
753                                      "xterm"                              method file (mm-handle-type handle))))
754                                      "-e" shell-file-name                (unwind-protect
755                                      shell-command-switch                    (if window-system
756                                      (mm-mailcap-command                        (start-process "*display*" nil
757                                       method file (mm-handle-type handle)))                                       mm-external-terminal-program
758                     (mm-handle-set-undisplayer handle (cons file buffer)))                                       "-e" shell-file-name
759                   (message "Displaying %s..." (format method file))                                       shell-command-switch command)
760                   'external)                      (require 'term)
761                  (copiousoutput                      (require 'gnus-win)
762                   (with-current-buffer outbuf                      (set-buffer
763                     (forward-line 1)                       (setq buffer
764                     (mm-insert-inline                             (make-term "display"
765                      handle                                        shell-file-name
766                      (unwind-protect                                        nil
767                          (progn                                        shell-command-switch command)))
768                            (call-process shell-file-name nil                      (term-mode)
769                                          (setq buffer                      (term-char-mode)
770                                                (generate-new-buffer "*mm*"))                      (set-process-sentinel
771                                          nil                       (get-buffer-process buffer)
772                                          shell-command-switch                       `(lambda (process state)
773                                          (mm-mailcap-command                          (if (eq 'exit (process-status process))
774                                           method file (mm-handle-type handle)))                              (gnus-configure-windows
775                            (if (buffer-live-p buffer)                               ',gnus-current-window-configuration))))
776                                (save-excursion                      (gnus-configure-windows 'display-term))
777                                  (set-buffer buffer)                  (mm-handle-set-external-undisplayer handle (cons file buffer)))
778                                  (buffer-string))))                (message "Displaying %s..." command))
779                        (progn              'external)
780                          (ignore-errors (delete-file file))             (copiousoutput
781                          (ignore-errors (delete-directory              (with-current-buffer outbuf
782                                          (file-name-directory file)))                (forward-line 1)
783                          (ignore-errors (kill-buffer buffer))))))                (mm-insert-inline
784                   'inline)                 handle
785                  (t                 (unwind-protect
786                   (unwind-protect                     (progn
787                       (start-process "*display*"                       (call-process shell-file-name nil
788                                      (setq buffer                                     (setq buffer
789                                            (generate-new-buffer "*mm*"))                                           (generate-new-buffer " *mm*"))
790                                      shell-file-name                                     nil
791                                      shell-command-switch                                     shell-command-switch
792                                      (mm-mailcap-command                                     (mm-mailcap-command
793                                       method file (mm-handle-type handle)))                                      method file (mm-handle-type handle)))
794                     (mm-handle-set-undisplayer handle (cons file buffer)))                       (if (buffer-live-p buffer)
795                   (message "Displaying %s..." (format method file))                           (save-excursion
796                   'external)))))))                             (set-buffer buffer)
797                               (buffer-string))))
798                     (progn
799                       (ignore-errors (delete-file file))
800                       (ignore-errors (delete-directory
801                                       (file-name-directory file)))
802                       (ignore-errors (kill-buffer buffer))))))
803                'inline)
804               (t
805                (let ((command (mm-mailcap-command
806                                method file (mm-handle-type handle))))
807                  (unwind-protect
808                      (start-process "*display*"
809                                     (setq buffer
810                                           (generate-new-buffer " *mm*"))
811                                     shell-file-name
812                                     shell-command-switch command)
813                    (mm-handle-set-external-undisplayer
814                     handle (cons file buffer)))
815                  (message "Displaying %s..." command))
816                'external)))))))
817    
818  (defun mm-mailcap-command (method file type-list)  (defun mm-mailcap-command (method file type-list)
819    (let ((ctl (cdr type-list))    (let ((ctl (cdr type-list))
820          (beg 0)          (beg 0)
821          (uses-stdin t)          (uses-stdin t)
822          out sub total)          out sub total)
823      (while (string-match "%{\\([^}]+\\)}\\|%s\\|%t\\|%%" method beg)      (while (string-match "%{\\([^}]+\\)}\\|'%s'\\|\"%s\"\\|%s\\|%t\\|%%"
824                             method beg)
825        (push (substring method beg (match-beginning 0)) out)        (push (substring method beg (match-beginning 0)) out)
826        (setq beg (match-end 0)        (setq beg (match-end 0)
827              total (match-string 0 method)              total (match-string 0 method)
# Line 480  external if displayed external." Line 829  external if displayed external."
829        (cond        (cond
830         ((string= total "%%")         ((string= total "%%")
831          (push "%" out))          (push "%" out))
832         ((string= total "%s")         ((or (string= total "%s")
833                ;; We do our own quoting.
834                (string= total "'%s'")
835                (string= total "\"%s\""))
836          (setq uses-stdin nil)          (setq uses-stdin nil)
837          (push (mm-quote-arg file) out))          (push (mm-quote-arg
838                   (gnus-map-function mm-path-name-rewrite-functions file)) out))
839         ((string= total "%t")         ((string= total "%t")
840          (push (mm-quote-arg (car type-list)) out))          (push (mm-quote-arg (car type-list)) out))
841         (t         (t
842          (push (mm-quote-arg (or (cdr (assq (intern sub) ctl)) "")) out))))          (push (mm-quote-arg (or (cdr (assq (intern sub) ctl)) "")) out))))
843      (push (substring method beg (length method)) out)      (push (substring method beg (length method)) out)
844      (if uses-stdin      (when uses-stdin
845          (progn        (push "<" out)
846            (push "<" out)        (push (mm-quote-arg
847            (push (mm-quote-arg file) out)))               (gnus-map-function mm-path-name-rewrite-functions file))
848                out))
849      (mapconcat 'identity (nreverse out) "")))      (mapconcat 'identity (nreverse out) "")))
850    
851  (defun mm-remove-parts (handles)  (defun mm-remove-parts (handles)
# Line 503  external if displayed external." Line 857  external if displayed external."
857        (while (setq handle (pop handles))        (while (setq handle (pop handles))
858          (cond          (cond
859           ((stringp handle)           ((stringp handle)
860            ;; Do nothing.            (when (buffer-live-p (get-text-property 0 'buffer handle))
861            )              (kill-buffer (get-text-property 0 'buffer handle))))
862           ((and (listp handle)           ((and (listp handle)
863                 (stringp (car handle)))                 (stringp (car handle)))
864            (mm-remove-parts (cdr handle)))            (mm-remove-parts (cdr handle)))
# Line 520  external if displayed external." Line 874  external if displayed external."
874        (while (setq handle (pop handles))        (while (setq handle (pop handles))
875          (cond          (cond
876           ((stringp handle)           ((stringp handle)
877            ;; Do nothing.            (when (buffer-live-p (get-text-property 0 'buffer handle))
878            )              (kill-buffer (get-text-property 0 'buffer handle))))
879           ((and (listp handle)           ((and (listp handle)
880                 (stringp (car handle)))                 (stringp (car handle)))
881            (mm-destroy-parts (cdr handle)))            (mm-destroy-parts handle))
882           (t           (t
883            (mm-destroy-part handle)))))))            (mm-destroy-part handle)))))))
884    
# Line 543  external if displayed external." Line 897  external if displayed external."
897            (funcall object))            (funcall object))
898           ;; Externally displayed part.           ;; Externally displayed part.
899           ((consp object)           ((consp object)
900              (condition-case ()
901                  (while (get-buffer-process (cdr object))
902                    (interrupt-process (get-buffer-process (cdr object)))
903                    (message "Waiting for external displayer to die...")
904                    (sit-for 1))
905                (quit)
906                (error))
907              (ignore-errors (and (cdr object) (kill-buffer (cdr object))))
908              (message "Waiting for external displayer to die...done")
909            (ignore-errors (delete-file (car object)))            (ignore-errors (delete-file (car object)))
910            (ignore-errors (delete-directory (file-name-directory (car object))))            (ignore-errors (delete-directory (file-name-directory
911            (ignore-errors (kill-buffer (cdr object))))                                              (car object)))))
912           ((bufferp object)           ((bufferp object)
913            (when (buffer-live-p object)            (when (buffer-live-p object)
914              (kill-buffer object)))))              (kill-buffer object)))))
# Line 562  external if displayed external." Line 925  external if displayed external."
925      (when (string-match (car elem) type)      (when (string-match (car elem) type)
926        (return elem))))        (return elem))))
927    
928    (defun mm-automatic-display-p (handle)
929      "Say whether the user wants HANDLE to be displayed automatically."
930      (let ((methods mm-automatic-display)
931            (type (mm-handle-media-type handle))
932            method result)
933        (while (setq method (pop methods))
934          (when (and (not (mm-inline-override-p handle))
935                     (string-match method type))
936            (setq result t
937                  methods nil)))
938        result))
939    
940  (defun mm-inlinable-p (handle)  (defun mm-inlinable-p (handle)
941    "Say whether HANDLE can be displayed inline."    "Say whether HANDLE can be displayed inline."
942    (let ((alist mm-inline-media-tests)    (let ((alist mm-inline-media-tests)
# Line 575  external if displayed external." Line 950  external if displayed external."
950        (pop alist))        (pop alist))
951      test))      test))
952    
 (defun mm-automatic-display-p (handle)  
   "Say whether the user wants HANDLE to be displayed automatically."  
   (let ((methods mm-automatic-display)  
         (type (mm-handle-media-type handle))  
         method result)  
     (while (setq method (pop methods))  
       (when (and (not (mm-inline-override-p handle))  
                  (string-match method type)  
                  (mm-inlinable-p handle))  
         (setq result t  
               methods nil)))  
     result))  
   
953  (defun mm-inlined-p (handle)  (defun mm-inlined-p (handle)
954    "Say whether the user wants HANDLE to be displayed automatically."    "Say whether the user wants HANDLE to be displayed inline."
955    (let ((methods mm-inlined-types)    (let ((methods mm-inlined-types)
956          (type (mm-handle-media-type handle))          (type (mm-handle-media-type handle))
957          method result)          method result)
958      (while (setq method (pop methods))      (while (setq method (pop methods))
959        (when (and (not (mm-inline-override-p handle))        (when (and (not (mm-inline-override-p handle))
960                   (string-match method type)                   (string-match method type))
                  (mm-inlinable-p handle))  
961          (setq result t          (setq result t
962                methods nil)))                methods nil)))
963      result))      result))
# Line 650  external if displayed external." Line 1011  external if displayed external."
1011  (defun mm-get-part (handle)  (defun mm-get-part (handle)
1012    "Return the contents of HANDLE as a string."    "Return the contents of HANDLE as a string."
1013    (mm-with-unibyte-buffer    (mm-with-unibyte-buffer
1014      (mm-insert-part handle)      (insert (with-current-buffer (mm-handle-buffer handle)
1015                  (mm-with-unibyte-current-buffer
1016                    (buffer-string))))
1017        (mm-decode-content-transfer-encoding
1018         (mm-handle-encoding handle)
1019         (mm-handle-media-type handle))
1020      (buffer-string)))      (buffer-string)))
1021    
1022  (defun mm-insert-part (handle)  (defun mm-insert-part (handle)
# Line 659  external if displayed external." Line 1025  external if displayed external."
1025      (save-excursion      (save-excursion
1026        (if (member (mm-handle-media-supertype handle) '("text" "message"))        (if (member (mm-handle-media-supertype handle) '("text" "message"))
1027            (with-temp-buffer            (with-temp-buffer
1028              (insert-buffer-substring (mm-handle-buffer handle))              (insert-buffer-substring (mm-handle-buffer handle))
1029              (mm-decode-content-transfer-encoding              (prog1
1030               (mm-handle-encoding handle)                  (mm-decode-content-transfer-encoding
1031               (mm-handle-media-type handle))                   (mm-handle-encoding handle)
1032              (let ((temp (current-buffer)))                   (mm-handle-media-type handle))
1033                (set-buffer cur)                (let ((temp (current-buffer)))
1034                (insert-buffer-substring temp)))                  (set-buffer cur)
1035                    (insert-buffer-substring temp))))
1036          (mm-with-unibyte-buffer          (mm-with-unibyte-buffer
1037            (insert-buffer-substring (mm-handle-buffer handle))            (insert-buffer-substring (mm-handle-buffer handle))
1038            (mm-decode-content-transfer-encoding            (prog1
1039             (mm-handle-encoding handle)                (mm-decode-content-transfer-encoding
1040             (mm-handle-media-type handle))                 (mm-handle-encoding handle)
1041            (let ((temp (current-buffer)))                 (mm-handle-media-type handle))
1042              (set-buffer cur)              (let ((temp (current-buffer)))
1043              (insert-buffer-substring temp)))))))                (set-buffer cur)
1044                  (insert-buffer-substring temp))))))))
1045    
1046  (defvar mm-default-directory nil)  (defun mm-file-name-delete-whitespace (file-name)
1047      "Remove all whitespace characters from FILE-NAME."
1048      (while (string-match "\\s-+" file-name)
1049        (setq file-name (replace-match "" t t file-name)))
1050      file-name)
1051    
1052    (defun mm-file-name-trim-whitespace (file-name)
1053      "Remove leading and trailing whitespace characters from FILE-NAME."
1054      (when (string-match "\\`\\s-+" file-name)
1055        (setq file-name (substring file-name (match-end 0))))
1056      (when (string-match "\\s-+\\'" file-name)
1057        (setq file-name (substring file-name 0 (match-beginning 0))))
1058      file-name)
1059    
1060    (defun mm-file-name-collapse-whitespace (file-name)
1061      "Collapse multiple whitespace characters in FILE-NAME."
1062      (while (string-match "\\s-\\s-+" file-name)
1063        (setq file-name (replace-match " " t t file-name)))
1064      file-name)
1065    
1066    (defun mm-file-name-replace-whitespace (file-name)
1067      "Replace whitespace characters in FILE-NAME with underscores.
1068    Set the option `mm-file-name-replace-whitespace' to any other
1069    string if you do not like underscores."
1070      (let ((s (or mm-file-name-replace-whitespace "_")))
1071        (while (string-match "\\s-" file-name)
1072          (setq file-name (replace-match s t t file-name))))
1073      file-name)
1074    
1075    (defun mm-file-name-delete-control (filename)
1076      "Delete control characters from FILENAME."
1077      (gnus-replace-in-string filename "[\x00-\x1f\x7f]" ""))
1078    
1079    (defun mm-file-name-delete-gotchas (filename)
1080      "Delete shell gotchas from FILENAME."
1081      (setq filename (gnus-replace-in-string filename "[<>|]" ""))
1082      (gnus-replace-in-string filename "^[.-]+" ""))
1083    
1084  (defun mm-save-part (handle)  (defun mm-save-part (handle)
1085    "Write HANDLE to a file."    "Write HANDLE to a file."
# Line 684  external if displayed external." Line 1088  external if displayed external."
1088                      (mm-handle-disposition handle) 'filename))                      (mm-handle-disposition handle) 'filename))
1089           file)           file)
1090      (when filename      (when filename
1091        (setq filename (file-name-nondirectory filename)))        (setq filename (gnus-map-function mm-file-name-rewrite-functions
1092                                            (file-name-nondirectory filename))))
1093      (setq file      (setq file
1094            (read-file-name "Save MIME part to: "            (mm-with-multibyte
1095                            (expand-file-name              (read-file-name "Save MIME part to: "
1096                             (or filename name "")                              (or mm-default-directory default-directory)
1097                             (or mm-default-directory default-directory))))                              nil nil (or filename name ""))))
1098      (setq mm-default-directory (file-name-directory file))      (setq mm-default-directory (file-name-directory file))
1099      (when (or (not (file-exists-p file))      (and (or (not (file-exists-p file))
1100                (yes-or-no-p (format "File %s already exists; overwrite? "               (yes-or-no-p (format "File %s already exists; overwrite? "
1101                                     file)))                                    file)))
1102        (mm-save-part-to-file handle file))))           (progn
1103               (mm-save-part-to-file handle file)
1104               file))))
1105    
1106  (defun mm-save-part-to-file (handle file)  (defun mm-save-part-to-file (handle file)
1107    (mm-with-unibyte-buffer    (mm-with-unibyte-buffer
1108      (mm-insert-part handle)      (mm-insert-part handle)
1109      (let ((coding-system-for-write 'binary)      (let ((coding-system-for-write 'binary)
1110              (current-file-modes (default-file-modes))
1111            ;; Don't re-compress .gz & al.  Arguably we should make            ;; Don't re-compress .gz & al.  Arguably we should make
1112            ;; `file-name-handler-alist' nil, but that would chop            ;; `file-name-handler-alist' nil, but that would chop
1113            ;; ange-ftp, which is reasonable to use here.            ;; ange-ftp, which is reasonable to use here.
1114            (inhibit-file-name-operation 'write-region)            (inhibit-file-name-operation 'write-region)
1115            (inhibit-file-name-handlers            (inhibit-file-name-handlers
1116             (cons 'jka-compr-handler inhibit-file-name-handlers)))             (cons 'jka-compr-handler inhibit-file-name-handlers)))
1117        (write-region (point-min) (point-max) file))))        (set-default-file-modes mm-attachment-file-modes)
1118          (unwind-protect
1119              (write-region (point-min) (point-max) file)
1120            (set-default-file-modes current-file-modes)))))
1121    
1122  (defun mm-pipe-part (handle)  (defun mm-pipe-part (handle)
1123    "Pipe HANDLE to a process."    "Pipe HANDLE to a process."
# Line 715  external if displayed external." Line 1126  external if displayed external."
1126            (read-string "Shell command on MIME part: " mm-last-shell-command)))            (read-string "Shell command on MIME part: " mm-last-shell-command)))
1127      (mm-with-unibyte-buffer      (mm-with-unibyte-buffer
1128        (mm-insert-part handle)        (mm-insert-part handle)
1129        (shell-command-on-region (point-min) (point-max) command nil))))        (let ((coding-system-for-write 'binary))
1130            (shell-command-on-region (point-min) (point-max) command nil)))))
1131    
1132  (defun mm-interactively-view-part (handle)  (defun mm-interactively-view-part (handle)
1133    "Display HANDLE using METHOD."    "Display HANDLE using METHOD."
# Line 768  external if displayed external." Line 1180  external if displayed external."
1180    "Return the handle(s) referred to by ID."    "Return the handle(s) referred to by ID."
1181    (cdr (assoc id mm-content-id-alist)))    (cdr (assoc id mm-content-id-alist)))
1182    
1183    (defconst mm-image-type-regexps
1184      '(("/\\*.*XPM.\\*/" . xpm)
1185        ("P[1-6]" . pbm)
1186        ("GIF8" . gif)
1187        ("\377\330" . jpeg)
1188        ("\211PNG\r\n" . png)
1189        ("#define" . xbm)
1190        ("\\(MM\0\\*\\)\\|\\(II\\*\0\\)" . tiff)
1191        ("%!PS" . postscript))
1192      "Alist of (REGEXP . IMAGE-TYPE) pairs used to auto-detect image types.
1193    When the first bytes of an image file match REGEXP, it is assumed to
1194    be of image type IMAGE-TYPE.")
1195    
1196    ;; Steal from image.el. image-type-from-data suffers multi-line matching bug.
1197    (defun mm-image-type-from-buffer ()
1198      "Determine the image type from data in the current buffer.
1199    Value is a symbol specifying the image type or nil if type cannot
1200    be determined."
1201      (let ((types mm-image-type-regexps)
1202            type)
1203        (goto-char (point-min))
1204        (while (and types (null type))
1205          (let ((regexp (car (car types)))
1206                (image-type (cdr (car types))))
1207            (when (looking-at regexp)
1208              (setq type image-type))
1209            (setq types (cdr types))))
1210        type))
1211    
1212  (defun mm-get-image (handle)  (defun mm-get-image (handle)
1213    "Return an image instance based on HANDLE."    "Return an image instance based on HANDLE."
1214    (let ((type (mm-handle-media-subtype handle))    (let ((type (mm-handle-media-subtype handle))
# Line 788  external if displayed external." Line 1229  external if displayed external."
1229            (prog1            (prog1
1230                (setq spec                (setq spec
1231                      (ignore-errors                      (ignore-errors
1232                       ;; Avoid testing `make-glyph' since W3 may define                        ;; Avoid testing `make-glyph' since W3 may define
1233                       ;; a bogus version of it.                        ;; a bogus version of it.
1234                        (if (fboundp 'create-image)                        (if (fboundp 'create-image)
1235                            (create-image (buffer-string) (intern type) 'data-p)                            (create-image (buffer-string)
1236                          (cond                                          (or (mm-image-type-from-buffer)
1237                           ((equal type "xbm")                                              (intern type))
1238                            ;; xbm images require special handling, since                                          'data-p)
1239                            ;; the only way to create glyphs from these                          (mm-create-image-xemacs type))))
                           ;; (without a ton of work) is to write them  
                           ;; out to a file, and then create a file  
                           ;; specifier.  
                           (let ((file (mm-make-temp-file  
                                        (expand-file-name "emm.xbm"  
                                                          mm-tmp-directory))))  
                             (unwind-protect  
                                 (progn  
                                   (write-region (point-min) (point-max) file)  
                                   (make-glyph (list (cons 'x file))))  
                               (ignore-errors  
                                (delete-file file)))))  
                          (t  
                           (make-glyph  
                            (vector (intern type) :data (buffer-string))))))))  
1240              (mm-handle-set-cache handle spec))))))              (mm-handle-set-cache handle spec))))))
1241    
1242    (defun mm-create-image-xemacs (type)
1243      (cond
1244       ((equal type "xbm")
1245        ;; xbm images require special handling, since
1246        ;; the only way to create glyphs from these
1247        ;; (without a ton of work) is to write them
1248        ;; out to a file, and then create a file
1249        ;; specifier.
1250        (let ((file (mm-make-temp-file
1251                     (expand-file-name "emm.xbm"
1252                                       mm-tmp-directory))))
1253          (unwind-protect
1254              (progn
1255                (write-region (point-min) (point-max) file)
1256                (make-glyph (list (cons 'x file))))
1257            (ignore-errors
1258              (delete-file file)))))
1259       (t
1260        (make-glyph
1261         (vector
1262          (or (mm-image-type-from-buffer)
1263              (intern type))
1264          :data (buffer-string))))))
1265    
1266  (defun mm-image-fit-p (handle)  (defun mm-image-fit-p (handle)
1267    "Say whether the image in HANDLE will fit the current window."    "Say whether the image in HANDLE will fit the current window."
1268    (let ((image (mm-get-image handle)))    (let ((image (mm-get-image handle)))
# Line 848  external if displayed external." Line 1298  external if displayed external."
1298    (and (mm-valid-image-format-p format)    (and (mm-valid-image-format-p format)
1299         (mm-image-fit-p handle)))         (mm-image-fit-p handle)))
1300    
1301    (defun mm-find-part-by-type (handles type &optional notp recursive)
1302      "Search in HANDLES for part with TYPE.
1303    If NOTP, returns first non-matching part.
1304    If RECURSIVE, search recursively."
1305      (let (handle)
1306        (while handles
1307          (if (and recursive (stringp (caar handles)))
1308              (if (setq handle (mm-find-part-by-type (cdar handles) type
1309                                                     notp recursive))
1310                  (setq handles nil))
1311            (if (if notp
1312                    (not (equal (mm-handle-media-type (car handles)) type))
1313                  (equal (mm-handle-media-type (car handles)) type))
1314                (setq handle (car handles)
1315                      handles nil)))
1316          (setq handles (cdr handles)))
1317        handle))
1318    
1319    (defun mm-find-raw-part-by-type (ctl type &optional notp)
1320      (goto-char (point-min))
1321      (let* ((boundary (concat "--" (mm-handle-multipart-ctl-parameter ctl
1322                                                                       'boundary)))
1323             (close-delimiter (concat "^" (regexp-quote boundary) "--[ \t]*$"))
1324             start
1325             (end (save-excursion
1326                    (goto-char (point-max))
1327                    (if (re-search-backward close-delimiter nil t)
1328                        (match-beginning 0)
1329                      (point-max))))
1330             result)
1331        (setq boundary (concat "^" (regexp-quote boundary) "[ \t]*$"))
1332        (while (and (not result)
1333                    (re-search-forward boundary end t))
1334          (goto-char (match-beginning 0))
1335          (when start
1336            (save-excursion
1337              (save-restriction
1338                (narrow-to-region start (1- (point)))
1339                (when (let ((ctl (ignore-errors
1340                                   (mail-header-parse-content-type
1341                                    (mail-fetch-field "content-type")))))
1342                        (if notp
1343                            (not (equal (car ctl) type))
1344                          (equal (car ctl) type)))
1345                  (setq result (buffer-string))))))
1346          (forward-line 1)
1347          (setq start (point)))
1348        (when (and (not result) start)
1349          (save-excursion
1350            (save-restriction
1351              (narrow-to-region start end)
1352              (when (let ((ctl (ignore-errors
1353                                 (mail-header-parse-content-type
1354                                  (mail-fetch-field "content-type")))))
1355                      (if notp
1356                          (not (equal (car ctl) type))
1357                        (equal (car ctl) type)))
1358                (setq result (buffer-string))))))
1359        result))
1360    
1361    (defvar mm-security-handle nil)
1362    
1363    (defsubst mm-set-handle-multipart-parameter (handle parameter value)
1364      ;; HANDLE could be a CTL.
1365      (when handle
1366        (put-text-property 0 (length (car handle)) parameter value
1367                           (car handle))))
1368    
1369    (defun mm-possibly-verify-or-decrypt (parts ctl)
1370      (let ((type (car ctl))
1371            (subtype (cadr (split-string (car ctl) "/")))
1372            (mm-security-handle ctl) ;; (car CTL) is the type.
1373            protocol func functest)
1374        (cond
1375         ((or (equal type "application/x-pkcs7-mime")
1376              (equal type "application/pkcs7-mime"))
1377          (with-temp-buffer
1378            (when (and (cond
1379                        ((eq mm-decrypt-option 'never) nil)
1380                        ((eq mm-decrypt-option 'always) t)
1381                        ((eq mm-decrypt-option 'known) t)
1382                        (t (y-or-n-p
1383                            (format "Decrypt (S/MIME) part? "))))
1384                       (mm-view-pkcs7 parts))
1385              (setq parts (mm-dissect-buffer t)))))
1386         ((equal subtype "signed")
1387          (unless (and (setq protocol
1388                             (mm-handle-multipart-ctl-parameter ctl 'protocol))
1389                       (not (equal protocol "multipart/mixed")))
1390            ;; The message is broken or draft-ietf-openpgp-multsig-01.
1391            (let ((protocols mm-verify-function-alist))
1392              (while protocols
1393                (if (and (or (not (setq functest (nth 3 (car protocols))))
1394                             (funcall functest parts ctl))
1395                         (mm-find-part-by-type parts (caar protocols) nil t))
1396                    (setq protocol (caar protocols)
1397                          protocols nil)
1398                  (setq protocols (cdr protocols))))))
1399          (setq func (nth 1 (assoc protocol mm-verify-function-alist)))
1400          (when (cond
1401                 ((eq mm-verify-option 'never) nil)
1402                 ((eq mm-verify-option 'always) t)
1403                 ((eq mm-verify-option 'known)
1404                  (and func
1405                       (or (not (setq functest
1406                                      (nth 3 (assoc protocol
1407                                                    mm-verify-function-alist))))
1408                           (funcall functest parts ctl))))
1409                 (t
1410                  (y-or-n-p
1411                   (format "Verify signed (%s) part? "
1412                           (or (nth 2 (assoc protocol mm-verify-function-alist))
1413                               (format "protocol=%s" protocol))))))
1414            (save-excursion
1415              (if func
1416                  (funcall func parts ctl)
1417                (mm-set-handle-multipart-parameter
1418                 mm-security-handle 'gnus-details
1419                 (format "Unknown sign protocol (%s)" protocol))))))
1420         ((equal subtype "encrypted")
1421          (unless (setq protocol
1422                        (mm-handle-multipart-ctl-parameter ctl 'protocol))
1423            ;; The message is broken.
1424            (let ((parts parts))
1425              (while parts
1426                (if (assoc (mm-handle-media-type (car parts))
1427                           mm-decrypt-function-alist)
1428                    (setq protocol (mm-handle-media-type (car parts))
1429                          parts nil)
1430                  (setq parts (cdr parts))))))
1431          (setq func (nth 1 (assoc protocol mm-decrypt-function-alist)))
1432          (when (cond
1433                 ((eq mm-decrypt-option 'never) nil)
1434                 ((eq mm-decrypt-option 'always) t)
1435                 ((eq mm-decrypt-option 'known)
1436                  (and func
1437                       (or (not (setq functest
1438                                      (nth 3 (assoc protocol
1439                                                    mm-decrypt-function-alist))))
1440                           (funcall functest parts ctl))))
1441                 (t
1442                  (y-or-n-p
1443                   (format "Decrypt (%s) part? "
1444                           (or (nth 2 (assoc protocol mm-decrypt-function-alist))
1445                               (format "protocol=%s" protocol))))))
1446            (save-excursion
1447              (if func
1448                  (setq parts (funcall func parts ctl))
1449                (mm-set-handle-multipart-parameter
1450                 mm-security-handle 'gnus-details
1451                 (format "Unknown encrypt protocol (%s)" protocol))))))
1452         (t nil))
1453        parts))
1454    
1455    (defun mm-multiple-handles (handles)
1456      (and (listp handles)
1457           (> (length handles) 1)
1458           (or (listp (car handles))
1459               (stringp (car handles)))))
1460    
1461    (defun mm-complicated-handles (handles)
1462      (and (listp (car handles))
1463           (> (length handles) 1)))
1464    
1465    (defun mm-merge-handles (handles1 handles2)
1466      (append
1467       (if (listp (car handles1))
1468           handles1
1469         (list handles1))
1470       (if (listp (car handles2))
1471           handles2
1472         (list handles2))))
1473    
1474    (defun mm-readable-p (handle)
1475      "Say whether the content of HANDLE is readable."
1476      (and (< (with-current-buffer (mm-handle-buffer handle)
1477                (buffer-size)) 10000)
1478           (mm-with-unibyte-buffer
1479             (mm-insert-part handle)
1480             (and (eq (mm-body-7-or-8) '7bit)
1481                  (not (mm-long-lines-p 76))))))
1482    
1483  (provide 'mm-decode)  (provide 'mm-decode)
1484    
1485  ;;; arch-tag: 4f35d360-56b8-4030-9388-3ed82d359b9b  ;;; arch-tag: 4f35d360-56b8-4030-9388-3ed82d359b9b

Legend:
Removed from v.1.13.6.1  
changed lines
  Added in v.1.13.6.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26