From 137966958dfb743089532a2cd91ed113f56b5f8f Mon Sep 17 00:00:00 2001 From: morioka Date: Mon, 2 Mar 1998 13:43:01 +0000 Subject: [PATCH] tm 5.0. --- Makefile | 4 +- tl-list.el | 84 ++++++- tl-str.el | 38 +++- tm-comp-jp.pln | 62 ++++++ tm-comp.el | 21 +- tm-gnus3.el | 4 +- tm-gnus4.el | 6 +- tm-jp.tex | 617 ++++++++++++++++++++++++++++++++++++++++++++++++++++ tm-mh-e.el | 6 +- tm-rich.el | 78 +++++++ tm-rmail.el | 16 +- tm-view.el | 665 ++++++++++++++++++++++++++++++++++++-------------------- 12 files changed, 1339 insertions(+), 262 deletions(-) create mode 100644 tm-comp-jp.pln create mode 100644 tm-jp.tex create mode 100644 tm-rich.el diff --git a/Makefile b/Makefile index 3a091fb..c737801 100644 --- a/Makefile +++ b/Makefile @@ -12,9 +12,9 @@ PSFILES = tm-jp.ps \ tiny-mime-jp.ps signature-jp.ps tiny-mime-eng.ps GOMI = *.aux *.toc *.log $(TEXFILES) $(DVIFILES) *.ps $(UTILS) -FILES = *.ol Makefile *.el *.c methods $(TEXFILES) +FILES = *.ol *.pln Makefile *.el *.c methods tm-jp.tex $(TEXFILES) -TARFILE = tm4.8.4.tar +TARFILE = tm5.tar .SUFFIXES: .ol .tex .dvi .ps diff --git a/tl-list.el b/tl-list.el index 6b0d85d..5353029 100644 --- a/tl-list.el +++ b/tl-list.el @@ -1,5 +1,5 @@ ;;; -;;; $Id: tl-list.el,v 0.6 1994/08/28 17:10:12 morioka Exp $ +;;; $Id: tl-list.el,v 1.0 1994/09/15 20:42:29 morioka Exp $ ;;; (provide 'tl-list) @@ -73,3 +73,85 @@ return new alist whose car is the new pair and cdr is . (fset 'put-field 'put-alist) (fset 'delete-field 'del-alist) + + +;;; @ field unifier +;;; + +(defun field-unifier-for-default (a b) + (let ((ret + (cond ((equal a b) a) + ((null (cdr b)) a) + ((null (cdr a)) b) + ))) + (if ret + (list nil ret nil) + ))) + +(defun field-unify (a b) + (let ((sym (symbol-concat "field-unifier-for-" (car a)))) + (if (not (fboundp sym)) + (setq sym (function field-unifier-for-default)) + ) + (funcall sym a b) + )) + + +;;; @ type unifier +;;; + +(defun assoc-unify (class instance) + (catch 'tag + (let ((cla (copy-alist class)) + (ins (copy-alist instance)) + (r class) + cell aret ret prev rest) + (while r + (setq cell (car r)) + (setq aret (fetch-field (car cell) ins)) + (if aret + (if (setq ret (field-unify cell aret)) + (progn + (if (car ret) + (setq prev (put-field (car (car ret)) + (cdr (car ret)) + prev)) + ) + (if (nth 2 ret) + (setq rest (put-field (car (nth 2 ret)) + (cdr (nth 2 ret)) + rest)) + ) + (setq cla (put-field (car cell)(cdr (nth 1 ret)) cla)) + (setq ins (delete-field (car cell) ins)) + ) + (throw 'tag nil) + )) + (setq r (cdr r)) + ) + (setq r (copy-alist ins)) + (while r + (setq cell (car r)) + (setq aret (fetch-field (car cell) cla)) + (if aret + (if (setq ret (field-unify cell aret)) + (progn + (if (car ret) + (setq prev (put-field (car (car ret)) + (cdr (car ret)) + prev)) + ) + (if (nth 2 ret) + (setq rest (put-field (car (nth 2 ret)) + (cdr (nth 2 ret)) + rest)) + ) + (setq cla (delete-field (car cell) cla)) + (setq ins (put-field (car cell)(cdr (nth 1 ret)) ins)) + ) + (throw 'tag nil) + )) + (setq r (cdr r)) + ) + (list prev (append cla ins) rest) + ))) diff --git a/tl-str.el b/tl-str.el index 55ed49c..3d55598 100644 --- a/tl-str.el +++ b/tl-str.el @@ -1,5 +1,5 @@ ;;; -;;; $Id: tl-str.el,v 1.4 1994/09/01 06:02:25 morioka Exp morioka $ +;;; $Id: tl-str.el,v 1.7 1994/09/25 21:33:52 morioka Exp $ ;;; (provide 'tl-str) @@ -17,6 +17,7 @@ (goto-char (point-min)) (let* ((fill-prefix (and (re-search-forward "^[^ \t>]*[>|]+[ \t#]*" nil t) + (re-search-forward "^[^ \t>]*[>|]+[ \t#]*" nil t) (buffer-substring (match-beginning 0) (match-end 0) ))) @@ -62,3 +63,38 @@ (setq i (+ i 1)) ) dest)) + +(defun symbol-concat (a b) + (intern (concat + (cond ((symbolp a) + (symbol-name a) + ) + ((stringp a) a) + ) + (cond ((symbolp b) + (symbol-name b) + ) + ((stringp b) b) + )))) + +(defun top-string-match (pat str) + (if (string-match + (concat "^" (regexp-quote pat)) + str) + (list pat (substring str (match-end 0))) + )) + +(defun middle-string-match (pat str) + (if (equal pat str) + (list nil pat nil) + (if (string-match (regexp-quote pat) str) + (let ((b (match-beginning 0)) + (e (match-end 0)) ) + (list (if (not (= b 0)) + (substring str 0 b) + ) + pat + (if (> (length str) e) + (substring str e) + ) + ))))) diff --git a/tm-comp-jp.pln b/tm-comp-jp.pln new file mode 100644 index 0000000..e5d1457 --- /dev/null +++ b/tm-comp-jp.pln @@ -0,0 +1,62 @@ +$B2,It!w5~Bg$G$9!#(B + +In article <199408221831.DAA24174@melon.jaist.ac.jp>, + $B writes: + +$B $B8= $B7A<0$KJ,3d$7$F$/$l$k$b$N$r=q$-$^$7$?!#(B + +$BJXMx$J$N$G!"$9$3$72~NI(B($B2~0-!)(B)$B$7$F$_$^$7$?!#(B + +1. mime-mode-exit $B$r>r7oIU$-$G8F$V$h$&$K$7!"(Bmime-mode $B0J30$G$b(B + $B;H$($k$h$&$K$7$?!#(B + + $B:G6a(B mh-e 4.1 $B$N(B mh-edit-mhn $B$b;H$C$F$_$F$$$k$N$G!"(Bmime-mode $B0J30$G$b(B + $B;H$($k$h$&$K$7$?$H$$$&$N$,F05!$G$9!#6KC<$K8@$($PIaCJ$O(B MIME $B$rA4A3;H$C$F(B + $B$$$J$$?M$G$b!"<+F0J,3d$K$O;H$($k$H;W$$$^$9!#(B + +$B!t(B mh-edit-mhn $B$GJQ49$7$?8e(B mime/view-mode $B$KF~$C$F%W%l%S%e!<$7!"(B + $B$&$^$/$$$C$F$J$+$C$?$i(B mh-revert-mhn-edit $B$G$d$jD>$9!"$H$$$&(B + $Bl9g$K$bBP1~$7$?!#(B + + mh-edit-mhn $B$N=PNO$O$3$N7A<0$J$N$G!"$d$`$rF@$:$=$&$7$^$7$?!#(B + +3. mime/draft-file-name $B$,(B nil $B$N$H$-$K;H$&%U%!%$%kL>$r0J2<$N$h$&$K$7$?!#(B + + (make-temp-name (expand-file-name "tm-draft" mime/tmp-dir)) + +4. $BJ,3d$7$?%a%C%;!<%8$K$O!"$b$H$N(B Subject $B$N$&$7$m$K(B (1/3) $B$J$I$H$D$/(B + $B$h$&$K$7$?!#(B + + $B6a$$>-Mh!"(Bsuper-pipe $B$d(B gnus-uu $B$N$h$&$K!"(Bmessage/partial $B$N$H$-$O$I(B + $B$l$+$R$H$D$N5-;v$r$_$l$PB>$N$rC5$7$K9T$/5!G=$,(B tm-view.el $B$Kl9g!"(BBcc:, Dcc: Fcc: $B$J$IK\MhAw$C$?;~$K>C$($k(B + $B$O$:$N$b$N$,FO$$$F$7$^$&(B($B$H$/$K(B Bcc: $B$,8+$($k$N$OLdBj(B)$B!#(B + $B1#$9%U%#!<%k%I$r;XDj$G$-$k$h$&$K$9$Y$-!#(B + +2. $B@8@.$5$l$k(B id $B$,D9$C$?$i$7$/$F$+$C$30-$$!#(B + ($BNc$($P(B GNUS $B$N(B message-id $B@8@.%k!<%A%s$rE>MQ$7$F$O$I$&$+(B) + +$B$J$I$,$"$j$^$9!#(B + +$B $B$^$?!"(Bmessage $B$N:GBg9T?t$rJQ?t(B mime/message-max-length $B$G;XDj$G$-$^(B +$B $B$9!#$H$j$"$($:!"(Bdefault $B$G$O(B 1000 $B9T$K$7$F$"$j$^$9$,!"$3$l$K4X$9$k0lHL(B +$B $BE*$JCM$O$"$k$s$G$7$g$&$+!)(B + +$B9T?t$h$j$O%P%$%H?t$,Bg;v$J$O$:$G!"$h$/8@$o$l$k$N$O(B1$BDL$"$?$j(B50KB$B$rD6$((B +$B$J$$$h$&$K$H$$$&@)Ls$G$9$M(B($B$&$A$N%;%s%?!<$NMxMQ$NAw$G!"Cf?H$O(B base64 +$B$G0l9T(B80$B;zDj$9$k$H!"(B600 $B9T6/$K$"$?$j$^$9!#$7$+$7(B50KB +$B0J>e$N$b$N$ODL$i$J$$$h$&$K$J$C$F$$$k$H$$$&$o$1$G$O$J$/C1$K0BA4$d8zN($r(B +$B9M$($F$NCM$G$7$g$&$+$i!"(Bsplit $B$NI8=`CM$G$b$"$k(B 1000 $B$GLdBj$J$$$H;W$$$^$9!#(B +----- +$B2,It$ ¤Ë mail ¤òÁ÷¤Ã¤Æ²¼¤µ¤¤¡£ + +tm ML ¤Ç¤Ï tm ¤Î¥Ð¥°¾ðÊó¤Î¸ò´¹¤äºÇ¿·ÈǤÎÇÛÉÛ¡¢tm ¤Î²þÎɤ˴ؤ¹¤ëµÄÏÀ¤ò +¹Ô¤Ê¤Ã¤Æ¤¤¤Þ¤¹¡£tm ML ¤Ë»²²Ã¤·¤¿¤¤Êý¤Ï + +\begin{center} + tm-admin@chamonix.jaist.ac.jp +\end{center} + +\noindent ¤Þ¤Ç mail ¤òÁ÷¤Ã¤Æ²¼¤µ¤¤¡£ÅÐÏ¿¤Ï¼êÆ°¤Ç¤¹¤Î¤Ç¡¢¤Ç¤­¤ì¤Ð¡¢¼«Á³ +¸À¸ì¤Ç½ñ¤¤¤Æ²¼¤µ¤¤¡£(\verb+^+\_\verb+^+) + +\end{document} diff --git a/tm-mh-e.el b/tm-mh-e.el index b503f24..96210e3 100644 --- a/tm-mh-e.el +++ b/tm-mh-e.el @@ -9,7 +9,7 @@ ;;; @ version ;;; (defconst tm-mh-e/RCS-ID - "$Id: tm-mh-e.el,v 3.1 1994/08/31 05:32:24 morioka Exp $") + "$Id: tm-mh-e.el,v 5.0 1994/09/25 21:28:29 morioka Exp $") (defconst tm-mh-e/version (and (string-match "[0-9][0-9.]*" tm-mh-e/RCS-ID) @@ -24,7 +24,7 @@ (if (not (boundp 'mh-e-version)) (require 'tm-mh-e3) ) -(autoload 'mime/view-mode "tm-view" "View MIME message." t) +(autoload 'mime/viewer-mode "tm-view" "View MIME message." t) ;;; @ MIME header decoding mode @@ -50,7 +50,7 @@ With arg, turn MIME processing on if arg is positive." (mh-invalidate-show-buffer) (mh-show-msg (mh-get-msg-num t)) (pop-to-buffer mh-show-buffer t) - (mime/view-mode) + (mime/viewer-mode) ) diff --git a/tm-rich.el b/tm-rich.el new file mode 100644 index 0000000..33246d7 --- /dev/null +++ b/tm-rich.el @@ -0,0 +1,78 @@ +;;; +;;; $Id: tm-rich.el,v 1.1 1994/09/05 14:34:06 morioka Exp morioka $ +;;; + +(provide 'tm-rich) + +(require 'tm-view) +(require 'assoc) +(require 'hilit19) + + +(defun mime/get-text/enriched-face (str) + (let ((sym (intern str))) + (if (eq sym 'italic) + 'modeline + sym))) + +(defun mime/decode-text/enriched-region (beg end) + (interactive "*r") + (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char beg) + (let (cmd sym (fb (point)) fe b e) + (while (re-search-forward + "[ \t\n\r]*<[^<>\n\r \t]+>[ \t\n\r]*" nil t) + (setq cmd (buffer-substring (match-beginning 0) (match-end 0))) + (replace-match "") + (string-match "^[ \t\n\r]*<" cmd) + (setq cmd (substring cmd (match-end 0))) + (string-match ">[ \t\n\r]*$" cmd) + (setq cmd (substring cmd 0 (match-beginning 0))) + (setq sym (mime/get-text/enriched-face cmd)) + (cond ((string= cmd "nl") + (fill-region fb (point) t) + (insert "\n") + (setq fb (point)) + ) + ((member sym (face-list)) + (if (not (bolp)) + (insert " ") + ) + (setq b (point)) + (save-excursion + (save-restriction + (if (re-search-forward (concat "[ \t\n\r]*[ \t\n\r]*") + nil t) + (progn + (replace-match " ") + (setq e (- (point) 1)) + ) + (setq e end) + ))) + (hilit-unhighlight-region b e) + (hilit-region-set-face b e sym) + ))) + (fill-region fb (point) t) + )))) + +(defun mime/decode-text/enriched-body () + (interactive) + (save-excursion + (save-restriction + (let ((beg (point-min)) (end (point-max))) + (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (setq beg (match-end 0)) + ) + (mime/decode-text/enriched-region beg end) + )))) + + +(aput 'mime/content-filter-alist + "text/enriched" (function mime/decode-text/enriched-body)) + +(aput 'mime/content-filter-alist + "text/richtext" (function mime/decode-text/enriched-body)) diff --git a/tm-rmail.el b/tm-rmail.el index b995236..49aaf83 100644 --- a/tm-rmail.el +++ b/tm-rmail.el @@ -1,5 +1,5 @@ ;;; -;;; $Id: tm-rmail.el,v 3.1 1994/08/31 05:37:24 morioka Exp $ +;;; $Id: tm-rmail.el,v 5.0 1994/09/25 21:26:05 morioka Exp $ ;;; (provide 'tm-rmail) @@ -7,17 +7,17 @@ (if (< (string-to-int emacs-version) 19) (require 'tl-18) ) -(autoload 'mime/view-mode "tm-view" "View MIME message." t) +(autoload 'mime/viewer-mode "tm-view" "View MIME message." t) (autoload 'mime/decode-message-header "tiny-mime" "Decode MIME header." t) (add-hook 'rmail-show-message-hook (function (lambda () - (let ((buffer-read-only nil)) + (let ((mf (buffer-modified-p)) + (buffer-read-only nil)) (mime/decode-message-header) - ) - (set-buffer-modified-p nil) - ))) + (set-buffer-modified-p mf) + )))) (add-hook 'rmail-mode-hook (function @@ -32,7 +32,7 @@ (function (lambda () (interactive) - (pop-to-buffer "RMAIL") - (mime/view-mode) + (pop-to-buffer rmail-buffer) + (mime/viewer-mode) ))) ))) diff --git a/tm-view.el b/tm-view.el index 4343565..4541cbb 100644 --- a/tm-view.el +++ b/tm-view.el @@ -10,7 +10,7 @@ ;;; (defconst mime/viewer-RCS-ID - "$Id: tm-view.el,v 3.8 1994/09/02 10:32:31 morioka Exp $") + "$Id: tm-view.el,v 5.1 1994/09/25 21:23:07 morioka Exp $") (defconst mime/viewer-version (and (string-match "[0-9][0-9.]*" mime/viewer-RCS-ID) @@ -21,7 +21,6 @@ ;;; @ require modules ;;; -(require 'outline) (require 'tl-str) (require 'tl-list) (require 'tl-header) @@ -48,25 +47,79 @@ ;;; @ variables ;;; -(defvar mime/content-decoding-method-alist - '(("text/plain" . "tm-plain") - ("text/x-latex" . "tm-latex") - ("audio/basic" . "tm-au") - ("image/gif" . "tm-image") - ("image/jpeg" . "tm-image") - ("image/tiff" . "tm-image") - ("image/x-tiff" . "tm-image") - ("image/x-xbm" . "tm-image") - ("image/x-pic" . "tm-image") - ("video/mpeg" . "tm-mpeg") - ("application/octet-stream" . "tm-file") +(defvar mime/content-decoding-condition +;;(setq mime/content-decoding-condition + '(((type . "text/plain") + (method "tm-plain" nil 'file 'type 'encoding 'mode 'name)) + ((type . "text/x-latex") + (method "tm-latex" nil 'file 'type 'encoding 'mode 'name)) + ((type . "audio/basic") + (method "tm-au" nil 'file 'type 'encoding 'mode 'name)) + ((type . "image/gif") + (method "tm-image" nil 'file 'type 'encoding 'mode 'name)) + ((type . "image/jpeg") + (method "tm-image" nil 'file 'type 'encoding 'mode 'name)) + ((type . "image/tiff") + (method "tm-image" nil 'file 'type 'encoding 'mode 'name)) + ((type . "image/x-tiff") + (method "tm-image" nil 'file 'type 'encoding 'mode 'name)) + ((type . "image/x-xbm") + (method "tm-image" nil 'file 'type 'encoding 'mode 'name)) + ((type . "image/x-pic") + (method "tm-image" nil 'file 'type 'encoding 'mode 'name)) + ((type . "video/mpeg") + (method "tm-mpeg" nil 'file 'type 'encoding 'mode 'name)) + ((type . "application/octet-stream") + (method "tm-file" nil 'file 'type 'encoding 'mode 'name)) + ;;((type . "message/external-body") + ;; (method "xterm" nil + ;; "-e" "showexternal" + ;; 'file '"access-type" '"name" '"site" '"directory")) + ((type . "message/partial") + (method . mime/decode-message/partial-region)) + ((method "metamail" t + "-m" "tm" "-x" "-d" "-z" "-e" 'file)(mode . "play")) )) +(defvar mime/content-filter-alist nil) + +(defvar mime/make-content-subject-function + (function + (lambda (cid subj ctype) + (insert + (format "[%s %s (%s)]\n" + (if (listp cid) + (mapconcat (function + (lambda (num) + (format "%s" (+ num 1)) + )) + cid ".") + "0") + subj (car ctype))) + ))) + +(defvar mime/make-content-header-filter + (function + (lambda (cid) + (if (listp cid) + (delete-region (goto-char (point-min)) + (or (and (search-forward "\n\n" nil t) + (match-beginning 0)) + (point-max)) + ) + ) + ))) + (defvar mime/default-showing-Content-Type-list - '("text/plain" "text/x-latex" "message/rfc822")) +;;(setq mime/default-showing-Content-Type-list + '("text/plain" "text/richtext" "text/enriched" + "text/x-latex" "message/rfc822" nil)) (defvar mime/go-to-top-node-method-alist +;;(setq mime/go-to-top-node-method-alist '((gnus-article-mode . (lambda () + (mime/exit-view-mode) + (delete-other-windows) (gnus-article-show-summary) )) (rmail-mode . (lambda () @@ -75,25 +128,37 @@ (delete-other-windows) )) (mh-show-mode . (lambda () - (pop-to-buffer - (let ((name (buffer-name))) - (string-match "show-" name) - (substring name (match-end 0)) - )) - )) + (let ((win (get-buffer-window + mime/output-buffer-name)) + (buf + (nth 2 (car mime/preview-flat-content-list))) + ) + (if win + (delete-window win) + ) + (mime/exit-view-mode) + (pop-to-buffer + (let ((name (buffer-name buf))) + (string-match "show-" name) + (substring name (match-end 0)) + )) + ))) (mime/show-message-mode . (lambda () (set-window-configuration mime/show-mode-old-window-configuration) - (let ((buf (current-buffer))) - (pop-to-buffer mime/mother-buffer) - (kill-buffer buf) + (let ((mother mime/mother-buffer)) + (kill-buffer + (nth 2 (car + mime/preview-flat-content-list))) + (mime/exit-view-mode) + (pop-to-buffer mother) + (goto-char (point-min)) + (mime/up-content) ))) )) (defvar mime/tmp-dir "/tmp/") -(defvar mime/hide-content-header nil) - (defvar mime/use-internal-decoder nil) (defvar mime/body-decoding-mode "play" "MIME body decoding mode") @@ -102,14 +167,17 @@ ;;; @ parser ;;; -(defun mime/parse-content () +(defun mime/parse-contents () (save-excursion (save-restriction - (mime/decode-message-header) (goto-char (point-min)) (let* ((ctl (mime/Content-Type)) + (ctype (car ctl)) (boundary (assoc "boundary" (cdr ctl))) beg end dest) + (if (stringp ctype) + (setq ctype (downcase ctype)) + ) (search-forward "\n\n" nil t) (cond (boundary (let ((sep (concat "\n--" @@ -133,9 +201,9 @@ (save-excursion (save-restriction (narrow-to-region cb ce) - (setq ret (mime/parse-content)) + (setq ret (mime/parse-contents)) )) - (setq dest (append dest (list ret))) + (setq dest (nconc dest (list ret))) (goto-char (nth 1 ret)) (search-forward (concat "--" boundary "\n") nil t) (goto-char (setq cb (match-end 0))) @@ -144,7 +212,7 @@ (save-excursion (save-restriction (narrow-to-region cb ce) - (setq ret (mime/parse-content)) + (setq ret (mime/parse-contents)) )) (setq dest (append dest (list ret))) )) @@ -153,19 +221,18 @@ (search-forward (concat "\n--" boundary "--\n") nil t) (setq end (match-beginning 0)) )) - ((string= (car ctl) "message/rfc822") + ((string= ctype "message/rfc822") (save-excursion (save-restriction (narrow-to-region (match-end 0) (point-max)) - (setq dest (list (mime/parse-content))) + (setq dest (list (mime/parse-contents))) )) (setq beg (point-min)) (setq end (point-max)) ) - (t - (setq beg (point-min)) - (setq end (point-max)) - )) + (t (setq beg (point-min)) + (setq end (point-max)) + )) (list beg end dest) )))) @@ -200,8 +267,9 @@ ) (setq dest (put-alist attribute - (buffer-substring (match-beginning 0) - (match-end 0)) + (message/strip-quoted-string + (buffer-substring (match-beginning 0) + (match-end 0))) dest)) ) ) @@ -218,34 +286,102 @@ default-encoding) ))) -(defun mime/get-name (ctype) +(defun mime/get-subject (param) (save-excursion (save-restriction - (replace-as-filename - (let (ret) - (or (and (setq ret (assoc "name" ctype)) - (message/strip-quoted-string (cdr ret)) - ) - (and (setq ret (assoc "x-name" ctype)) - (message/strip-quoted-string (cdr ret)) - ) - (message/get-field-body "Content-Description") - "")) - )))) + (let (ret) + (or (and (setq ret (assoc "name" param)) + (message/strip-quoted-string (cdr ret)) + ) + (and (setq ret (assoc "x-name" param)) + (message/strip-quoted-string (cdr ret)) + ) + (message/get-field-body "Content-Description") + (message/get-field-body "Subject") + "")) + ))) -(defun mime/parse-message () - (interactive) - (save-excursion - (save-restriction - (setq selective-display t) - (make-variable-buffer-local 'mime/content-list) - (let ((buffer-read-only nil)) - (setq mime/content-list (mime/parse-content)) +(defun mime/get-name (param) + (replace-as-filename (mime/get-subject param)) + ) + +(defun mime/make-preview-buffer (&optional buf cl obuf) + (let ((the-buf (current-buffer)) fcl) + (if (null buf) + (setq buf (current-buffer)) + (setq buf (get-buffer buf)) + ) + (if (null cl) + (progn + (switch-to-buffer buf) + (setq cl mime/content-list) + )) + (if (null obuf) + (setq obuf (concat "*Preview-" (buffer-name buf) "*")) + ) + (setq fcl (mime/make-flat-content-list cl)) + (if (get-buffer obuf) + (progn + (switch-to-buffer obuf) + (erase-buffer) + )) + (let ((r fcl) cell cid ctype beg end e nb ne subj dest) + (while r + (setq cell (car r)) + (setq beg (car cell)) + (setq end (nth 1 cell)) + (setq cid (mime/get-point-content-number beg cl)) + (switch-to-buffer buf) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char beg) + (setq ctype (mime/Content-Type)) + (setq e + (if (not (member (car ctype) + mime/default-showing-Content-Type-list)) + (progn + (goto-char beg) + (search-forward "\n\n" nil t) + (match-end 0) + ) + end)) + )) + (setq str (buffer-substring beg e)) + (switch-to-buffer obuf) + (setq nb (point)) + (insert str) + (setq ne (- (point) 1)) + (save-excursion + (save-restriction + (narrow-to-region nb ne) + (mime/decode-message-header) + (setq subj (mime/get-subject (cdr ctype))) + (let ((f (cdr (assoc (car ctype) mime/content-filter-alist)))) + (if (and f (fboundp f)) + (funcall f) + )) + (funcall mime/make-content-header-filter cid) + (goto-char nb) + (funcall mime/make-content-subject-function cid subj ctype) + (setq ne (point-max)) + (setq dest (nconc dest (list (list nb ne buf beg end)))) + )) + (setq r (cdr r)) ) - (mime/hide-all) (set-buffer-modified-p nil) + (switch-to-buffer the-buf) + (list obuf dest) ))) +(defun mime/parse-message () + (interactive) + (make-variable-buffer-local 'mime/content-list) + (setq mime/content-list (mime/parse-contents)) + (let ((ret (mime/make-preview-buffer))) + (make-variable-buffer-local 'mime/preview-buffer) + (setq mime/preview-buffer (car ret)) + ret)) ;;; @ content information ;;; @@ -300,6 +436,22 @@ ) dest)) +(defun mime/get-point-preview-content (p &optional fcl) + (if (null fcl) + (setq fcl mime/preview-flat-content-list) + ) + (catch 'tag + (let ((r fcl) cell) + (while r + (setq cell (car r)) + (if (and (<= (car cell) p)(<= p (nth 1 cell))) + (throw 'tag cell) + ) + (setq r (cdr r)) + )) + (car (last fcl)) + )) + ;;; @ decoder ;;; @@ -342,51 +494,66 @@ ))) )) -(defun mime/start-external-method-region (beg end ctype ctl encoding) - (goto-char beg) - (let ((method (cdr (assoc ctype mime/content-decoding-method-alist))) - (name (mime/get-name ctl)) - ) - (if method - (progn - (search-forward "\n\n" nil t) - (let ((file (make-temp-name - (expand-file-name "TM" mime/tmp-dir))) - (b (match-end 0)) - (e end)) - (goto-char b) - (if (and (string= encoding "base64") - mime/use-internal-decoder) - (progn - (mime/base64-decode-region b e nil file) - (setq encoding "binary") - ) - (write-region b e file) +(defun mime/make-method-args (cal format) + (mapcar (function + (lambda (arg) + (if (stringp arg) + arg + (let ((ret (cdr (assoc (eval arg) cal)))) + (if ret + ret + "") + )) + )) + format)) + +(defun mime/start-external-method-region (beg end cal) + (let ((e end)) + (if (< end (point-max)) + (setq e (+ end 1)) + ) + (save-excursion + (save-restriction + (narrow-to-region beg e) + (goto-char beg) + (let ((method (cdr (assoc 'method cal))) + (name (mime/get-name cal)) ) - (start-process method mime/output-buffer-name method file - ctype encoding - (if mime/body-decoding-mode - mime/body-decoding-mode - "play") - (replace-as-filename name) - ) - (if (null (get-buffer-window mime/output-buffer-name)) - (let ((the-buf (current-buffer))) - (split-window-vertically (/ (* (window-height) 3) 4)) - (pop-to-buffer mime/output-buffer-name) - (pop-to-buffer the-buf) - )) - ))))) + (if method + (let ((file (make-temp-name + (expand-file-name "TM" mime/tmp-dir))) + b args) + (if (nth 1 method) + (setq b beg) + (search-forward "\n\n" nil t) + (setq b (match-end 0)) + ) + (goto-char b) + (write-region b e file) + (setq cal (put-alist + 'name (replace-as-filename name) cal)) + (setq cal (put-alist 'file file cal)) + (setq args (nconc + (list (car method) + mime/output-buffer-name (car method) + ) + (mime/make-method-args cal (cdr (cdr method))) + )) + (apply (function start-process) args) + (mime/show-output-buffer) + )))))) + ) -(defun mime/decode-message/partial-region (beg end ctype default-encoding) +(defun mime/decode-message/partial-region (beg end cal) (goto-char beg) - (let ((root-dir (expand-file-name - (concat "m-prts-" (user-login-name)) mime/tmp-dir)) - (id (cdr (assoc "id" ctype))) - (number (cdr (assoc "number" ctype))) - (total (cdr (assoc "total" ctype))) - (the-buf (current-buffer)) - file) + (let* ((root-dir (expand-file-name + (concat "m-prts-" (user-login-name)) mime/tmp-dir)) + (id (cdr (assoc "id" cal))) + (number (cdr (assoc "number" cal))) + (total (cdr (assoc "total" cal))) + (the-buf (current-buffer)) + file + (mother mime/preview-buffer)) (if (not (file-exists-p root-dir)) (shell-command (concat "mkdir " root-dir)) ) @@ -421,150 +588,158 @@ (goto-char (point-max)) (setq i (+ i 1)) ) - (write-file (concat root-dir "/FULL")) (delete-other-windows) + (write-file (concat root-dir "/FULL")) + (setq major-mode 'mime/show-message-mode) + (mime/viewer-mode mother) (pop-to-buffer (current-buffer)) - (goto-char (point-min)) - (mime/show-message-mode the-buf) )) ) (progn (delete-other-windows) (find-file file) - (mime/show-message-mode the-buf) + (setq major-mode 'mime/show-message-mode) + (mime/viewer-mode mother) + (pop-to-buffer (current-buffer)) )) )) -(defun mime/decode-content-region (beg end) - (interactive "*r") - (save-excursion - (save-restriction - (outline-flag-region beg end ?\n) - (let ((e end)) - (if (< end (point-max)) - (setq e (+ end 1)) +(defun mime/get-content-decoding-alist (al) + (let ((r mime/content-decoding-condition) ret) + (catch 'tag + (while r + (if (setq ret (nth 1 (assoc-unify (car r) al))) + (throw 'tag ret) ) - (narrow-to-region beg e) - (goto-char beg) - (let ((ctl (mime/Content-Type))) - (if ctl - (let ((ctype (downcase (car ctl))) - (encoding (mime/Content-Transfer-Encoding "7bit")) - ) - (setq ctl (cdr ctl)) - (cond ((string= ctype "message/partial") - (mime/decode-message/partial-region beg e - ctl encoding) - ) - (t (mime/start-external-method-region beg e - ctype ctl encoding) - (if (not (member - ctype - mime/default-showing-Content-Type-list)) - (mime/hide-region beg end) - ) - )) - )))) - ))) - - -;;; @ hide -;;; - -(defun mime/hide-region (beg end) - (save-excursion - (save-restriction - (goto-char beg) - (if (not mime/hide-content-header) - (progn - (search-forward "\n\n" nil t) - (setq beg (match-end 0)) - )) - (outline-flag-region beg end ?\^M) - ))) + (setq r (cdr r)) + )))) -(defun mime/hide-all () - (let ((fl (mime/make-flat-content-list)) - p c) - (while fl - (setq p (car (car fl))) - (setq c (mime/get-content-region (mime/get-point-content-number p))) - (if (null (nth 2 c)) - (save-excursion - (save-restriction - (narrow-to-region (car c)(nth 1 c)) - (goto-char (car c)) - (let ((ctl (mime/Content-Type))) - (if (and ctl - (not (member - (car ctl) - mime/default-showing-Content-Type-list))) - (mime/hide-region (car c)(nth 1 c)) - ))))) - (setq fl (cdr fl)) - ))) +(defun mime/decode-content-region (beg end) + (interactive "*r") + (let (ctl encoding) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (and (goto-char beg) + (setq ctl (mime/Content-Type)) + (goto-char beg) + (setq encoding (mime/Content-Transfer-Encoding "7bit")) + ))) + (if ctl + (let ((ctype (downcase (car ctl))) method cal ret) + (setq ctl (cdr ctl)) + (setq cal (nconc (list (cons 'type ctype) + (cons 'encoding encoding) + ) + ctl)) + (if mime/body-decoding-mode + (setq cal (cons + (cons 'mode mime/body-decoding-mode) + cal)) + ) + (setq ret (mime/get-content-decoding-alist cal)) + (setq method (cdr (assoc 'method ret))) + (cond ((and (symbolp method) + (fboundp method)) + (funcall method beg end ret) + ) + ((and (listp method)(stringp (car method))) + (mime/start-external-method-region beg end ret) + ) + (t (mime/show-output-buffer + "No method are specified for %s\n" ctype) + )) + )) + )) +(defun mime/show-output-buffer (&rest forms) + (let ((the-buf (current-buffer))) + (if (null (get-buffer-window mime/output-buffer-name)) + (split-window-vertically (/ (* (window-height) 3) 4)) + ) + (pop-to-buffer mime/output-buffer-name) + (goto-char (point-max)) + (if forms + (insert (apply (function format) forms)) + ) + (pop-to-buffer the-buf) + )) -;;; @ MIME show message mode (major-mode) -;;; -(defun mime/show-message-mode (mother) - (kill-all-local-variables) - (make-variable-buffer-local 'mime/show-mode-old-window-configuration) - (setq mime/show-mode-old-window-configuration - (current-window-configuration)) - (make-variable-buffer-local 'mime/mother-buffer) - (setq mime/mother-buffer mother) - (setq major-mode 'mime/show-message-mode) - (setq mode-name "MIME-View") - (mime/view-mode) - (run-hooks 'mime/show-message-mode-hook) - ) -;;; @ MIME view message mode (minor-mode) +;;; @ MIME viewer mode ;;; -(defun mime/view-mode () +(defun mime/viewer-mode (&optional mother) (interactive) - (make-local-variable 'mime/view-mode-old-local-map) - (let ((keymap (current-local-map))) - (if (null keymap) - (setq keymap (make-sparse-keymap)) - (progn - (setq mime/view-mode-old-local-map keymap) + (let ((buf (get-buffer mime/output-buffer-name)) + (the-buf (current-buffer)) + ) + (if buf + (progn + (switch-to-buffer buf) + (erase-buffer) + (switch-to-buffer the-buf) + ))) + (let ((ret (mime/parse-message)) + (mode major-mode)) + (switch-to-buffer (car ret)) + (setq major-mode 'mime/viewer-mode) + (setq mode-name "MIME-View") + + (make-variable-buffer-local 'mime/viewer-original-major-mode) + (setq mime/viewer-original-major-mode + (if mother + (progn + (make-variable-buffer-local + 'mime/show-mode-old-window-configuration) + (setq mime/show-mode-old-window-configuration + (current-window-configuration)) + (make-variable-buffer-local 'mime/mother-buffer) + (setq mime/mother-buffer mother) + 'mime/show-message-mode) + mode)) + (let ((keymap (current-local-map))) + (if (null keymap) + (setq keymap (make-sparse-keymap)) (setq keymap (copy-keymap keymap)) - )) - (let ((buf (get-buffer mime/output-buffer-name))) - (if buf - (let ((the-buf (current-buffer))) - (switch-to-buffer buf) - (erase-buffer) - (switch-to-buffer the-buf) - ))) - (use-local-map keymap) - (define-key keymap "u" 'mime/up-content) - (define-key keymap "p" 'mime/previous-content) - (define-key keymap "n" 'mime/next-content) - (define-key keymap " " 'mime/scroll-up-content) - (define-key keymap "\M- " 'mime/scroll-down-content) - (define-key keymap "v" 'mime/play-content) - (define-key keymap "e" 'mime/extract-content) - (define-key keymap "\C-c\C-p" 'mime/print-content) - (define-key keymap "\C-c\C-x" 'mime/exit-view-mode) - ) - (mime/parse-message) - (search-forward "\n\n" nil t) - ) + ) + (use-local-map keymap) + (define-key keymap "u" 'mime/up-content) + (define-key keymap "p" 'mime/previous-content) + (define-key keymap "n" 'mime/next-content) + (define-key keymap " " 'mime/scroll-up-content) + (define-key keymap "\M- " 'mime/scroll-down-content) + (define-key keymap "v" 'mime/play-content) + (define-key keymap "e" 'mime/extract-content) + (define-key keymap "\C-c\C-p" 'mime/print-content) + (define-key keymap "\C-c\C-x" 'mime/exit-view-mode) + + (make-variable-buffer-local 'mime/preview-flat-content-list) + (setq mime/preview-flat-content-list (nth 1 ret)) + + (goto-char + (let ((ce (nth 1 (car mime/preview-flat-content-list))) + e) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (setq e (match-end 0)) + (if (<= e ce) + e + ce))) + ))) (defun mime/decode-content () (interactive) - (let ((cr (mime/get-content-region - (mime/get-point-content-number (point)))) - ) - (and cr - (null (nth 2 cr)) - (mime/decode-content-region (car cr)(nth 1 cr)) - ))) + (let ((pc (mime/get-point-preview-content (point)))) + (if pc + (let ((the-buf (current-buffer))) + (switch-to-buffer (nth 2 pc)) + (mime/decode-content-region (nth 3 pc)(nth 4 pc)) + (if (eq (current-buffer) (nth 2 pc)) + (switch-to-buffer the-buf) + ) + )))) (defun mime/play-content () (interactive) @@ -586,20 +761,36 @@ (defun mime/up-content () (interactive) - (let ((cn (mime/get-point-content-number (point))) - r) + (let ((pc (mime/get-point-preview-content (point))) + (the-buf (current-buffer)) + cn r) + (switch-to-buffer (nth 2 pc)) + (setq cn (mime/get-point-content-number (nth 3 pc))) (if (eq cn t) (and (setq r (assoc major-mode mime/go-to-top-node-method-alist)) + (switch-to-buffer the-buf) (funcall (cdr r)) ) - (if (setq r (mime/get-content-region (butlast cn))) - (goto-char (car r)) - ) + (setq r (mime/get-content-region (cdr cn))) + (switch-to-buffer the-buf) + (catch 'tag + (let ((rfcl mime/preview-flat-content-list) cell) + (while rfcl + (setq cell (car rfcl)) + (if (and (= (car r)(nth 3 cell)) + (= (nth 1 r)(nth 4 cell)) + ) + (progn + (goto-char (nth 0 cell)) + (throw 'tag nil) + )) + (setq rfcl (cdr rfcl)) + ))) ))) (defun mime/previous-content () (interactive) - (let* ((fcl (mime/make-flat-content-list)) + (let* ((fcl mime/preview-flat-content-list) (p (point)) (i (- (length fcl) 1)) ) @@ -614,7 +805,7 @@ (defun mime/next-content () (interactive) - (let ((fcl (mime/make-flat-content-list)) + (let ((fcl mime/preview-flat-content-list) (p (point)) ) (catch 'tag @@ -628,7 +819,7 @@ (defun mime/scroll-up-content () (interactive) - (let ((fcl (mime/make-flat-content-list)) + (let ((fcl mime/preview-flat-content-list) (p (point)) (h (- (window-height) 1)) np) @@ -647,7 +838,7 @@ (defun mime/scroll-down-content () (interactive) - (let ((fcl (mime/make-flat-content-list)) + (let ((fcl mime/preview-flat-content-list) (p (point)) (h (- (window-height) 1)) pp) @@ -667,9 +858,9 @@ (defun mime/exit-view-mode () (interactive) - (if (and (boundp 'mime/view-mode-old-local-map) - (keymapp mime/view-mode-old-local-map)) - (use-local-map mime/view-mode-old-local-map) - ) - (show-all) + (kill-buffer (current-buffer)) ) + +(fset 'mime/view-mode 'mime/viewer-mode) + +(run-hooks 'tm-view-load-hook) -- 1.7.10.4