From 6f60f010f0797bb67af3aa0bf0f202b61ad7b72d Mon Sep 17 00:00:00 2001 From: morioka Date: Mon, 2 Mar 1998 13:37:40 +0000 Subject: [PATCH] tm 4.8.3. --- Makefile | 28 +-- methods/tm-file | 10 +- methods/tm-image | 21 +- mime-setup.el | 19 +- sc-setup.el | 49 +++-- tl-list.el | 34 ++- tl-str.el | 64 ++++++ tm-comp.el | 144 +++++++++++++ tm-gnus.el | 52 +---- tm-gnus3.el | 42 ++-- tm-gnus4.el | 25 ++- tm-mh-e.el | 49 ++--- tm-misc.el | 8 +- tm-rmail.el | 38 ++++ tm-setup.el | 7 +- tm-view.el | 623 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 16 files changed, 1029 insertions(+), 184 deletions(-) create mode 100644 tl-str.el create mode 100644 tm-comp.el create mode 100644 tm-rmail.el create mode 100644 tm-view.el diff --git a/Makefile b/Makefile index 2eacc1b..6412dad 100644 --- a/Makefile +++ b/Makefile @@ -4,27 +4,19 @@ CFLAGS = -O UTILS = ol2 decode-b METHODS = tm-au tm-file tm-image tm-latex tm-mpeg -OLFILES = README-jp.ol tiny-mime-jp.ol tm-body-jp.ol \ - tm-mh-e-jp.ol tm-gnus-jp.ol signature-jp.ol \ - README-eng.ol tiny-mime-eng.ol tm-body-eng.ol \ - tm-mh-e-eng.ol tm-gnus-eng.ol -TEXFILES= README-jp.tex tiny-mime-jp.tex tm-body-jp.tex \ - tm-mh-e-jp.tex tm-gnus-jp.tex \ - README-eng.tex tiny-mime-eng.tex tm-body-eng.tex \ - tm-mh-e-eng.tex tm-gnus-eng.tex -DVIFILES= README-jp.dvi tiny-mime-jp.dvi tm-body-jp.dvi \ - tm-mh-e-jp.dvi tm-gnus-jp.dvi \ - README-eng.dvi tiny-mime-eng.dvi tm-body-eng.dvi \ - tm-mh-e-eng.dvi tm-gnus-eng.dvi -PSFILES = README-jp.ps tiny-mime-jp.ps tm-body-jp.ps \ - tm-mh-e-jp.ps tm-gnus-jp.ps signature-jp.ps \ - README-eng.ps tiny-mime-eng.ps tm-body-eng.ps \ - tm-mh-e-eng.ps tm-gnus-eng.ps -GOMI = *.aux *.log *.tex $(DVIFILES) *.ps $(UTILS) +OLFILES = tiny-mime-jp.ol signature-jp.ol \ + tiny-mime-eng.ol +TEXFILES= tiny-mime-jp.tex signature-jp.tex \ + tiny-mime-eng.tex +DVIFILES= tm-jp.dvi tiny-mime-jp.dvi signature-jp.dvi \ + tiny-mime-eng.dvi +PSFILES = tm-jp.ps tiny-mime-jp.ps signature-jp.ps \ + tiny-mime-eng.ps +GOMI = *.aux *.log $(TEXFILES) $(DVIFILES) *.ps $(UTILS) FILES = *.ol Makefile *.el *.c methods $(TEXFILES) -TARFILE = tm4.8.2.tar +TARFILE = tm4.8.3.tar .SUFFIXES: .ol .tex .dvi .ps diff --git a/methods/tm-file b/methods/tm-file index 92b16c0..aa94b2f 100755 --- a/methods/tm-file +++ b/methods/tm-file @@ -1,9 +1,13 @@ #!/bin/csh +if (! $?TM_TMP_DIR) then + set TM_TMP_DIR=/tmp +endif + if( $5 == "" ) then - set filename="/tmp/mime$$" + set filename="$TM_TMP_DIR/mime$$" else - set filename = /tmp/$5 + set filename = $TM_TMP_DIR/$5 endif echo "$2; $3 -> $filename" @@ -21,7 +25,7 @@ case "quoted-printable": mmencode -q -u $1 > $filename breaksw case "x-uue": - pushd /tmp + pushd $TM_TMP_DIR uudecode $1 popd breaksw diff --git a/methods/tm-image b/methods/tm-image index 852d822..83436e1 100755 --- a/methods/tm-image +++ b/methods/tm-image @@ -1,27 +1,31 @@ #!/bin/csh +if (! $?TM_TMP_DIR) then + set TM_TMP_DIR=/tmp +endif + if( $5 == "" ) then switch ( $2 ) case "image/gif": - set filename="/tmp/mime$$.gif" + set filename="$TM_TMP_DIR/mime$$.gif" breaksw case "image/jpeg": - set filename="/tmp/mime$$.jpg" + set filename="$TM_TMP_DIR/mime$$.jpg" breaksw case "image/x-xwd": - set filename="/tmp/mime$$.xwd" + set filename="$TM_TMP_DIR/mime$$.xwd" breaksw case "image/x-xbm": - set filename="/tmp/mime$$.xbm" + set filename="$TM_TMP_DIR/mime$$.xbm" breaksw case "image/x-pic": - set filename="/tmp/mime$$.pic" + set filename="$TM_TMP_DIR/mime$$.pic" breaksw default: - set filename="/tmp/mime$$.img" + set filename="$TM_TMP_DIR/mime$$.img" endsw else - set filename = /tmp/$5 + set filename = $TM_TMP_DIR/$5 endif echo "$2; $3 -> $filename" @@ -35,6 +39,9 @@ case "binary": case "base64": decode-b < $1 > $filename breaksw +case "quoted-printable": + mmencode -u -q $1 > $filename + breaksw endsw /bin/rm $1 diff --git a/mime-setup.el b/mime-setup.el index 74de2bd..70c6775 100644 --- a/mime-setup.el +++ b/mime-setup.el @@ -1,5 +1,5 @@ ;;; -;;; $Id: mime-setup.el,v 1.17 1994/08/20 12:06:34 morioka Exp $ +;;; $Id: mime-setup.el,v 3.0 1994/08/31 05:33:58 morioka Exp $ ;;; (provide 'mime-setup) @@ -174,23 +174,6 @@ (setq gnus-signature-file nil) -;;; @ for RMAIL -;;; -(autoload 'rmail-show-mime "rmailmime" "Show MIME messages." t) -(autoload 'rmail-convert-mime-header "rmailmime" "Convert MIME header." nil) -(setq rmail-message-filter (function mime/decode-message-header)) -(add-hook 'rmail-mode-hook - (function - (lambda () - ;; Forward mail using MIME. - (require 'mime) - (substitute-key-definition 'rmail-forward - 'mime-forward-from-rmail-using-mail - (current-local-map)) - (local-set-key "v" 'rmail-show-mime) - ))) - - ;;; @ for Mail mode (includes VM mode) ;;; (add-hook 'mail-mode-hook (function mime-mode)) diff --git a/sc-setup.el b/sc-setup.el index c191963..18f38a1 100644 --- a/sc-setup.el +++ b/sc-setup.el @@ -1,5 +1,5 @@ ;;; -;;; $Id: sc-setup.el,v 1.2 1994/08/20 12:12:59 morioka Exp $ +;;; $Id: sc-setup.el,v 1.3 1994/08/22 13:56:10 morioka Exp morioka $ ;;; (provide 'sc-setup) @@ -14,7 +14,10 @@ ;;; @ for Super Cite ;;; -(autoload 'sc-cite-original "sc" nil t) +(if (< (string-to-int emacs-version) 19) + (autoload 'sc-cite-original "sc" nil t) + (autoload 'sc-cite-original "supercite" "supercite 3.1" t) + (autoload 'sc-submit-bug-report "supercite" "Supercite 3.1" t)) (setq sc-citation-leader "") (cond ((boundp 'MULE) ;; for MULE @@ -25,28 +28,34 @@ (setq sc-cite-regexp "\\s *\\([a-zA-Z0-9]\\|\\cc\\|\\cC\\|\\ch\\|\\cH\\|\\ck\\|\\cK\\)*>+\\s *") )) -(defun my-sc-overload-hook () - (require 'sc-oloads) - (sc-overload-functions) - ) +(if (< (string-to-int emacs-version) 19) + (progn + (defun my-sc-overload-hook () + (require 'sc-oloads) + (sc-overload-functions) + ) -;;; @@ for all but mh-e -;;; -(setq mail-yank-hooks (function sc-cite-original)) + ;; @@ for all but mh-e + ;; + (setq mail-yank-hooks (function sc-cite-original)) -;;; @@ for RMAIL, PCMAIL, GNUS -;;; -(add-hook 'mail-setup-hook (function my-sc-overload-hook)) + ;; @@ for RMAIL, PCMAIL, GNUS + ;; + (add-hook 'mail-setup-hook (function my-sc-overload-hook)) -;;; @@ for Gnus -;;; -(add-hook 'news-reply-mode-hook (function my-sc-overload-hook)) -(add-hook 'gnews-ready-hook (function my-sc-overload-hook)) + ;; @@ for Gnus + ;; + (add-hook 'news-reply-mode-hook (function my-sc-overload-hook)) + (add-hook 'gnews-ready-hook (function my-sc-overload-hook)) -;;; @@ for mh-e -;;; -(add-hook 'mh-letter-mode-hook (function my-sc-overload-hook)) -(setq mh-yank-hooks 'sc-cite-original) ; for MH-E only + ;; @@ for mh-e + ;; + (add-hook 'mh-letter-mode-hook (function my-sc-overload-hook)) + (setq mh-yank-hooks 'sc-cite-original) ; for MH-E only + ) + (add-hook 'mail-citation-hook 'sc-cite-original) + (setq news-reply-header-hook nil) + ) ;;; @ for sc-register diff --git a/tl-list.el b/tl-list.el index 8f3c781..6b0d85d 100644 --- a/tl-list.el +++ b/tl-list.el @@ -1,15 +1,40 @@ ;;; -;;; $Id: tl-list.el,v 0.3 1994/07/16 04:08:52 morioka Exp morioka $ +;;; $Id: tl-list.el,v 0.6 1994/08/28 17:10:12 morioka Exp $ ;;; (provide 'tl-list) +;;; @ list +;;; + +(defun last (list) + "Returns the last element in the list . +[mol's Common Lisp emulating function]" + (nthcdr (- (length list) 1) list) + ) + +(defun butlast (x &optional n) + "Returns a copy of LIST with the last N elements removed. +[tl-list.el: imported from cl.el]" + (if (and n (<= n 0)) x + (nbutlast (copy-sequence x) n))) + +(defun nbutlast (x &optional n) + "Modifies LIST to remove the last N elements. +[tl-list.el: imported from cl.el]" + (let ((m (length x))) + (or n (setq n 1)) + (and (< n m) + (progn + (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil)) + x)))) + + ;;; @ alist ;;; (defun put-alist (item value alist) - "\t(put-alist )\n -If there is a pair whose car is , replace its cdr by . + "If there is a pair whose car is , replace its cdr by . If there is not such pair, create new pair ( . ) and return new alist whose car is the new pair and cdr is . [mol's ELIS emulating function]" @@ -21,8 +46,7 @@ return new alist whose car is the new pair and cdr is . )) (defun del-alist (item alist) - "\t(del-alist )\n -If there is a pair whose key is , delete it from . + "If there is a pair whose key is , delete it from . [mol's ELIS emulating function]" (if (equal item (car (car alist))) (cdr alist) diff --git a/tl-str.el b/tl-str.el new file mode 100644 index 0000000..5dce601 --- /dev/null +++ b/tl-str.el @@ -0,0 +1,64 @@ +;;; +;;; $Id: tl-str.el,v 1.3 1994/08/31 06:54:15 morioka Exp $ +;;; + +(provide 'tl-str) + +(defun fill-cited-region (beg end) + (interactive "*r") + (save-excursion + (save-restriction + (goto-char end) + (while (not (eolp)) + (backward-char) + ) + (setq end (point)) + (narrow-to-region beg end) + (goto-char (point-min)) + (let* ((fill-prefix + (and (re-search-forward "^[^ \t>]*[>|]+[ \t]*" nil t) + (buffer-substring (match-beginning 0) + (match-end 0) + ))) + (pat (concat "\n" fill-prefix)) + ) + (goto-char (point-min)) + (while (search-forward pat nil t) + (replace-match "") + ) + (goto-char (point-min)) + (fill-region (point-min) (point-max)) + )))) + +(defun replace-top-string (&optional old new) + (interactive) + (if (null old) + (setq old (read-string "old string is ? ")) + ) + (if (null new) + (setq new (read-string "new string is ? ")) + ) + (while (re-search-forward (concat "^" (regexp-quote old)) nil t) + (replace-match new) + )) + +(defun replace-as-filename (str) + (let ((dest "") + (i 0)(len (length str)) + chr) + (while (< i len) + (setq chr (elt str i)) + (if (or (and (<= ?+ chr)(<= chr ?.)) + (and (<= ?0 chr)(<= chr ?:)) + (= chr ?=) + (and (<= ?@ chr)(<= chr ?\[)) + (and (<= ?\] chr)(<= chr ?_)) + (and (<= ?a chr)(<= chr ?{)) + (and (<= ?} chr)(<= chr ?~)) + ) + (setq dest (concat dest + (char-to-string chr))) + ) + (setq i (+ i 1)) + ) + dest)) diff --git a/tm-comp.el b/tm-comp.el new file mode 100644 index 0000000..9663b53 --- /dev/null +++ b/tm-comp.el @@ -0,0 +1,144 @@ +;;; +;;; $Id: tm-comp.el,v 1.1 1994/08/21 22:00:44 morioka Exp morioka $ +;;; + +(provide 'tm-comp) + +(defvar mime/message-max-length 1000) +(defvar mime/message-sender-alist + '((mail-mode . sendmail-send-it) + (mh-letter-mode . (lambda () + (write-region (point-min) (point-max) + mime/draft-file-name) + (call-process + (expand-file-name mh-send-prog mh-progs) + nil nil nil mime/draft-file-name) + )) + (news-reply-mode . gnus-inews-article) + )) +(defvar mime/window-config-alist + '((mail-mode . nil) + (mh-letter-mode . mh-previous-window-config) + (news-reply-mode . (prog1 + gnus-winconf-post-news + (setq gnus-winconf-post-news nil) + )) + )) + +(defun mime/split-and-send (&optional cmd) + (interactive) + (if (null cmd) + (setq cmd (cdr (assq major-mode mime/message-sender-alist))) + ) + (let ((mime/draft-file-name (buffer-file-name)) + (lines (count-lines (point-min)(point-max))) + (separator mail-header-separator) + (config (eval (cdr (assq major-mode mime/window-config-alist)))) + ) + (if (null mime/draft-file-name) + (setq mime/draft-file-name "/tmp/tm-draft") + ) + (mime-mode-exit) + (if (<= lines mime/message-max-length) + (funcall cmd) + (let ((header (message/get-header-string-except + "^Content-" separator)) + (id (concat "\"" + (replace-space-with-underline (current-time-string)) + "@" (system-name) "\"")) + ) + (goto-char (point-min)) + (if (re-search-forward (concat "^" (regexp-quote separator) "$") + nil t) + (replace-match "") + ) + (let* ((total (+ (/ lines mime/message-max-length) + (if (> (mod lines mime/message-max-length) 0) + 1))) + (i 0)(l mime/message-max-length) + (the-buf (current-buffer)) + (buf (get-buffer "*tmp-send*")) + data) + (if buf + (progn + (switch-to-buffer buf) + (erase-buffer) + (switch-to-buffer the-buf) + ) + (setq buf (get-buffer-create "*tmp-send*")) + ) + (switch-to-buffer buf) + (make-variable-buffer-local 'mail-header-separator) + (setq mail-header-separator separator) + (switch-to-buffer the-buf) + (goto-char (point-min)) + (while (< i total) + (setq buf (get-buffer "*tmp-send*")) + + (setq data (buffer-substring + (point) + (progn + (goto-line l) + (point)) + )) + (switch-to-buffer buf) + (insert header) + (insert + (format + "Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n" + id (+ i 1) total separator)) + (insert data) + (funcall cmd) + (erase-buffer) + (switch-to-buffer the-buf) + (setq l (+ l mime/message-max-length)) + (setq i (+ i 1)) + ) + ))) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer)) + (if config + (set-window-configuration config) + ) + )) + +(add-hook 'mime-mode-hook + (function + (lambda () + (if (not (fboundp 'default-mime-mode-exit-and-run)) + (progn + (make-variable-buffer-local 'mime/send-message-method) + (fset 'default-mime-mode-exit-and-run + 'mime-mode-exit-and-run) + (fset 'mime-mode-exit-and-run + 'mime/split-and-send) + ))))) + +(defun message/get-header-string-except (pat boundary) + (save-excursion + (save-restriction + (narrow-to-region (goto-char (point-min)) + (progn + (re-search-forward boundary nil t) + (match-beginning 0) + )) + (goto-char (point-min)) + (let (field header) + (while (re-search-forward message/field-regexp nil t) + (setq field (buffer-substring (match-beginning 0) + (match-end 0) + )) + (if (not (string-match pat field)) + (setq header (concat header field "\n")) + )) + header) + ))) + +(defun replace-space-with-underline (str) + (mapconcat (function + (lambda (arg) + (char-to-string + (if (= arg 32) + ?_ + arg)))) str "") + ) diff --git a/tm-gnus.el b/tm-gnus.el index ec6a9d7..ac15c58 100644 --- a/tm-gnus.el +++ b/tm-gnus.el @@ -1,5 +1,5 @@ ;;; -;;; $Id: tm-gnus.el,v 2.0 1994/07/24 08:33:00 morioka Exp morioka $ +;;; $Id: tm-gnus.el,v 3.0 1994/08/28 16:22:16 morioka Exp $ ;;; ;;; A MIME extension for GNUS ;;; @@ -46,57 +46,9 @@ If you don't like it, define your own gnus-article-set-mode-line." (set-buffer-modified-p t)) -;;; @ MIME full decode message -;;; -(defun tm-gnus/full-decode-message-old (arg) - "MIME full-decode this article." - (interactive "P") - (let ((gnus-Article-prepare-hook mime/body-decoding-method)) - ;; The following is a trick - ;; to force to read the current article again. - (setq gnus-have-all-headers (not gnus-have-all-headers)) - (gnus-summary-select-article (not gnus-have-all-headers) t) - )) - -(defun tm-gnus/full-decode-message-new (arg) - "MIME full-decode this article." - (interactive "P") - (setq gnus-show-mime t) - ;; The following is a trick to force to read the current article again. - (setq gnus-have-all-headers (not gnus-have-all-headers)) - (gnus-summary-select-article (not gnus-have-all-headers) t) - (setq gnus-show-mime nil)) - -(defun tm-gnus/play-message (arg) - "MIME decode and play this message." - (interactive "P") - (let ((mime/body-decoding-mode "play")) - (tm-gnus/full-decode-message arg) - ) - (mime/show-body-decoded-result) - ) - -(defun tm-gnus/extract-message (arg) - "MIME decode and extract files from this message." - (interactive "P") - (let ((mime/body-decoding-mode "extract")) - (tm-gnus/full-decode-message arg) - ) - (mime/show-body-decoded-result) - ) - -(defun tm-gnus/print-message (arg) - "MIME decode and print contents of this message." - (interactive "P") - (let ((mime/body-decoding-mode "print")) - (tm-gnus/full-decode-message arg) - ) - (mime/show-body-decoded-result) - ) - - ;;; @ change MIME header decoding mode, decoding or non decoding. ;;; + (defun tm-gnus/set-mime-header-decoding-mode (arg) "Set MIME header processing. With arg, turn MIME processing on iff arg is positive." diff --git a/tm-gnus3.el b/tm-gnus3.el index 8143b82..185812f 100644 --- a/tm-gnus3.el +++ b/tm-gnus3.el @@ -1,10 +1,12 @@ ;;; -;;; $Id: tm-gnus3.el,v 2.0 1994/07/24 08:33:00 morioka Exp morioka $ +;;; $Id: tm-gnus3.el,v 3.2 1994/08/31 12:07:15 morioka Exp $ ;;; (provide 'tm-gnus3) (require 'tm-gnus) +(require 'tm-view) +(require 'tl-list) (if (and (null gnus-Startup-hook) (boundp 'gnus-startup-hook)) @@ -27,15 +29,28 @@ (setq gnus-Article-prepare-hook gnus-article-prepare-hook) ) -(defun tm-gnus/full-decode-message-old (arg) - "MIME full-decode this article." +(setq mime/go-to-top-node-method-alist + (put-alist 'gnus-Article-mode + (if (string-match (regexp-quote "3.14.4") gnus-version) + (function + (lambda () + (gnus-Article-show-summary) + )) + (function + (lambda () + (gnus-Article-show-subjects) + ))) + mime/go-to-top-node-method-alist)) + +(defun tm-gnus/view-message (arg) + "MIME decode and play this message." (interactive "P") - (let ((gnus-Article-prepare-hook mime/body-decoding-method)) - ;; The following is a trick - ;; to force to read the current article again. - (setq gnus-have-all-headers (not gnus-have-all-headers)) - (gnus-summary-select-article (not gnus-have-all-headers) t) - )) + (let ((gnus-break-pages nil)) + (gnus-Subject-select-article t t) + ) + (pop-to-buffer gnus-Article-buffer t) + (mime/view-mode) + ) (add-hook 'gnus-Select-group-hook (function @@ -51,9 +66,7 @@ (define-key gnus-Subject-mode-map "\et" 'tm-gnus/toggle-mime-header-decoding-mode) -(define-key gnus-Subject-mode-map "v" 'tm-gnus/play-message) -(define-key gnus-Subject-mode-map "e" 'tm-gnus/extract-message) -(define-key gnus-Subject-mode-map "\C-cp" 'tm-gnus/print-message) +(define-key gnus-Subject-mode-map "v" 'tm-gnus/view-message) (fset 'gnus-summary-select-article 'gnus-Subject-select-article) @@ -73,13 +86,8 @@ (make-local-variable 'minor-mode-alist) (mime/add-header-decoding-mode-to-mode-line) ))) - - (fset 'tm-gnus/full-decode-message 'tm-gnus/full-decode-message-old) ) (progn (add-hook 'gnus-Article-mode-hook (function mime/add-header-decoding-mode-to-mode-line)) - - (fset 'tm-gnus/full-decode-message 'tm-gnus/full-decode-message-new) - (setq gnus-show-mime-method mime/body-decoding-method) )) diff --git a/tm-gnus4.el b/tm-gnus4.el index 45ec0c2..958f8e8 100644 --- a/tm-gnus4.el +++ b/tm-gnus4.el @@ -1,10 +1,11 @@ ;;; -;;; $Id: tm-gnus4.el,v 2.0 1994/07/24 08:33:00 morioka Exp morioka $ +;;; $Id: tm-gnus4.el,v 3.1 1994/08/31 05:29:42 morioka Exp $ ;;; (provide 'tm-gnus4) (require 'tm-gnus) +(autoload 'mime/view-mode "tm-view" "View MIME message." t) (if (and (null gnus-startup-hook) (boundp 'gnus-Startup-hook)) @@ -27,6 +28,16 @@ (setq gnus-article-prepare-hook gnus-Article-prepare-hook) ) +(defun tm-gnus/view-message (arg) + "MIME decode and play this message." + (interactive "P") + (let ((gnus-break-pages nil)) + (gnus-summary-select-article t t) + ) + (pop-to-buffer gnus-article-buffer t) + (mime/view-mode) + ) + (add-hook 'gnus-select-group-hook (function (lambda () @@ -41,9 +52,12 @@ (define-key gnus-summary-mode-map "\et" 'tm-gnus/toggle-mime-header-decoding-mode) -(define-key gnus-summary-mode-map "v" 'tm-gnus/play-message) -(define-key gnus-summary-mode-map "e" 'tm-gnus/extract-message) -(define-key gnus-summary-mode-map "\C-cp" 'tm-gnus/print-message) +(define-key gnus-summary-mode-map "v" 'tm-gnus/view-message) +(define-key gnus-summary-mode-map "\e\r" + (function (lambda () + (interactive) + (gnus-summary-scroll-up -1) + ))) (fset 'gnus-article-set-mode-line 'tm-gnus/article-set-mode-line) (add-hook 'gnus-article-mode-hook @@ -55,6 +69,3 @@ (if mime/header-decoding-mode (mime/decode-message-header) ))) t) - -(fset 'tm-gnus/full-decode-message 'tm-gnus/full-decode-message-new) -(setq gnus-show-mime-method mime/body-decoding-method) diff --git a/tm-mh-e.el b/tm-mh-e.el index 0a0de56..b503f24 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 2.2 1994/07/25 16:13:03 morioka Exp $") + "$Id: tm-mh-e.el,v 3.1 1994/08/31 05:32:24 morioka Exp $") (defconst tm-mh-e/version (and (string-match "[0-9][0-9.]*" tm-mh-e/RCS-ID) @@ -24,6 +24,7 @@ (if (not (boundp 'mh-e-version)) (require 'tm-mh-e3) ) +(autoload 'mime/view-mode "tm-view" "View MIME message." t) ;;; @ MIME header decoding mode @@ -43,34 +44,13 @@ With arg, turn MIME processing on if arg is positive." ;;; @ MIME body players ;;; -(defun tm-mh-e/play-message (arg) +(defun tm-mh-e/view-message (arg) "MIME decode and play this message." (interactive "P") (mh-invalidate-show-buffer) - (let ((mime/body-decoding-mode "play")) - (mh-show-msg (mh-get-msg-num t)) - ) - (mime/show-body-decoded-result) - ) - -(defun tm-mh-e/extract-message (arg) - "MIME decode and extract files from this message." - (interactive "P") - (mh-invalidate-show-buffer) - (let ((mime/body-decoding-mode "extract")) - (mh-show-msg (mh-get-msg-num t)) - ) - (mime/show-body-decoded-result) - ) - -(defun tm-mh-e/print-message (arg) - "MIME decode and extract files from this message." - (interactive "P") - (mh-invalidate-show-buffer) - (let ((mime/body-decoding-mode "print")) - (mh-show-msg (mh-get-msg-num t)) - ) - (mime/show-body-decoded-result) + (mh-show-msg (mh-get-msg-num t)) + (pop-to-buffer mh-show-buffer t) + (mime/view-mode) ) @@ -85,13 +65,18 @@ With arg, turn MIME processing on if arg is positive." (if mime/header-decoding-mode (mime/decode-message-header) ) - (if mime/body-decoding-mode - (funcall mime/body-decoding-method) - ) (set-buffer-modified-p nil) )))) (define-key mh-folder-mode-map "\et" 'tm-mh-e/toggle-header-decoding-mode) -(define-key mh-folder-mode-map "v" 'tm-mh-e/play-message) -(define-key mh-folder-mode-map "e" 'tm-mh-e/extract-message) -(define-key mh-folder-mode-map "\C-cp" 'tm-mh-e/print-message) +(define-key mh-folder-mode-map "v" 'tm-mh-e/view-message) +(define-key mh-folder-mode-map "\r" + (function (lambda () + (interactive) + (scroll-other-window 1) + ))) +(define-key mh-folder-mode-map "\e\r" + (function (lambda () + (interactive) + (scroll-other-window -1) + ))) diff --git a/tm-misc.el b/tm-misc.el index d77ac5b..1be7b4b 100644 --- a/tm-misc.el +++ b/tm-misc.el @@ -1,5 +1,5 @@ ;;; -;;; $Id: tm-misc.el,v 2.1 1994/08/01 05:24:09 morioka Exp $ +;;; $Id: tm-misc.el,v 3.0 1994/08/31 07:15:08 morioka Exp $ ;;; ;;; MIME utility for tm-*.el MIME user agent packages ;;; @@ -11,7 +11,6 @@ (require 'tl-18) ) (require 'tiny-mime) -(require 'tm-body) (defvar mime/header-decoding-mode t "*Decode MIME header if non-nil.") @@ -22,10 +21,6 @@ minor-mode-alist)) )) -(defvar mime/body-decoding-mode nil "MIME body decoding mode") -(defvar mime/body-decoding-method (function mime/decode-body) - "MIME body decoding method to play") - ;;; @ about rightful dividing for multi-octet string ;;; @@ -44,6 +39,7 @@ i)) )) + ;;; @ functions to check field ;;; (defun mime/exist-encoded-word-in-subject () diff --git a/tm-rmail.el b/tm-rmail.el new file mode 100644 index 0000000..b995236 --- /dev/null +++ b/tm-rmail.el @@ -0,0 +1,38 @@ +;;; +;;; $Id: tm-rmail.el,v 3.1 1994/08/31 05:37:24 morioka Exp $ +;;; + +(provide 'tm-rmail) + +(if (< (string-to-int emacs-version) 19) + (require 'tl-18) + ) +(autoload 'mime/view-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)) + (mime/decode-message-header) + ) + (set-buffer-modified-p nil) + ))) + +(add-hook 'rmail-mode-hook + (function + (lambda () + (local-set-key "v" 'mime/view-mode) + ))) + +(add-hook 'rmail-summary-mode-hook + (function + (lambda () + (local-set-key "v" + (function + (lambda () + (interactive) + (pop-to-buffer "RMAIL") + (mime/view-mode) + ))) + ))) diff --git a/tm-setup.el b/tm-setup.el index e6eea64..5ad49e8 100644 --- a/tm-setup.el +++ b/tm-setup.el @@ -1,5 +1,5 @@ ;;; -;;; $Id: tm-setup.el,v 1.2 1994/08/20 12:07:45 morioka Exp $ +;;; $Id: tm-setup.el,v 1.3 1994/08/30 04:26:05 morioka Exp $ ;;; (provide 'tm-setup) @@ -14,6 +14,11 @@ )) +;;; @ for RMAIL +;;; +(require 'tm-rmail) + + ;;; @ for mh-e ;;; (add-hook 'mh-folder-mode-hook diff --git a/tm-view.el b/tm-view.el new file mode 100644 index 0000000..a08a312 --- /dev/null +++ b/tm-view.el @@ -0,0 +1,623 @@ +;;; +;;; A MIME viewer for GNU Emacs +;;; +;;; by Morioka Tomohiko, 1994/07/13 + +(provide 'tm-view) + + +;;; @ version +;;; + +(defconst mime/viewer-RCS-ID + "$Id: tm-view.el,v 3.1 1994/08/31 07:16:10 morioka Exp $") + +(defconst mime/viewer-version + (and (string-match "[0-9][0-9.]*" mime/viewer-RCS-ID) + (substring mime/viewer-RCS-ID (match-beginning 0)(match-end 0)) + )) + + +;;; @ require modules +;;; + +(require 'outline) +(require 'tl-str) +(require 'tl-list) +(require 'tl-header) +(require 'tiny-mime) + + +;;; @ constants +;;; + +(defconst mime/tspecials "\000-\040()<>@,;:\\\"/[\093?.=") +(defconst mime/token-regexp + (concat "[^" mime/tspecials "]*")) +(defconst mime/content-type-subtype-regexp + (concat mime/token-regexp "/" mime/token-regexp)) +(defconst mime/content-parameter-value-regexp + (concat "\\(" + message/quoted-string-regexp + "\\|[^; \t\n]\\)*")) + +(defconst mime/output-buffer-name "*MIME-out*") +(defconst mime/decoding-buffer-name "*MIME-decoding*") + + +;;; @ 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/default-showing-Content-Type-list + '("text/plain" "text/x-latex" "message/rfc822")) + +(setq mime/default-showing-Content-Type-list + '("text/plain" "text/x-latex" "message/rfc822")) + +(defvar mime/go-to-top-node-method-alist + '((gnus-article-mode . (lambda () + (gnus-article-show-summary) + )) + (rmail-mode . (lambda () + (mime/exit-view-mode) + (rmail-summary) + (delete-other-windows) + )) + (mh-show-mode . (lambda () + (pop-to-buffer + (let ((name (buffer-name))) + (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) + ))) + )) + +(defvar mime/tmp-dir "/tmp/") + +(defvar mime/use-internal-decoder nil) + +(defvar mime/body-decoding-mode "play" "MIME body decoding mode") + + +;;; @ parser +;;; + +(defun mime/parse-content () + (save-excursion + (save-restriction + (mime/decode-message-header) + (goto-char (point-min)) + (let* ((ctl (mime/Content-Type)) + (boundary (assoc "boundary" (cdr ctl))) + beg end dest) + (search-forward "\n\n" nil t) + (cond (boundary + (let ((sep (concat "\n--" + (setq boundary (read (cdr boundary))) + "\n")) + cb ce ct ret ncb) + (setq beg (match-end 0)) + (search-forward (concat "\n--" boundary "--\n") nil t) + (setq end (match-beginning 0)) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char (point-min)) + (search-forward (concat "--" boundary "\n") nil t) + (setq cb (match-end 0)) + (while (search-forward sep nil t) + (setq ce (match-beginning 0)) + (setq ncb (match-end 0)) + (save-excursion + (save-restriction + (narrow-to-region cb ce) + (setq ret (mime/parse-content)) + )) + (setq dest (append dest (list ret))) + (goto-char (nth 1 ret)) + (search-forward (concat "--" boundary "\n") nil t) + (goto-char (setq cb (match-end 0))) + ) + (setq ce (point-max)) + (save-excursion + (save-restriction + (narrow-to-region cb ce) + (setq ret (mime/parse-content)) + )) + (setq dest (append dest (list ret))) + )) + (setq beg (point-min)) + (goto-char beg) + (search-forward (concat "\n--" boundary "--\n") nil t) + (setq end (match-beginning 0)) + )) + ((string= (car ctl) "message/rfc822") + (save-excursion + (save-restriction + (narrow-to-region (match-end 0) (point-max)) + (setq dest (list (mime/parse-content))) + )) + (setq beg (point-min)) + (setq end (point-max)) + ) + (t + (setq beg (point-min)) + (setq end (point-max)) + )) + (list beg end dest) + )))) + +(defun mime/Content-Type () + (save-excursion + (save-restriction + (if (and (re-search-forward "^Content-Type:[ \t]*" nil t) + (progn + (narrow-to-region + (point) + (and (re-search-forward ".*\\(\n[ \t].*\\)*" nil t) + (match-end 0)) + ) + (goto-char (point-min)) + (re-search-forward mime/content-type-subtype-regexp nil t) + )) + (let ((ctype + (downcase + (buffer-substring (match-beginning 0) (match-end 0)) + )) + dest attribute value) + (while (and (re-search-forward "[ \t\n]*;[ \t\n]*" nil t) + (re-search-forward mime/token-regexp nil t) + ) + (setq attribute + (downcase + (buffer-substring (match-beginning 0) (match-end 0)) + )) + (if (and (re-search-forward "=[ \t\n]*" nil t) + (re-search-forward mime/content-parameter-value-regexp + nil t) + ) + (setq dest + (put-alist attribute + (buffer-substring (match-beginning 0) + (match-end 0)) + dest)) + ) + ) + (cons ctype dest) + ))))) + +(defun mime/Content-Transfer-Encoding (&optional default-encoding) + (save-excursion + (save-restriction + (if (and (re-search-forward "^Content-Transfer-Encoding:[ \t]*" nil t) + (re-search-forward mime/token-regexp nil t) + ) + (downcase (buffer-substring (match-beginning 0) (match-end 0))) + default-encoding) + ))) + +(defun mime/get-name (ctype) + (save-excursion + (save-restriction + (replace-as-filename + (let (ret) + (or (and (setq ret (assoc "name" ctype)) + (read (cdr ret)) + ) + (and (setq ret (assoc "x-name" ctype)) + (read (cdr ret))) + (message/get-field-body "Content-Description") + "")) + )))) + +(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)) + ) + (mime/hide-all) + (set-buffer-modified-p nil) + ))) + + +;;; @ content information +;;; + +(defun mime/get-point-content-number (p &optional cl) + (if (null cl) + (setq cl mime/content-list) + ) + (let ((b (car cl)) + (e (nth 1 cl)) + (c (nth 2 cl)) + ) + (if (and (<= b p)(<= p e)) + (or (let (co ret (sn 0)) + (catch 'tag + (while c + (setq co (car c)) + (setq ret (mime/get-point-content-number p co)) + (cond ((eq ret t) (throw 'tag (list sn))) + (ret (throw 'tag (cons sn ret))) + ) + (setq c (cdr c)) + (setq sn (+ sn 1)) + ))) + t)))) + +(defun mime/get-content-region (cn &optional cl) + (if (null cl) + (setq cl mime/content-list) + ) + (if (eq cn t) + cl + (let ((sn (car cn))) + (if (null sn) + cl + (let ((rcl (nth sn (nth 2 cl)))) + (if rcl + (mime/get-content-region (cdr cn) rcl) + )) + )))) + +(defun mime/make-flat-content-list (&optional cl) + (if (null cl) + (setq cl mime/content-list) + ) + (let ((dest (list (car cl))) + (rcl (nth 2 cl)) + ) + (while rcl + (setq dest (append dest (mime/make-flat-content-list (car rcl)))) + (setq rcl (cdr rcl)) + ) + dest)) + + +;;; @ decoder +;;; + +(defun mime/base64-decode-region (beg end &optional buf filename) + (let ((the-buf (current-buffer)) ret) + (if (null buf) + (setq buf (get-buffer-create mime/decoding-buffer-name)) + ) + (save-excursion + (save-restriction + (switch-to-buffer buf) + (erase-buffer) + (switch-to-buffer the-buf) + (narrow-to-region beg end) + (goto-char (point-min)) + (while (re-search-forward + (concat "^" + mime/Base64-encoded-text-regexp + "$") nil t) + (setq ret (mime/base64-decode-string + (buffer-substring (match-beginning 0) + (match-end 0) + ))) + (switch-to-buffer buf) + (insert ret) + (switch-to-buffer the-buf) + ))) + (if filename + (progn + (switch-to-buffer buf) + (let ((kanji-flag nil) + (mc-flag nil) + (file-coding-system + (if (featurep 'mule) *noconv*)) + ) + (write-file filename) + (kill-buffer buf) + (switch-to-buffer the-buf) + ))) + )) + +(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) + ) + (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) + )) + ))))) + +(defun mime/decode-message/partial-region (beg end ctype default-encoding) + (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) + (if (not (file-exists-p root-dir)) + (shell-command (concat "mkdir " root-dir)) + ) + (setq id (replace-as-filename id)) + (setq root-dir (concat root-dir "/" id)) + (if (not (file-exists-p root-dir)) + (shell-command (concat "mkdir " root-dir)) + ) + (setq file (concat root-dir "/FULL")) + (if (not (file-exists-p file)) + (progn + (re-search-forward "^$") + (goto-char (+ (match-end 0) 1)) + (setq file (concat root-dir "/" number)) + (write-region (point) (point-max) file) + (if (get-buffer "*MIME-temp*") + (kill-buffer "*MIME-temp*") + ) + (switch-to-buffer "*MIME-temp*") + (let ((i 1) + (max (string-to-int total)) + ) + (catch 'tag + (while (<= i max) + (setq file (concat root-dir "/" (int-to-string i))) + (if (not (file-exists-p file)) + (progn + (switch-to-buffer the-buf) + (throw 'tag nil) + )) + (insert-file-contents file) + (goto-char (point-max)) + (setq i (+ i 1)) + ) + (write-file (concat root-dir "/FULL")) + (delete-other-windows) + (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) + )) + )) + +(defun mime/decode-content-region (beg end) + (interactive "*r") + (save-excursion + (save-restriction + (narrow-to-region beg end) + (outline-flag-region beg end ?\n) + (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 end ctl encoding) + ) + (t (mime/start-external-method-region beg end + 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) + (search-forward "\n\n" nil t) + (setq beg (match-end 0)) + (outline-flag-region beg end ?\^M) + ))) + +(defun mime/hide-all () + (let ((fl (mime/make-flat-content-list)) + p c) + (while fl + (setq p (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)) + ))) + + +;;; @ 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) +;;; + +(defun mime/view-mode () + (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) + (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 "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) + ) + +(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)) + ))) + +(defun mime/play-content () + (interactive) + (let ((mime/body-decoding-mode "play")) + (mime/decode-content) + )) + +(defun mime/extract-content () + (interactive) + (let ((mime/body-decoding-mode "extract")) + (mime/decode-content) + )) + +(defun mime/print-content () + (interactive) + (let ((mime/body-decoding-mode "print")) + (mime/decode-content) + )) + +(defun mime/up-content () + (interactive) + (let ((cn (mime/get-point-content-number (point))) + r) + (if (eq cn t) + (and (setq r (assoc major-mode mime/go-to-top-node-method-alist)) + (funcall (cdr r)) + ) + (if (setq r (mime/get-content-region (butlast cn))) + (goto-char (car r)) + ) + ))) + +(defun mime/previous-content () + (interactive) + (let* ((fcl (mime/make-flat-content-list)) + (p (point)) + (i (- (length fcl) 1)) + ) + (catch 'tag + (while (>= i 0) + (if (> p (nth i fcl)) + (throw 'tag (goto-char (nth i fcl))) + ) + (setq i (- i 1)) + )) + )) + +(defun mime/next-content () + (interactive) + (let ((fcl (mime/make-flat-content-list)) + (p (point)) + ) + (catch 'tag + (while fcl + (if (< p (car fcl)) + (throw 'tag (goto-char (car fcl))) + ) + (setq fcl (cdr fcl)) + )) + )) + +(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) + ) -- 1.7.10.4