2 ;;; A MIME viewer for GNU Emacs
4 ;;; by Morioka Tomohiko, 1994/07/13
12 (defconst mime/viewer-RCS-ID
13 "$Id: tm-view.el,v 3.1 1994/08/31 07:16:10 morioka Exp $")
15 (defconst mime/viewer-version
16 (and (string-match "[0-9][0-9.]*" mime/viewer-RCS-ID)
17 (substring mime/viewer-RCS-ID (match-beginning 0)(match-end 0))
34 (defconst mime/tspecials "\000-\040()<>@,;:\\\"/[\093?.=")
35 (defconst mime/token-regexp
36 (concat "[^" mime/tspecials "]*"))
37 (defconst mime/content-type-subtype-regexp
38 (concat mime/token-regexp "/" mime/token-regexp))
39 (defconst mime/content-parameter-value-regexp
41 message/quoted-string-regexp
44 (defconst mime/output-buffer-name "*MIME-out*")
45 (defconst mime/decoding-buffer-name "*MIME-decoding*")
51 (defvar mime/content-decoding-method-alist
52 '(("text/plain" . "tm-plain")
53 ("text/x-latex" . "tm-latex")
54 ("audio/basic" . "tm-au")
55 ("image/gif" . "tm-image")
56 ("image/jpeg" . "tm-image")
57 ("image/tiff" . "tm-image")
58 ("image/x-tiff" . "tm-image")
59 ("image/x-xbm" . "tm-image")
60 ("image/x-pic" . "tm-image")
61 ("video/mpeg" . "tm-mpeg")
62 ("application/octet-stream" . "tm-file")
65 (defvar mime/default-showing-Content-Type-list
66 '("text/plain" "text/x-latex" "message/rfc822"))
68 (setq mime/default-showing-Content-Type-list
69 '("text/plain" "text/x-latex" "message/rfc822"))
71 (defvar mime/go-to-top-node-method-alist
72 '((gnus-article-mode . (lambda ()
73 (gnus-article-show-summary)
75 (rmail-mode . (lambda ()
78 (delete-other-windows)
80 (mh-show-mode . (lambda ()
82 (let ((name (buffer-name)))
83 (string-match "show-" name)
84 (substring name (match-end 0))
87 (mime/show-message-mode . (lambda ()
88 (set-window-configuration
89 mime/show-mode-old-window-configuration)
90 (let ((buf (current-buffer)))
91 (pop-to-buffer mime/mother-buffer)
96 (defvar mime/tmp-dir "/tmp/")
98 (defvar mime/use-internal-decoder nil)
100 (defvar mime/body-decoding-mode "play" "MIME body decoding mode")
106 (defun mime/parse-content ()
109 (mime/decode-message-header)
110 (goto-char (point-min))
111 (let* ((ctl (mime/Content-Type))
112 (boundary (assoc "boundary" (cdr ctl)))
114 (search-forward "\n\n" nil t)
116 (let ((sep (concat "\n--"
117 (setq boundary (read (cdr boundary)))
120 (setq beg (match-end 0))
121 (search-forward (concat "\n--" boundary "--\n") nil t)
122 (setq end (match-beginning 0))
125 (narrow-to-region beg end)
126 (goto-char (point-min))
127 (search-forward (concat "--" boundary "\n") nil t)
128 (setq cb (match-end 0))
129 (while (search-forward sep nil t)
130 (setq ce (match-beginning 0))
131 (setq ncb (match-end 0))
134 (narrow-to-region cb ce)
135 (setq ret (mime/parse-content))
137 (setq dest (append dest (list ret)))
138 (goto-char (nth 1 ret))
139 (search-forward (concat "--" boundary "\n") nil t)
140 (goto-char (setq cb (match-end 0)))
142 (setq ce (point-max))
145 (narrow-to-region cb ce)
146 (setq ret (mime/parse-content))
148 (setq dest (append dest (list ret)))
150 (setq beg (point-min))
152 (search-forward (concat "\n--" boundary "--\n") nil t)
153 (setq end (match-beginning 0))
155 ((string= (car ctl) "message/rfc822")
158 (narrow-to-region (match-end 0) (point-max))
159 (setq dest (list (mime/parse-content)))
161 (setq beg (point-min))
162 (setq end (point-max))
165 (setq beg (point-min))
166 (setq end (point-max))
171 (defun mime/Content-Type ()
174 (if (and (re-search-forward "^Content-Type:[ \t]*" nil t)
178 (and (re-search-forward ".*\\(\n[ \t].*\\)*" nil t)
181 (goto-char (point-min))
182 (re-search-forward mime/content-type-subtype-regexp nil t)
186 (buffer-substring (match-beginning 0) (match-end 0))
188 dest attribute value)
189 (while (and (re-search-forward "[ \t\n]*;[ \t\n]*" nil t)
190 (re-search-forward mime/token-regexp nil t)
194 (buffer-substring (match-beginning 0) (match-end 0))
196 (if (and (re-search-forward "=[ \t\n]*" nil t)
197 (re-search-forward mime/content-parameter-value-regexp
202 (buffer-substring (match-beginning 0)
210 (defun mime/Content-Transfer-Encoding (&optional default-encoding)
213 (if (and (re-search-forward "^Content-Transfer-Encoding:[ \t]*" nil t)
214 (re-search-forward mime/token-regexp nil t)
216 (downcase (buffer-substring (match-beginning 0) (match-end 0)))
220 (defun mime/get-name (ctype)
225 (or (and (setq ret (assoc "name" ctype))
228 (and (setq ret (assoc "x-name" ctype))
230 (message/get-field-body "Content-Description")
234 (defun mime/parse-message ()
238 (setq selective-display t)
239 (make-variable-buffer-local 'mime/content-list)
240 (let ((buffer-read-only nil))
241 (setq mime/content-list (mime/parse-content))
244 (set-buffer-modified-p nil)
248 ;;; @ content information
251 (defun mime/get-point-content-number (p &optional cl)
253 (setq cl mime/content-list)
259 (if (and (<= b p)(<= p e))
260 (or (let (co ret (sn 0))
264 (setq ret (mime/get-point-content-number p co))
265 (cond ((eq ret t) (throw 'tag (list sn)))
266 (ret (throw 'tag (cons sn ret)))
273 (defun mime/get-content-region (cn &optional cl)
275 (setq cl mime/content-list)
282 (let ((rcl (nth sn (nth 2 cl))))
284 (mime/get-content-region (cdr cn) rcl)
288 (defun mime/make-flat-content-list (&optional cl)
290 (setq cl mime/content-list)
292 (let ((dest (list (car cl)))
296 (setq dest (append dest (mime/make-flat-content-list (car rcl))))
305 (defun mime/base64-decode-region (beg end &optional buf filename)
306 (let ((the-buf (current-buffer)) ret)
308 (setq buf (get-buffer-create mime/decoding-buffer-name))
312 (switch-to-buffer buf)
314 (switch-to-buffer the-buf)
315 (narrow-to-region beg end)
316 (goto-char (point-min))
317 (while (re-search-forward
319 mime/Base64-encoded-text-regexp
321 (setq ret (mime/base64-decode-string
322 (buffer-substring (match-beginning 0)
325 (switch-to-buffer buf)
327 (switch-to-buffer the-buf)
331 (switch-to-buffer buf)
332 (let ((kanji-flag nil)
335 (if (featurep 'mule) *noconv*))
337 (write-file filename)
339 (switch-to-buffer the-buf)
343 (defun mime/start-external-method-region (beg end ctype ctl encoding)
345 (let ((method (cdr (assoc ctype mime/content-decoding-method-alist)))
346 (name (mime/get-name ctl))
350 (search-forward "\n\n" nil t)
351 (let ((file (make-temp-name
352 (expand-file-name "TM" mime/tmp-dir)))
356 (if (and (string= encoding "base64")
357 mime/use-internal-decoder)
359 (mime/base64-decode-region b e nil file)
360 (setq encoding "binary")
362 (write-region b e file)
364 (start-process method mime/output-buffer-name method file
366 (if mime/body-decoding-mode
367 mime/body-decoding-mode
369 (replace-as-filename name)
371 (if (null (get-buffer-window mime/output-buffer-name))
372 (let ((the-buf (current-buffer)))
373 (split-window-vertically (/ (* (window-height) 3) 4))
374 (pop-to-buffer mime/output-buffer-name)
375 (pop-to-buffer the-buf)
379 (defun mime/decode-message/partial-region (beg end ctype default-encoding)
381 (let ((root-dir (expand-file-name
382 (concat "m-prts-" (user-login-name)) mime/tmp-dir))
383 (id (cdr (assoc "id" ctype)))
384 (number (cdr (assoc "number" ctype)))
385 (total (cdr (assoc "total" ctype)))
386 (the-buf (current-buffer))
388 (if (not (file-exists-p root-dir))
389 (shell-command (concat "mkdir " root-dir))
391 (setq id (replace-as-filename id))
392 (setq root-dir (concat root-dir "/" id))
393 (if (not (file-exists-p root-dir))
394 (shell-command (concat "mkdir " root-dir))
396 (setq file (concat root-dir "/FULL"))
397 (if (not (file-exists-p file))
399 (re-search-forward "^$")
400 (goto-char (+ (match-end 0) 1))
401 (setq file (concat root-dir "/" number))
402 (write-region (point) (point-max) file)
403 (if (get-buffer "*MIME-temp*")
404 (kill-buffer "*MIME-temp*")
406 (switch-to-buffer "*MIME-temp*")
408 (max (string-to-int total))
412 (setq file (concat root-dir "/" (int-to-string i)))
413 (if (not (file-exists-p file))
415 (switch-to-buffer the-buf)
418 (insert-file-contents file)
419 (goto-char (point-max))
422 (write-file (concat root-dir "/FULL"))
423 (delete-other-windows)
424 (pop-to-buffer (current-buffer))
425 (goto-char (point-min))
426 (mime/show-message-mode the-buf)
430 (delete-other-windows)
432 (mime/show-message-mode the-buf)
436 (defun mime/decode-content-region (beg end)
440 (narrow-to-region beg end)
441 (outline-flag-region beg end ?\n)
443 (let ((ctl (mime/Content-Type)))
445 (let ((ctype (downcase (car ctl)))
446 (encoding (mime/Content-Transfer-Encoding "7bit"))
449 (cond ((string= ctype "message/partial")
450 (mime/decode-message/partial-region beg end ctl encoding)
452 (t (mime/start-external-method-region beg end
456 mime/default-showing-Content-Type-list))
457 (mime/hide-region beg end)
466 (defun mime/hide-region (beg end)
470 (search-forward "\n\n" nil t)
471 (setq beg (match-end 0))
472 (outline-flag-region beg end ?\^M)
475 (defun mime/hide-all ()
476 (let ((fl (mime/make-flat-content-list))
480 (setq c (mime/get-content-region (mime/get-point-content-number p)))
484 (narrow-to-region (car c)(nth 1 c))
486 (let ((ctl (mime/Content-Type)))
490 mime/default-showing-Content-Type-list)))
491 (mime/hide-region (car c)(nth 1 c))
497 ;;; @ MIME show message mode (major-mode)
499 (defun mime/show-message-mode (mother)
500 (kill-all-local-variables)
501 (make-variable-buffer-local 'mime/show-mode-old-window-configuration)
502 (setq mime/show-mode-old-window-configuration
503 (current-window-configuration))
504 (make-variable-buffer-local 'mime/mother-buffer)
505 (setq mime/mother-buffer mother)
506 (setq major-mode 'mime/show-message-mode)
507 (setq mode-name "MIME-View")
509 (run-hooks 'mime/show-message-mode-hook)
513 ;;; @ MIME view message mode (minor-mode)
516 (defun mime/view-mode ()
518 (make-local-variable 'mime/view-mode-old-local-map)
519 (let ((keymap (current-local-map)))
521 (setq keymap (make-sparse-keymap))
523 (setq mime/view-mode-old-local-map keymap)
524 (setq keymap (copy-keymap keymap))
526 (let ((buf (get-buffer mime/output-buffer-name)))
528 (let ((the-buf (current-buffer)))
529 (switch-to-buffer buf)
531 (switch-to-buffer the-buf)
533 (use-local-map keymap)
534 (define-key keymap "u" 'mime/up-content)
535 (define-key keymap "p" 'mime/previous-content)
536 (define-key keymap "n" 'mime/next-content)
537 (define-key keymap "v" 'mime/play-content)
538 (define-key keymap "e" 'mime/extract-content)
539 (define-key keymap "\C-c\C-p" 'mime/print-content)
540 (define-key keymap "\C-c\C-x" 'mime/exit-view-mode)
543 (search-forward "\n\n" nil t)
546 (defun mime/decode-content ()
548 (let ((cr (mime/get-content-region
549 (mime/get-point-content-number (point))))
553 (mime/decode-content-region (car cr)(nth 1 cr))
556 (defun mime/play-content ()
558 (let ((mime/body-decoding-mode "play"))
559 (mime/decode-content)
562 (defun mime/extract-content ()
564 (let ((mime/body-decoding-mode "extract"))
565 (mime/decode-content)
568 (defun mime/print-content ()
570 (let ((mime/body-decoding-mode "print"))
571 (mime/decode-content)
574 (defun mime/up-content ()
576 (let ((cn (mime/get-point-content-number (point)))
579 (and (setq r (assoc major-mode mime/go-to-top-node-method-alist))
582 (if (setq r (mime/get-content-region (butlast cn)))
587 (defun mime/previous-content ()
589 (let* ((fcl (mime/make-flat-content-list))
591 (i (- (length fcl) 1))
595 (if (> p (nth i fcl))
596 (throw 'tag (goto-char (nth i fcl)))
602 (defun mime/next-content ()
604 (let ((fcl (mime/make-flat-content-list))
610 (throw 'tag (goto-char (car fcl)))
616 (defun mime/exit-view-mode ()
618 (if (and (boundp 'mime/view-mode-old-local-map)
619 (keymapp mime/view-mode-old-local-map))
620 (use-local-map mime/view-mode-old-local-map)