Sync up with Pterodactyl Gnus v0.56.
[elisp/gnus.git-] / lisp / mm-decode.el
1 ;;; mm-decode.el --- Functions for decoding MIME things
2 ;; Copyright (C) 1998 Free Software Foundation, Inc.
3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
6 ;; This file is part of GNU Emacs.
7
8 ;; GNU Emacs is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation; either version 2, or (at your option)
11 ;; any later version.
12
13 ;; GNU Emacs is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;; GNU General Public License for more details.
17
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 ;; Boston, MA 02111-1307, USA.
22
23 ;;; Commentary:
24
25 ;;; Code:
26
27 (require 'mail-parse)
28 (require 'gnus-mailcap)
29 (require 'mm-bodies)
30
31 ;;; Convenience macros.
32
33 (defmacro mm-handle-buffer (handle)
34   `(nth 0 ,handle))
35 (defmacro mm-handle-type (handle)
36   `(nth 1 ,handle))
37 (defmacro mm-handle-encoding (handle)
38   `(nth 2 ,handle))
39 (defmacro mm-handle-undisplayer (handle)
40   `(nth 3 ,handle))
41 (defmacro mm-handle-set-undisplayer (handle function)
42   `(setcar (nthcdr 3 ,handle) ,function))
43 (defmacro mm-handle-disposition (handle)
44   `(nth 4 ,handle))
45 (defmacro mm-handle-description (handle)
46   `(nth 5 ,handle))
47
48 (defvar mm-inline-media-tests
49   '(("image/jpeg" mm-inline-image
50      (and window-system (featurep 'jpeg) (mm-image-fit-p handle)))
51     ("image/png" mm-inline-image
52      (and window-system (featurep 'png) (mm-image-fit-p handle)))
53     ("image/gif" mm-inline-image
54      (and window-system (featurep 'gif) (mm-image-fit-p handle)))
55     ("image/tiff" mm-inline-image
56      (and window-system (featurep 'tiff) (mm-image-fit-p handle)))
57     ("image/xbm" mm-inline-image
58      (and window-system (fboundp 'device-type)
59           (eq (device-type) 'x)))
60     ("image/xpm" mm-inline-image
61      (and window-system (featurep 'xpm)))
62     ("image/bmp" mm-inline-image
63      (and window-system (featurep 'bmp)))
64     ("text/plain" mm-inline-text t)
65     ("text/enriched" mm-inline-text t)
66     ("text/richtext" mm-inline-text t)
67     ("text/html" mm-inline-text (locate-library "w3"))
68     ("message/delivery-status" mm-inline-text t)
69     ("audio/wav" mm-inline-audio
70      (and (or (featurep 'nas-sound) (featurep 'native-sound))
71           (device-sound-enabled-p)))
72     ("audio/au" mm-inline-audio
73      (and (or (featurep 'nas-sound) (featurep 'native-sound))
74           (device-sound-enabled-p))))
75   "Alist of media types/test that say whether the media types can be displayed inline.")
76
77 (defvar mm-user-display-methods
78   '(("image/.*" . inline)
79     ("text/.*" . inline)
80     ("message/delivery-status" . inline)))
81
82 (defvar mm-user-automatic-display
83   '("text/plain" "text/enriched" "text/richtext" "text/html" 
84     "image/.*" "message/delivery-status" "multipart/.*"))
85
86 (defvar mm-alternative-precedence
87   '("image/jpeg" "image/gif" "text/html" "text/enriched"
88     "text/richtext" "text/plain")
89   "List that describes the precedence of alternative parts.")
90
91 (defvar mm-tmp-directory "/tmp/"
92   "Where mm will store its temporary files.")
93
94 ;;; Internal variables.
95
96 (defvar mm-dissection-list nil)
97 (defvar mm-last-shell-command "")
98 (defvar mm-content-id-alist nil)
99
100 ;;; The functions.
101
102 (defun mm-dissect-buffer (&optional no-strict-mime)
103   "Dissect the current buffer and return a list of MIME handles."
104   (save-excursion
105     (let (ct ctl type subtype cte cd description id result)
106       (save-restriction
107         (mail-narrow-to-head)
108         (when (and (or no-strict-mime
109                        (mail-fetch-field "mime-version"))
110                    (setq ct (mail-fetch-field "content-type")))
111           (setq ctl (condition-case () (mail-header-parse-content-type ct)
112                       (error nil))
113                 cte (mail-fetch-field "content-transfer-encoding")
114                 cd (mail-fetch-field "content-disposition")
115                 description (mail-fetch-field "content-description")
116                 id (mail-fetch-field "content-id"))))
117       (if (not ctl)
118           (mm-dissect-singlepart
119            '("text/plain") nil no-strict-mime nil description)
120         (setq type (split-string (car ctl) "/"))
121         (setq subtype (cadr type)
122               type (pop type))
123         (setq
124          result
125          (cond
126           ((equal type "multipart")
127            (cons (car ctl) (mm-dissect-multipart ctl)))
128           (t
129            (mm-dissect-singlepart
130             ctl
131             (and cte (intern (downcase (mail-header-remove-whitespace
132                                         (mail-header-remove-comments
133                                          cte)))))
134             no-strict-mime
135             (and cd (condition-case ()
136                         (mail-header-parse-content-disposition cd)
137                       (error nil)))
138             description))))
139         (when id
140           (when (string-match " *<\\(.*\\)> *" id)
141             (setq id (match-string 1 id)))
142           (push (cons id result) mm-content-id-alist))
143         result))))
144
145 (defun mm-dissect-singlepart (ctl cte &optional force cdl description)
146   (when (or force
147             (not (equal "text/plain" (car ctl))))
148     (let ((res (list (mm-copy-to-buffer) ctl cte nil cdl description)))
149       (push (car res) mm-dissection-list)
150       res)))
151
152 (defun mm-remove-all-parts ()
153   "Remove all MIME handles."
154   (interactive)
155   (mapcar 'mm-remove-part mm-dissection-list)
156   (setq mm-dissection-list nil))
157
158 (defun mm-dissect-multipart (ctl)
159   (goto-char (point-min))
160   (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
161         (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$"))
162         start parts 
163         (end (save-excursion    
164                (goto-char (point-max))
165                (if (re-search-backward close-delimiter nil t)
166                    (match-beginning 0)
167                  (point-max)))))
168     (while (search-forward boundary end t)
169       (goto-char (match-beginning 0))
170       (when start
171         (save-excursion
172           (save-restriction
173             (narrow-to-region start (point))
174             (setq parts (nconc (list (mm-dissect-buffer t)) parts)))))
175       (forward-line 2)
176       (setq start (point)))
177     (when start
178       (save-excursion
179         (save-restriction
180           (narrow-to-region start end)
181           (setq parts (nconc (list (mm-dissect-buffer t)) parts)))))
182     (nreverse parts)))
183
184 (defun mm-copy-to-buffer ()
185   "Copy the contents of the current buffer to a fresh buffer."
186   (save-excursion
187     (let ((obuf (current-buffer))
188           beg)
189       (goto-char (point-min))
190       (search-forward-regexp "^\n" nil t)
191       (setq beg (point))
192       (set-buffer (generate-new-buffer " *mm*"))
193       (insert-buffer-substring obuf beg)
194       (current-buffer))))
195
196 (defun mm-inlinable-part-p (type)
197   "Say whether TYPE can be displayed inline."
198   (eq (mm-user-method type) 'inline))
199
200 (defun mm-display-part (handle &optional no-default)
201   "Display the MIME part represented by HANDLE.
202 Returns nil if the part is removed; inline if displayed inline;
203 external if displayed external."
204   (save-excursion
205     (mailcap-parse-mailcaps)
206     (if (mm-handle-displayed-p handle)
207         (mm-remove-part handle)
208       (let* ((type (car (mm-handle-type handle)))
209              (method (mailcap-mime-info type))
210              (user-method (mm-user-method type)))
211         (if (eq user-method 'inline)
212             (progn
213               (forward-line 1)
214               (mm-display-inline handle))
215           (when (or user-method
216                     method
217                     (not no-default))
218             (if (and (not user-method)
219                      (not method)
220                      (equal "text" (car (split-string type))))
221                 (progn
222                   (mm-insert-inline handle (mm-get-part handle))
223                   'inline)
224               (mm-display-external
225                handle (or user-method method
226                           'mailcap-save-binary-file))
227               'external)))))))
228
229 (defun mm-display-external (handle method)
230   "Display HANDLE using METHOD."
231   (mm-with-unibyte-buffer
232     (insert-buffer-substring (mm-handle-buffer handle))
233     (mm-decode-content-transfer-encoding
234      (mm-handle-encoding handle) (car (mm-handle-type handle)))
235     (if (functionp method)
236         (let ((cur (current-buffer)))
237           (if (eq method 'mailcap-save-binary-file)
238               (progn
239                 (set-buffer (generate-new-buffer "*mm*"))
240                 (setq method nil))
241             (let ((win (get-buffer-window cur t)))
242               (when win
243                 (select-window win)))
244             (switch-to-buffer (generate-new-buffer "*mm*")))
245           (buffer-disable-undo)
246           (mm-set-buffer-file-coding-system mm-binary-coding-system)
247           (insert-buffer-substring cur)
248           (message "Viewing with %s" method)
249           (let ((mm (current-buffer)))
250             (unwind-protect
251                 (if method
252                     (funcall method)
253                   (mm-save-part handle))
254               (mm-handle-set-undisplayer handle mm))))
255       (let* ((dir (make-temp-name (expand-file-name "emm." mm-tmp-directory)))
256              (filename (mail-content-type-get
257                         (mm-handle-disposition handle) 'filename))
258              (needsterm (assoc "needsterm"
259                                (mailcap-mime-info
260                                 (car (mm-handle-type handle)) t)))
261              process file)
262         ;; We create a private sub-directory where we store our files.
263         (make-directory dir)
264         (set-file-modes dir 448)
265         (if filename
266             (setq file (expand-file-name (file-name-nondirectory filename)
267                                          dir))
268           (setq file (make-temp-name (expand-file-name "mm." dir))))
269         (write-region (point-min) (point-max) file nil 'nomesg)
270         (message "Viewing with %s" method)
271         (unwind-protect
272             (setq process
273                   (if needsterm
274                       (start-process "*display*" nil
275                                      "xterm"
276                                      "-e" shell-file-name "-c"
277                                      (format method
278                                              (mm-quote-arg file)))
279                     (start-process "*display*" (generate-new-buffer "*mm*")
280                                    shell-file-name
281                                    "-c" (format method
282                                                 (mm-quote-arg file)))))
283           (mm-handle-set-undisplayer handle (cons file process)))
284         (message "Displaying %s..." (format method file))))))
285
286 (defun mm-remove-parts (handles)
287   "Remove the displayed MIME parts represented by HANDLE."
288   (if (and (listp handles)
289            (bufferp (car handles)))
290       (mm-remove-part handles)
291     (let (handle)
292       (while (setq handle (pop handles))
293         (cond
294          ((stringp handle)
295           )
296          ((and (listp handle)
297                (stringp (car handle)))
298           (mm-remove-parts (cdr handle)))
299          (t
300           (mm-remove-part handle)))))))
301
302 (defun mm-destroy-parts (handles)
303   "Remove the displayed MIME parts represented by HANDLE."
304   (if (and (listp handles)
305            (bufferp (car handles)))
306       (mm-destroy-part handles)
307     (let (handle)
308       (while (setq handle (pop handles))
309         (cond
310          ((stringp handle)
311           )
312          ((and (listp handle)
313                (stringp (car handle)))
314           (mm-destroy-parts (cdr handle)))
315          (t
316           (mm-destroy-part handle)))))))
317
318 (defun mm-remove-part (handle)
319   "Remove the displayed MIME part represented by HANDLE."
320   (when (listp handle)
321     (let ((object (mm-handle-undisplayer handle)))
322       (condition-case ()
323           (cond
324            ;; Internally displayed part.
325            ((mm-annotationp object)
326             (delete-annotation object))
327            ((or (functionp object)
328                 (and (listp object)
329                      (eq (car object) 'lambda)))
330             (funcall object))
331            ;; Externally displayed part.
332            ((consp object)
333             (condition-case ()
334                 (delete-file (car object))
335               (error nil))
336             (condition-case ()
337                 (delete-directory (file-name-directory (car object)))
338               (error nil))
339             (condition-case ()
340                 (kill-process (cdr object))
341               (error nil)))
342            ((bufferp object)
343             (when (buffer-live-p object)
344               (kill-buffer object))))
345         (error nil))
346       (mm-handle-set-undisplayer handle nil))))
347
348 (defun mm-display-inline (handle)
349   (let* ((type (car (mm-handle-type handle)))
350          (function (cadr (assoc type mm-inline-media-tests))))
351     (funcall function handle)
352     (goto-char (point-min))))
353
354 (defun mm-inlinable-p (type)
355   "Say whether TYPE can be displayed inline."
356   (let ((alist mm-inline-media-tests)
357         test)
358     (while alist
359       (when (equal type (caar alist))
360         (setq test (caddar alist)
361               alist nil)
362         (setq test (eval test)))
363       (pop alist))
364     test))
365
366 (defun mm-user-method (type)
367   "Return the user-defined method for TYPE."
368   (let ((methods mm-user-display-methods)
369         method result)
370     (while (setq method (pop methods))
371       (when (string-match (car method) type)
372         (when (or (not (eq (cdr method) 'inline))
373                   (mm-inlinable-p type))
374           (setq result (cdr method)
375                 methods nil))))
376     result))
377
378 (defun mm-automatic-display-p (type)
379   "Return the user-defined method for TYPE."
380   (let ((methods mm-user-automatic-display)
381         method result)
382     (while (setq method (pop methods))
383       (when (and (string-match method type)
384                  (mm-inlinable-p type))
385         (setq result t
386               methods nil)))
387     result))
388
389 (defun add-mime-display-method (type method)
390   "Make parts of TYPE be displayed with METHOD.
391 This overrides entries in the mailcap file."
392   (push (cons type method) mm-user-display-methods))
393
394 (defun mm-destroy-part (handle)
395   "Destroy the data structures connected to HANDLE."
396   (when (listp handle)
397     (mm-remove-part handle)
398     (when (buffer-live-p (mm-handle-buffer handle))
399       (kill-buffer (mm-handle-buffer handle)))))
400
401 (defun mm-handle-displayed-p (handle)
402   "Say whether HANDLE is displayed or not."
403   (mm-handle-undisplayer handle))
404   
405 (defun mm-quote-arg (arg)
406   "Return a version of ARG that is safe to evaluate in a shell."
407   (let ((pos 0) new-pos accum)
408     ;; *** bug: we don't handle newline characters properly
409     (while (setq new-pos (string-match "[;!`\"$\\& \t{} ]" arg pos))
410       (push (substring arg pos new-pos) accum)
411       (push "\\" accum)
412       (push (list (aref arg new-pos)) accum)
413       (setq pos (1+ new-pos)))
414     (if (= pos 0)
415         arg
416       (apply 'concat (nconc (nreverse accum) (list (substring arg pos)))))))
417
418 ;;;
419 ;;; Functions for outputting parts
420 ;;;
421
422 (defun mm-get-part (handle)
423   "Return the contents of HANDLE as a string."
424   (mm-with-unibyte-buffer
425     (insert-buffer-substring (mm-handle-buffer handle))
426     (mm-decode-content-transfer-encoding
427      (mm-handle-encoding handle)
428      (car (mm-handle-type handle)))
429     (buffer-string)))
430
431 (defvar mm-default-directory nil)
432
433 (defun mm-save-part (handle)
434   "Write HANDLE to a file."
435   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
436          (filename (mail-content-type-get
437                     (mm-handle-disposition handle) 'filename))
438          file)
439     (when filename
440       (setq filename (file-name-nondirectory filename)))
441     (setq file
442           (read-file-name "Save MIME part to: "
443                           (expand-file-name
444                            (or filename name "")
445                            (or mm-default-directory default-directory))))
446     (setq mm-default-directory (file-name-directory file))
447     (mm-with-unibyte-buffer
448       (insert-buffer-substring (mm-handle-buffer handle))
449       (mm-decode-content-transfer-encoding
450        (mm-handle-encoding handle)
451        (car (mm-handle-type handle)))
452       (when (or (not (file-exists-p file))
453                 (yes-or-no-p (format "File %s already exists; overwrite? "
454                                      file)))
455         ;; Now every coding system is 100% binary within mm-with-unibyte-buffer
456         ;; Is text still special?
457       (let ((coding-system-for-write
458              (if (equal "text" (car (split-string
459                                      (car (mm-handle-type handle)) "/")))
460                  buffer-file-coding-system
461                'binary)))
462         (write-region (point-min) (point-max) file))))))
463
464 (defun mm-pipe-part (handle)
465   "Pipe HANDLE to a process."
466   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
467          (command
468           (read-string "Shell command on MIME part: " mm-last-shell-command)))
469     (mm-with-unibyte-buffer
470       (insert-buffer-substring (mm-handle-buffer handle))
471       (mm-decode-content-transfer-encoding
472        (mm-handle-encoding handle)
473        (car (mm-handle-type handle)))
474       (shell-command-on-region (point-min) (point-max) command nil))))
475
476 (defun mm-interactively-view-part (handle)
477   "Display HANDLE using METHOD."
478   (let* ((type (car (mm-handle-type handle)))
479          (methods
480           (mapcar (lambda (i) (list (cdr (assoc 'viewer i))))
481                   (mailcap-mime-info type 'all)))
482          (method (completing-read "Viewer: " methods)))
483     (mm-display-external (copy-sequence handle) method)))
484
485 (defun mm-preferred-alternative (handles &optional preferred)
486   "Say which of HANDLES are preferred."
487   (let ((prec (if preferred (list preferred) mm-alternative-precedence))
488         p h result type handle)
489     (while (setq p (pop prec))
490       (setq h handles)
491       (while h
492         (setq type
493               (if (stringp (caar h))
494                   (caar h)
495                 (car (mm-handle-type (car h)))))
496         (setq handle (car h))
497         (when (and (equal p type)
498                    (mm-automatic-display-p type)
499                    (or (stringp (caar h))
500                        (not (mm-handle-disposition (car h)))
501                        (equal (car (mm-handle-disposition (car h)))
502                               "inline")))
503           (setq result (car h)
504                 h nil
505                 prec nil))
506         (pop h)))
507     result))
508
509 (defun mm-get-content-id (id)
510   "Return the handle(s) referred to by ID."
511   (cdr (assoc id mm-content-id-alist)))
512
513 (defun mm-get-image (handle)
514   "Return an image instance based on HANDLE."
515   (let ((type (cadr (split-string (car (mm-handle-type handle)) "/"))))
516     (mm-with-unibyte-buffer
517       (insert-buffer-substring (mm-handle-buffer handle))
518       (mm-decode-content-transfer-encoding
519        (mm-handle-encoding handle)
520        (car (mm-handle-type handle)))
521       (make-image-specifier
522        (vector (intern type) :data (buffer-string))))))
523
524 (defun mm-image-fit-p (handle)
525   "Say whether the image in HANDLE will fit the current window."
526   (let ((image (make-annotation (mm-get-image handle))))
527     (and (< (glyph-width (annotation-glyph image))
528             (window-pixel-width))
529          (< (glyph-height (annotation-glyph image))
530             (window-pixel-height)))))
531
532 (provide 'mm-decode)
533
534 ;; mm-decode.el ends here