2 ;;; A MIME viewer for GNU Emacs
4 ;;; by Morioka Tomohiko, 1994/07/13
22 (defconst mime/viewer-RCS-ID
23 "$Id: tm-view.el,v 5.12 1994/10/17 07:28:34 morioka Exp $")
25 (defconst mime/viewer-version (get-version-string mime/viewer-RCS-ID))
31 (defconst mime/tspecials "\000-\040()<>@,;:\\\"/[\093?.=")
32 (defconst mime/token-regexp
33 (concat "[^" mime/tspecials "]*"))
34 (defconst mime/content-type-subtype-regexp
35 (concat mime/token-regexp "/" mime/token-regexp))
36 (defconst mime/content-parameter-value-regexp
38 message/quoted-string-regexp
41 (defconst mime/output-buffer-name "*MIME-out*")
42 (defconst mime/decoding-buffer-name "*MIME-decoding*")
48 (defvar mime/content-decoding-condition
49 ;;(setq mime/content-decoding-condition
50 '(((type . "text/plain")
51 (method "tm-plain" nil 'file 'type 'encoding 'mode 'name))
52 ((type . "text/x-latex")
53 (method "tm-latex" nil 'file 'type 'encoding 'mode 'name))
54 ((type . "audio/basic")
55 (method "tm-au" nil 'file 'type 'encoding 'mode 'name))
57 (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
58 ((type . "image/jpeg")
59 (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
60 ((type . "image/tiff")
61 (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
62 ((type . "image/x-tiff")
63 (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
64 ((type . "image/x-xbm")
65 (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
66 ((type . "image/x-pic")
67 (method "tm-image" nil 'file 'type 'encoding 'mode 'name))
68 ((type . "video/mpeg")
69 (method "tm-mpeg" nil 'file 'type 'encoding 'mode 'name))
70 ((type . "application/octet-stream")
71 (method "tm-file" nil 'file 'type 'encoding 'mode 'name))
72 ;;((type . "message/external-body")
73 ;; (method "xterm" nil
74 ;; "-e" "showexternal"
75 ;; 'file '"access-type" '"name" '"site" '"directory"))
76 ((type . "message/partial")
77 (method . mime/decode-message/partial-region))
79 "-m" "tm" "-x" "-d" "-z" "-e" 'file)(mode . "play"))
82 (defvar mime/content-filter-alist nil)
84 (defvar mime/make-content-subject-function
86 (lambda (cid subj ctype)
88 (format "[%s %s (%s)]\n"
92 (format "%s" (+ num 1))
99 (defvar mime/make-content-header-filter
100 ;;(setq mime/make-content-header-filter
104 (delete-region (goto-char (point-min))
105 (or (and (re-search-forward "^$" nil t)
112 (defvar mime/default-showing-Content-Type-list
113 ;;(setq mime/default-showing-Content-Type-list
114 '("text/plain" "text/richtext" "text/enriched" "text/x-latex" nil))
116 (defvar mime/go-to-top-node-method-alist
117 ;;(setq mime/go-to-top-node-method-alist
118 '((gnus-article-mode . (lambda ()
119 (mime/exit-view-mode)
120 (delete-other-windows)
121 (gnus-article-show-summary)
123 (rmail-mode . (lambda ()
124 (mime/exit-view-mode)
126 (delete-other-windows)
128 (mh-show-mode . (lambda ()
129 (let ((win (get-buffer-window
130 mime/output-buffer-name))
132 (nth 2 (car mime/preview-flat-content-list)))
137 (mime/exit-view-mode)
139 (let ((name (buffer-name buf)))
140 (string-match "show-" name)
141 (substring name (match-end 0))
144 (mime/show-message-mode . (lambda ()
145 (set-window-configuration
146 mime/show-mode-old-window-configuration)
147 (let ((mother mime/mother-buffer))
150 mime/preview-flat-content-list)))
151 (mime/exit-view-mode)
152 (pop-to-buffer mother)
153 (goto-char (point-min))
158 (defvar mime/use-internal-decoder nil)
160 (defvar mime/body-decoding-mode "play" "MIME body decoding mode")
166 (defun mime/parse-contents ()
169 (goto-char (point-min))
170 (let* ((ctl (mime/Content-Type))
172 (boundary (assoc "boundary" (cdr ctl)))
175 (setq ctype (downcase ctype))
177 (search-forward "\n\n" nil t)
179 (let ((sep (concat "\n--"
181 (message/strip-quoted-string
185 (setq beg (match-end 0))
186 (search-forward (concat "\n--" boundary "--\n") nil t)
187 (setq end (match-beginning 0))
190 (narrow-to-region beg end)
191 (goto-char (point-min))
192 (search-forward (concat "--" boundary "\n") nil t)
193 (setq cb (match-end 0))
194 (while (search-forward sep nil t)
195 (setq ce (match-beginning 0))
196 (setq ncb (match-end 0))
199 (narrow-to-region cb ce)
200 (setq ret (mime/parse-contents))
202 (setq dest (nconc dest (list ret)))
203 (goto-char (nth 1 ret))
204 (search-forward (concat "--" boundary "\n") nil t)
205 (goto-char (setq cb (match-end 0)))
207 (setq ce (point-max))
210 (narrow-to-region cb ce)
211 (setq ret (mime/parse-contents))
213 (setq dest (append dest (list ret)))
215 (setq beg (point-min))
217 (search-forward (concat "\n--" boundary "--\n") nil t)
218 (setq end (match-beginning 0))
220 ((string= ctype "message/rfc822")
223 (narrow-to-region (match-end 0) (point-max))
224 (setq dest (list (mime/parse-contents)))
226 (setq beg (point-min))
227 (setq end (point-max))
229 (t (setq beg (point-min))
230 (setq end (point-max))
235 (defun mime/Content-Type ()
238 (if (and (re-search-forward "^Content-Type:[ \t]*" nil t)
242 (and (re-search-forward ".*\\(\n[ \t].*\\)*" nil t)
245 (goto-char (point-min))
246 (re-search-forward mime/content-type-subtype-regexp nil t)
250 (buffer-substring (match-beginning 0) (match-end 0))
252 dest attribute value)
253 (while (and (re-search-forward "[ \t\n]*;[ \t\n]*" nil t)
254 (re-search-forward mime/token-regexp nil t)
258 (buffer-substring (match-beginning 0) (match-end 0))
260 (if (and (re-search-forward "=[ \t\n]*" nil t)
261 (re-search-forward mime/content-parameter-value-regexp
266 (message/strip-quoted-string
267 (buffer-substring (match-beginning 0)
275 (defun mime/Content-Transfer-Encoding (&optional default-encoding)
278 (if (and (re-search-forward "^Content-Transfer-Encoding:[ \t]*" nil t)
279 (re-search-forward mime/token-regexp nil t)
281 (downcase (buffer-substring (match-beginning 0) (match-end 0)))
285 (defun mime/get-subject (param)
289 (or (and (setq ret (assoc "name" param))
290 (message/strip-quoted-string (cdr ret))
292 (and (setq ret (assoc "x-name" param))
293 (message/strip-quoted-string (cdr ret))
296 (narrow-to-region (point-min)
297 (or (and (search-forward "\n\n" nil t)
302 (message/get-field-body "Content-Description")
303 (message/get-field-body "Subject")
308 (defun mime/get-name (param)
309 (replace-as-filename (mime/get-subject param))
312 (defun mime/make-preview-buffer (&optional buf cl obuf)
313 (let ((the-buf (current-buffer)) fcl)
315 (setq buf (current-buffer))
316 (setq buf (get-buffer buf))
320 (switch-to-buffer buf)
321 (setq cl mime/content-list)
324 (setq obuf (concat "*Preview-" (buffer-name buf) "*"))
326 (setq fcl (mime/make-flat-content-list cl))
327 (if (get-buffer obuf)
329 (switch-to-buffer obuf)
332 (let ((r fcl) cell cid ctype beg end e nb ne subj dest str)
335 (setq beg (car cell))
336 (setq end (nth 1 cell))
337 (setq cid (mime/get-point-content-number beg cl))
338 (switch-to-buffer buf)
341 (narrow-to-region beg end)
343 (setq ctype (mime/Content-Type))
345 (if (not (member (car ctype)
346 mime/default-showing-Content-Type-list))
349 (search-forward "\n\n" nil t)
355 (if (> e (point-max))
358 (setq str (buffer-substring beg e))
359 (switch-to-buffer obuf)
365 (narrow-to-region nb ne)
366 (mime/decode-message-header)
367 (setq subj (mime/get-subject (cdr ctype)))
368 (let ((f (cdr (assoc (car ctype) mime/content-filter-alist))))
369 (if (and f (fboundp f))
372 (funcall mime/make-content-header-filter cid)
374 (funcall mime/make-content-subject-function cid subj ctype)
375 (setq ne (point-max))
376 (setq dest (nconc dest (list (list nb (- ne 1) buf beg end))))
381 (set-buffer-modified-p nil)
382 (setq buffer-read-only t)
383 (switch-to-buffer the-buf)
387 (defun mime/parse-message ()
389 (make-variable-buffer-local 'mime/content-list)
390 (setq mime/content-list (mime/parse-contents))
391 (let ((ret (mime/make-preview-buffer)))
392 (make-variable-buffer-local 'mime/preview-buffer)
393 (setq mime/preview-buffer (car ret))
396 ;;; @ content information
399 (defun mime/get-point-content-number (p &optional cl)
401 (setq cl mime/content-list)
407 (if (and (<= b p)(<= p e))
408 (or (let (co ret (sn 0))
412 (setq ret (mime/get-point-content-number p co))
413 (cond ((eq ret t) (throw 'tag (list sn)))
414 (ret (throw 'tag (cons sn ret)))
421 (defun mime/get-content-region (cn &optional cl)
423 (setq cl mime/content-list)
430 (let ((rcl (nth sn (nth 2 cl))))
432 (mime/get-content-region (cdr cn) rcl)
436 (defun mime/make-flat-content-list (&optional cl)
438 (setq cl mime/content-list)
440 (let ((dest (list cl))
444 (setq dest (append dest (mime/make-flat-content-list (car rcl))))
449 (defun mime/get-point-preview-content (p &optional fcl)
451 (setq fcl mime/preview-flat-content-list)
457 (if (and (<= (car cell) p)(<= p (nth 1 cell)))
469 (defun mime/base64-decode-region (beg end &optional buf filename)
470 (let ((the-buf (current-buffer)) ret)
472 (setq buf (get-buffer-create mime/decoding-buffer-name))
476 (switch-to-buffer buf)
478 (switch-to-buffer the-buf)
479 (narrow-to-region beg end)
480 (goto-char (point-min))
481 (while (re-search-forward
483 mime/Base64-encoded-text-regexp
485 (setq ret (mime/base64-decode-string
486 (buffer-substring (match-beginning 0)
489 (switch-to-buffer buf)
491 (switch-to-buffer the-buf)
495 (switch-to-buffer buf)
496 (let ((kanji-flag nil)
499 (if (featurep 'mule) *noconv*))
501 (write-file filename)
503 (switch-to-buffer the-buf)
507 (defun mime/make-method-args (cal format)
512 (let ((ret (cdr (assoc (eval arg) cal))))
520 (defun mime/start-external-method-region (beg end cal)
522 (if (< end (point-max))
527 (narrow-to-region beg e)
529 (let ((method (cdr (assoc 'method cal)))
530 (name (mime/get-name cal))
533 (let ((file (make-temp-name
534 (expand-file-name "TM" mime/tmp-dir)))
538 (search-forward "\n\n" nil t)
539 (setq b (match-end 0))
542 (write-region b e file)
544 'name (replace-as-filename name) cal))
545 (setq cal (put-alist 'file file cal))
548 mime/output-buffer-name (car method)
550 (mime/make-method-args cal (cdr (cdr method)))
552 (apply (function start-process) args)
553 (mime/show-output-buffer)
557 (defun mime/decode-message/partial-region (beg end cal)
559 (let* ((root-dir (expand-file-name
560 (concat "m-prts-" (user-login-name)) mime/tmp-dir))
561 (id (cdr (assoc "id" cal)))
562 (number (cdr (assoc "number" cal)))
563 (total (cdr (assoc "total" cal)))
564 (the-buf (current-buffer))
566 (mother mime/preview-buffer))
567 (if (not (file-exists-p root-dir))
568 (shell-command (concat "mkdir " root-dir))
570 (setq id (replace-as-filename id))
571 (setq root-dir (concat root-dir "/" id))
572 (if (not (file-exists-p root-dir))
573 (shell-command (concat "mkdir " root-dir))
575 (setq file (concat root-dir "/FULL"))
576 (if (not (file-exists-p file))
578 (re-search-forward "^$")
579 (goto-char (+ (match-end 0) 1))
580 (setq file (concat root-dir "/" number))
581 (write-region (point) (point-max) file)
582 (if (get-buffer "*MIME-temp*")
583 (kill-buffer "*MIME-temp*")
585 (switch-to-buffer "*MIME-temp*")
587 (max (string-to-int total))
591 (setq file (concat root-dir "/" (int-to-string i)))
592 (if (not (file-exists-p file))
594 (switch-to-buffer the-buf)
597 (insert-file-contents file)
598 (goto-char (point-max))
601 (delete-other-windows)
602 (write-file (concat root-dir "/FULL"))
603 (setq major-mode 'mime/show-message-mode)
604 (mime/viewer-mode mother)
605 (pop-to-buffer (current-buffer))
609 (delete-other-windows)
611 (setq major-mode 'mime/show-message-mode)
612 (mime/viewer-mode mother)
613 (pop-to-buffer (current-buffer))
617 (defun mime/get-content-decoding-alist (al)
618 (let ((r mime/content-decoding-condition) ret)
621 (if (setq ret (nth 1 (assoc-unify (car r) al)))
627 (defun mime/decode-content-region (beg end)
632 (narrow-to-region beg end)
634 (setq ctl (mime/Content-Type))
636 (setq encoding (mime/Content-Transfer-Encoding "7bit"))
639 (let ((ctype (downcase (car ctl))) method cal ret)
641 (setq cal (nconc (list (cons 'type ctype)
642 (cons 'encoding encoding)
645 (if mime/body-decoding-mode
647 (cons 'mode mime/body-decoding-mode)
650 (setq ret (mime/get-content-decoding-alist cal))
651 (setq method (cdr (assoc 'method ret)))
652 (cond ((and (symbolp method)
654 (funcall method beg end ret)
656 ((and (listp method)(stringp (car method)))
657 (mime/start-external-method-region beg end ret)
659 (t (mime/show-output-buffer
660 "No method are specified for %s\n" ctype)
665 (defun mime/show-output-buffer (&rest forms)
666 (let ((the-buf (current-buffer)))
667 (if (null (get-buffer-window mime/output-buffer-name))
668 (split-window-vertically (/ (* (window-height) 3) 4))
670 (pop-to-buffer mime/output-buffer-name)
671 (goto-char (point-max))
673 (insert (apply (function format) forms))
675 (pop-to-buffer the-buf)
680 ;;; @ MIME viewer mode
683 (defun mime/viewer-mode (&optional mother)
685 (let ((buf (get-buffer mime/output-buffer-name))
686 (the-buf (current-buffer))
690 (switch-to-buffer buf)
692 (switch-to-buffer the-buf)
694 (let ((ret (mime/parse-message))
696 (switch-to-buffer (car ret))
697 (setq major-mode 'mime/viewer-mode)
698 (setq mode-name "MIME-View")
700 (make-variable-buffer-local 'mime/viewer-original-major-mode)
701 (setq mime/viewer-original-major-mode
704 (make-variable-buffer-local
705 'mime/show-mode-old-window-configuration)
706 (setq mime/show-mode-old-window-configuration
707 (current-window-configuration))
708 (make-variable-buffer-local 'mime/mother-buffer)
709 (setq mime/mother-buffer mother)
710 'mime/show-message-mode)
712 (let ((keymap (current-local-map)))
714 (setq keymap (make-sparse-keymap))
715 (setq keymap (copy-keymap keymap))
717 (use-local-map keymap)
718 (define-key keymap "u" 'mime/up-content)
719 (define-key keymap "p" 'mime/previous-content)
720 (define-key keymap "n" 'mime/next-content)
721 (define-key keymap " " 'mime/scroll-up-content)
722 (define-key keymap "\M- " 'mime/scroll-down-content)
723 (define-key keymap "\177" 'mime/scroll-down-content)
724 (define-key keymap "\C-m" 'mime/next-line-content)
725 (define-key keymap "\C-\M-m" 'mime/previous-line-content)
726 (define-key keymap "v" 'mime/play-content)
727 (define-key keymap "e" 'mime/extract-content)
728 (define-key keymap "\C-c\C-p" 'mime/print-content)
729 (define-key keymap "\C-c\C-x" 'mime/exit-view-mode)
731 (make-variable-buffer-local 'mime/preview-flat-content-list)
732 (setq mime/preview-flat-content-list (nth 1 ret))
735 (let ((ce (nth 1 (car mime/preview-flat-content-list)))
737 (goto-char (point-min))
738 (search-forward "\n\n" nil t)
739 (setq e (match-end 0))
745 (defun mime/decode-content ()
747 (let ((pc (mime/get-point-preview-content (point))))
749 (let ((the-buf (current-buffer)))
750 (switch-to-buffer (nth 2 pc))
751 (mime/decode-content-region (nth 3 pc)(nth 4 pc))
752 (if (eq (current-buffer) (nth 2 pc))
753 (switch-to-buffer the-buf)
757 (defun mime/play-content ()
759 (let ((mime/body-decoding-mode "play"))
760 (mime/decode-content)
763 (defun mime/extract-content ()
765 (let ((mime/body-decoding-mode "extract"))
766 (mime/decode-content)
769 (defun mime/print-content ()
771 (let ((mime/body-decoding-mode "print"))
772 (mime/decode-content)
775 (defun mime/up-content ()
777 (let ((pc (mime/get-point-preview-content (point)))
778 (the-buf (current-buffer))
780 (switch-to-buffer (nth 2 pc))
781 (setq cn (mime/get-point-content-number (nth 3 pc)))
783 (if (setq r (assoc major-mode mime/go-to-top-node-method-alist))
785 (switch-to-buffer the-buf)
788 (setq r (mime/get-content-region (butlast cn)))
789 (switch-to-buffer the-buf)
791 (let ((rfcl mime/preview-flat-content-list) cell)
793 (setq cell (car rfcl))
794 (if (and (= (car r)(nth 3 cell))
795 (= (nth 1 r)(nth 4 cell))
798 (goto-char (nth 0 cell))
801 (setq rfcl (cdr rfcl))
805 (defun mime/previous-content ()
807 (let* ((fcl mime/preview-flat-content-list)
809 (i (- (length fcl) 1))
813 (if (> p (car (nth i fcl)))
814 (throw 'tag (goto-char (car (nth i fcl))))
820 (defun mime/next-content ()
822 (let ((fcl mime/preview-flat-content-list)
827 (if (< p (car (car fcl)))
828 (throw 'tag (goto-char (car (car fcl))))
834 (defun mime/scroll-up-content (&optional h)
837 (setq h (- (window-height) 1))
839 (let ((fcl mime/preview-flat-content-list)
842 (setq np (or (catch 'tag
844 (if (< p (car (car fcl)))
845 (throw 'tag (car (car fcl)))
855 (defun mime/scroll-down-content (&optional h)
858 (setq h (- (window-height) 1))
860 (let ((fcl mime/preview-flat-content-list)
863 (setq pp (or (let ((i (- (length fcl) 1)))
866 (if (> p (nth 1 (nth i fcl)))
867 (throw 'tag (nth 1 (nth i fcl)))
877 (defun mime/next-line-content ()
879 (mime/scroll-up-content 1)
882 (defun mime/previous-line-content ()
884 (mime/scroll-down-content 1)
887 (defun mime/exit-view-mode ()
889 (kill-buffer (current-buffer))
892 (fset 'mime/view-mode 'mime/viewer-mode)
894 (run-hooks 'tm-view-load-hook)