;;;
-;;; $Id: tm-comp.el,v 1.2 1994/09/26 12:37:03 morioka Exp $
+;;; tm-comp.el --- attachment for MIME composer
+;;;
+;;; Copyright (C) 1995 Free Software Foundation, Inc.
+;;; Copyright (C) 1994,1995 MORIOKA Tomohiko
+;;; Copyright (C) 1994,1995 OKABE Yasuo
+;;;
+;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>,
+;;; OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
+;;; modified by MORITA Masahiro <hiro@isl.ntt.JP>
+;;; Kazushi (Jam) MARUKAWA <kazusi-m@is.aist-nara.ac.jp>,
+;;; KOBAYASHI Shuhei <shuhei@cmpt01.phys.tohoku.ac.jp>,
+;;; YAMAOKA Katsumi <yamaoka@ga.sony.co.jp>,
+;;; and Richard Stanton <stanton@haas.berkeley.edu>
+;;; Keywords: mail, news, MIME, multimedia
+;;;
+;;; This file is part of tm (Tools for MIME).
;;;
-(provide 'tm-comp)
-(require 'tl-header)
+(require 'tm-view)
+(require 'tl-822)
+(require 'tl-list)
(require 'mail-utils)
-(defvar mime/tmp-dir (or (getenv "TM_TMPDIR") "/tmp/"))
-(defvar mime/message-max-length 1000)
+;;; @ version
+;;;
+
+(defconst mime/composer-RCS-ID
+ "$Id: tm-comp.el,v 7.2 1995/10/08 09:31:05 morioka Exp $")
+
+(defconst mime/composer-version (get-version-string mime/composer-RCS-ID))
+
+
+;;; @ variables
+;;;
+
+(defvar mime/message-default-max-length 1000)
+
+(defvar mime/message-max-length-alist
+ '((news-reply-mode . 500)))
+
+(defconst mime/message-nuke-headers
+ "\\(^Content-\\|^Subject:\\|^MIME-Version:\\)")
+(defvar mime/message-blind-headers "\\(^[BDFbdf]cc:\\|^cc:[ \t]*$\\)")
+
+(defvar mime/message-default-sender-alist
+ '((mail-mode . mail-send-and-exit)
+ (mh-letter-mode . mh-send-letter)
+ (news-reply-mode . gnus-inews-news)))
+
(defvar mime/message-sender-alist
- '((mail-mode . sendmail-send-it)
- (mh-letter-mode . (lambda ()
- (write-region (point-min) (point-max)
+ '((mail-mode . (lambda ()
+ (interactive)
+ (sendmail-send-it)
+ ))
+ (mh-letter-mode . (lambda (&optional arg)
+ (interactive "P")
+ (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)
+ (message
+ (format "Sending %d/%d..." (+ i 1) total))
+ (cond (arg
+ (pop-to-buffer "MH mail delivery")
+ (erase-buffer)
+ (mh-exec-cmd-output mh-send-prog t "-watch" "-nopush"
+ "-nodraftfolder" mh-send-args mime/draft-file-name)
+ (goto-char (point-max)) ; show the interesting part
+ (recenter -1)
+ (sit-for 1))
+ (t
+ (apply 'mh-exec-cmd-quiet t mh-send-prog
+ (mh-list-to-string
+ (list "-nopush" "-nodraftfolder" "-noverbose" "-nowatch" mh-send-args mime/draft-file-name)))))
+ (message
+ (format "Sending %d/%d... done" (+ i 1) total))
+ ))
))
+
+
(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)
- ))
+ (news-reply-mode . (cond ((boundp 'gnus-winconf-post-news)
+ (prog1
+ gnus-winconf-post-news
+ (setq gnus-winconf-post-news nil)
+ ))
+ ((boundp 'gnus-prev-winconf)
+ (prog1
+ gnus-prev-winconf
+ (setq gnus-prev-winconf nil)
+ ))
+ ))
))
+(defvar mime/news-reply-mode-server-running nil)
+
+
+(defvar mime/message-before-send-hook-alist
+ '((mh-letter-mode . mh-before-send-letter-hook)))
+
+(defvar mime/message-after-send-hook-alist
+ '((mh-letter-mode . (lambda ()
+ (if mh-annotate-char
+ (mh-annotate-msg mh-sent-from-msg
+ mh-sent-from-folder
+ mh-annotate-char
+ "-component" mh-annotate-field
+ "-text"
+ (format "\"%s %s\""
+ (mh-get-field "To:")
+ (mh-get-field "Cc:"))))))
+ ))
+
+(defvar tm-comp/message-inserter-alist nil)
+
+
+;;; @ edit
+;;;
+
+(defun tm-comp::mime-insert-file (file)
+ "Insert a message from a file."
+ (interactive "fInsert file as MIME message: ")
+ (let* ((guess (mime-find-file-type file))
+ (pritype (nth 0 guess))
+ (subtype (nth 1 guess))
+ (parameters (nth 2 guess))
+ (default (nth 3 guess)) ;Guess encoding from its file name.
+ (encoding
+ (if (not (interactive-p))
+ default
+ (completing-read
+ (concat "What transfer encoding"
+ (if default
+ (concat " (default "
+ (if (string-equal default "") "\"\"" default)
+ ")"
+ ))
+ ": ")
+ mime-transfer-encoders nil t nil))))
+ (if (string-equal encoding "")
+ (setq encoding default))
+ (if (consp parameters)
+ (let ((rest parameters) cell attribute value)
+ (setq parameters "")
+ (while rest
+ (setq cell (car rest))
+ (setq attribute (car cell))
+ (setq value (cdr cell))
+ (if (eq value 'file)
+ (setq value (file-name-nondirectory file))
+ )
+ (setq parameters (concat parameters "; " attribute "=" value))
+ (setq rest (cdr rest))
+ )))
+ (mime-insert-tag pritype subtype parameters)
+ (mime-insert-binary-file file encoding)
+ ))
+
+;; Insert the binary content after MIME tag.
+;; modified by MORITA Masahiro <hiro@isl.ntt.JP>
+;; for x-uue
+(defun tm-comp::mime-insert-binary-file (file &optional encoding)
+ "Insert binary FILE at point.
+Optional argument ENCODING specifies an encoding method such as base64."
+ (let ((tmpbuf (get-buffer-create " *MIME insert*")))
+ (save-excursion
+ (set-buffer tmpbuf)
+ (erase-buffer)
+ (let ((mc-flag nil) ;Mule
+ (file-coding-system-for-read
+ (if (featurep 'mule) *noconv*))
+ (kanji-flag nil) ;NEmacs
+ (emx-binary-mode t) ;Stop CRLF to LF conversion in OS/2
+ )
+ (let (jka-compr-compression-info-list
+ jam-zcat-filename-list)
+ (insert-file-contents file))))
+ (prog1
+ (if (and (stringp encoding)
+ (string-equal (downcase encoding) "x-uue"))
+ (let ((mime-transfer-encoders
+ (copy-alist (cons (list "x-uue" "uuencode"
+ (file-name-nondirectory file))
+ mime-transfer-encoders))))
+ (mime-insert-binary-buffer tmpbuf encoding))
+ (mime-insert-binary-buffer tmpbuf encoding))
+ (kill-buffer tmpbuf))))
+
+;; Insert the binary content after MIME tag.
+;; modified by MORITA Masahiro <hiro@isl.ntt.JP>
+;; for x-uue
+(defun tm-comp::mime-insert-binary-buffer (buffer &optional encoding)
+ "Insert binary BUFFER at point.
+Optional argument ENCODING specifies an encoding method such as base64."
+ (let* ((tagend (1- (point))) ;End of the tag
+ (hide-p (and mime-auto-hide-body
+ (stringp encoding)
+ (let ((en (downcase encoding)))
+ (or (string-equal en "base64")
+ (string-equal en "x-uue")
+ ))))
+ )
+ (save-restriction
+ (narrow-to-region (1- (point)) (point))
+ (let ((start (point))
+ (emx-binary-mode t)) ;Stop LF to CRLF conversion in OS/2
+ (insert-buffer-substring buffer)
+ ;; Encode binary message if necessary.
+ (if encoding
+ (mime-encode-region encoding start (point-max))))
+ (if hide-p
+ (progn
+ (mime-flag-region (point-min) (1- (point-max)) ?\^M)
+ (goto-char (point-max)))
+ ))
+ ;; Define encoding even if it is 7bit.
+ (if (stringp encoding)
+ (save-excursion
+ (goto-char tagend) ;Make sure which line the tag is on.
+ (mime-define-encoding encoding)))
+ ))
+
+
+(defun tm-comp/insert-message (&optional message)
+ (interactive)
+ (let ((inserter (assoc-value major-mode tm-comp/message-inserter-alist)))
+ (if (and inserter (fboundp inserter))
+ (progn
+ (mime-insert-tag "message" "rfc822")
+ (funcall inserter message)
+ )
+ (message "Sorry, I don't have message inserter for your MUA.")
+ )))
+
+
+;;; @ split
+;;;
+
(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))))
+ (let ((mime/message-max-length
+ (or (cdr (assq major-mode mime/message-max-length-alist))
+ mime/message-default-max-length))
+ (lines (count-lines (point-min) (point-max)))
)
- (if (null mime/draft-file-name)
- (setq mime/draft-file-name
- (make-temp-name (expand-file-name "tm-draft" mime/tmp-dir)))
- )
- (if (and (boundp 'mime-mode-flag) mime-mode-flag)
- (mime-mode-exit))
(if (<= lines mime/message-max-length)
- (funcall cmd)
- (let ((header (message/get-header-string-except
- "\\(^[Cc]ontent-\\|^[Ss]ubject:\\)" separator))
- (subject (mail-fetch-field "subject"))
- (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)
+ (call-interactively
+ (or cmd (cdr (assq major-mode mime/message-default-sender-alist))))
+ (let* ((mime/draft-file-name
+ (or (buffer-file-name)
+ (make-temp-name (expand-file-name "tm-draft" mime/tmp-dir))))
+ (separator mail-header-separator)
+ (config (eval (cdr (assq major-mode mime/window-config-alist))))
+ (id (concat "\""
+ (replace-space-with-underline (current-time-string))
+ "@" (system-name) "\"")))
+
+ (let ((hook (cdr (assq major-mode
+ mime/message-before-send-hook-alist))))
+ (run-hooks hook))
+ (let* ((header (rfc822/get-header-string-except
+ mime/message-nuke-headers separator))
+ (orig-header (rfc822/get-header-string-except
+ mime/message-blind-headers separator))
+ (subject (mail-fetch-field "subject"))
+ (total (+ (/ lines mime/message-max-length)
(if (> (mod lines mime/message-max-length) 0)
1)))
- (i 0)(l mime/message-max-length)
+ (i 0)
+ (l mime/message-max-length)
(the-buf (current-buffer))
(buf (get-buffer "*tmp-send*"))
+ (command
+ (or cmd
+ (cdr (assq major-mode mime/message-sender-alist))
+ (cdr (assq major-mode mime/message-default-sender-alist))))
data)
+ (goto-char (point-min))
+ (if (re-search-forward (concat "^" (regexp-quote separator) "$")
+ nil t)
+ (replace-match "")
+ )
(if buf
(progn
(switch-to-buffer buf)
(setq mail-header-separator separator)
(switch-to-buffer the-buf)
(goto-char (point-min))
+ (re-search-forward "^$" nil t)
(while (< i total)
(setq buf (get-buffer "*tmp-send*"))
-
(setq data (buffer-substring
(point)
(progn
(insert
(format "Subject: %s (%d/%d)\n" subject (+ i 1) total))
(insert
+ (format "Mime-Version: 1.0 (split by tm-comp %s)\n"
+ mime/composer-version))
+ (insert
(format
"Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n"
id (+ i 1) total separator))
+ (if (eq i 0)
+ (insert orig-header))
(insert data)
- (funcall cmd)
+ (save-excursion
+ (call-interactively command))
(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)
- )
- ))
+ )
+ (let ((hook
+ (cdr (assq major-mode mime/message-after-send-hook-alist))))
+ (run-hooks 'hook))
+ (set-buffer-modified-p nil)
+ (cond ((y-or-n-p "Kill draft buffer? ")
+ (kill-buffer (current-buffer))
+ (if config
+ (set-window-configuration config))))
+ (message "")
+ ))))
+
+(defun tm-comp::mime-mode-exit-and-run ()
+ (interactive)
+ (mime-mode-exit)
+ (call-interactively 'mime/split-and-send)
+ )
+
+
+;;; @ set up
+;;;
(add-hook 'mime-mode-hook
(function
(lambda ()
- (if (not (fboundp 'default-mime-mode-exit-and-run))
+ (if (not (fboundp 'original::mime-insert-file))
+ (progn
+ (fset 'original::mime-insert-file
+ (symbol-function 'mime-insert-file))
+ (fset 'mime-insert-file 'tm-comp::mime-insert-file)
+ ))
+ (if (not (fboundp 'original::mime-insert-binary-file))
+ (progn
+ (fset 'original::mime-insert-binary-file
+ (symbol-function 'mime-insert-binary-file))
+ (fset 'mime-insert-binary-file
+ 'tm-comp::mime-insert-binary-file)
+ ))
+ (if (not (fboundp 'original::mime-insert-binary-buffer))
(progn
- (make-variable-buffer-local 'mime/send-message-method)
- (fset 'default-mime-mode-exit-and-run
- 'mime-mode-exit-and-run)
+ (fset 'original::mime-insert-binary-buffer
+ (symbol-function 'mime-insert-binary-buffer))
+ (fset 'mime-insert-binary-buffer
+ 'tm-comp::mime-insert-binary-buffer)
+ ))
+ (if (not (fboundp 'original::mime-mode-exit-and-run))
+ (progn
+ (fset 'original::mime-mode-exit-and-run
+ (symbol-function 'mime-mode-exit-and-run))
(fset 'mime-mode-exit-and-run
- 'mime/split-and-send)
- )))))
+ 'tm-comp::mime-mode-exit-and-run)
+ ))
+ (define-key (lookup-key (current-local-map) mime-prefix)
+ "m" 'tm-comp/insert-message)
+ )))
-(defun message/get-header-string-except (pat boundary)
- (save-excursion
- (save-restriction
- (narrow-to-region (goto-char (point-min))
- (progn
- (re-search-forward
- (concat "^\\(" (regexp-quote boundary) "\\)?$")
- nil t)
- (match-beginning 0)
- ))
+
+;;; @ draft preview
+;;;
+;; by "OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
+;; Mon, 10 Apr 1995 20:03:07 +0900
+
+(defvar mime/draft-header-separator-alist
+ '((news-reply-mode . mail-header-separator)
+ (mh-letter-mode . mail-header-separator)
+ ))
+
+(defvar mime::article/draft-header-separator nil)
+
+(defun mime/draft-preview ()
+ (interactive)
+ (let ((sep (assoc-value major-mode mime/draft-header-separator-alist)))
+ (or (stringp sep) (setq sep (eval sep)))
+ (make-variable-buffer-local 'mime::article/draft-header-separator)
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^\\(" (regexp-quote sep) "\\)?$"))
+ (setq mime::article/draft-header-separator
+ (buffer-substring (match-beginning 0) (match-end 0)))
+ (replace-match "")
+ (mime/viewer-mode (current-buffer))
+ (pop-to-buffer (current-buffer))
+ ))
+
+(defun mime-viewer::quitting-method/draft-preview ()
+ (let ((mother mime/mother-buffer))
+ (save-excursion
+ (switch-to-buffer mother)
(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)
- )))
+ (if (and
+ (re-search-forward
+ (concat "^\\("
+ (regexp-quote mime::article/draft-header-separator)
+ "\\)?$") nil t)
+ (bolp))
+ (progn
+ (insert mime::article/draft-header-separator)
+ (set-buffer-modified-p (buffer-modified-p))
+ )))
+ (mime-viewer/kill-buffer)
+ (pop-to-buffer mother)
+ ))
+
+(set-alist 'mime-viewer/quitting-method-alist
+ 'mh-letter-mode
+ (function mime-viewer::quitting-method/draft-preview)
+ )
+
+(set-alist 'mime-viewer/quitting-method-alist
+ 'news-reply-mode
+ (function mime-viewer::quitting-method/draft-preview)
+ )
+
+
+;;; @ etc
+;;;
+
+(defun rfc822/get-header-string-except (pat boundary)
+ (let ((case-fold-search t))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (goto-char (point-min))
+ (progn
+ (re-search-forward
+ (concat "^\\(" (regexp-quote boundary) "\\)?$")
+ nil t)
+ (match-beginning 0)
+ ))
+ (goto-char (point-min))
+ (let (field header)
+ (while (re-search-forward rfc822/field-top-regexp nil t)
+ (setq field (buffer-substring (match-beginning 0)
+ (rfc822/field-end)
+ ))
+ (if (not (string-match pat field))
+ (setq header (concat header field "\n"))
+ ))
+ header)
+ ))))
(defun replace-space-with-underline (str)
(mapconcat (function
?_
arg)))) str "")
)
+
+
+;;; @ end
+;;;
+
+(provide 'tm-comp)
+
+(run-hooks 'tm-comp-load-hook)
projects / elisp / tm.git / blobdiff