2 ;;; tm-comp.el --- attachment for MIME composer
4 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
5 ;;; Copyright (C) 1994,1995 MORIOKA Tomohiko
6 ;;; Copyright (C) 1994,1995 OKABE Yasuo
8 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>,
9 ;;; OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
10 ;;; modified by MORITA Masahiro <hiro@isl.ntt.JP>
11 ;;; Kazushi (Jam) MARUKAWA <kazusi-m@is.aist-nara.ac.jp>,
12 ;;; KOBAYASHI Shuhei <shuhei@cmpt01.phys.tohoku.ac.jp>,
13 ;;; YAMAOKA Katsumi <yamaoka@ga.sony.co.jp>,
14 ;;; and Richard Stanton <stanton@haas.berkeley.edu>
15 ;;; Keywords: mail, news, MIME, multimedia
17 ;;; This file is part of tm (Tools for MIME).
29 (defconst mime/composer-RCS-ID
30 "$Id: tm-comp.el,v 7.2 1995/10/08 09:31:05 morioka Exp $")
32 (defconst mime/composer-version (get-version-string mime/composer-RCS-ID))
38 (defvar mime/message-default-max-length 1000)
40 (defvar mime/message-max-length-alist
41 '((news-reply-mode . 500)))
43 (defconst mime/message-nuke-headers
44 "\\(^Content-\\|^Subject:\\|^MIME-Version:\\)")
45 (defvar mime/message-blind-headers "\\(^[BDFbdf]cc:\\|^cc:[ \t]*$\\)")
47 (defvar mime/message-default-sender-alist
48 '((mail-mode . mail-send-and-exit)
49 (mh-letter-mode . mh-send-letter)
50 (news-reply-mode . gnus-inews-news)))
52 (defvar mime/message-sender-alist
53 '((mail-mode . (lambda ()
57 (mh-letter-mode . (lambda (&optional arg)
59 (write-region (point-min) (point-max)
62 (format "Sending %d/%d..." (+ i 1) total))
64 (pop-to-buffer "MH mail delivery")
66 (mh-exec-cmd-output mh-send-prog t "-watch" "-nopush"
67 "-nodraftfolder" mh-send-args mime/draft-file-name)
68 (goto-char (point-max)) ; show the interesting part
72 (apply 'mh-exec-cmd-quiet t mh-send-prog
74 (list "-nopush" "-nodraftfolder" "-noverbose" "-nowatch" mh-send-args mime/draft-file-name)))))
76 (format "Sending %d/%d... done" (+ i 1) total))
81 (defvar mime/window-config-alist
83 (mh-letter-mode . mh-previous-window-config)
84 (news-reply-mode . (cond ((boundp 'gnus-winconf-post-news)
86 gnus-winconf-post-news
87 (setq gnus-winconf-post-news nil)
89 ((boundp 'gnus-prev-winconf)
92 (setq gnus-prev-winconf nil)
97 (defvar mime/news-reply-mode-server-running nil)
100 (defvar mime/message-before-send-hook-alist
101 '((mh-letter-mode . mh-before-send-letter-hook)))
103 (defvar mime/message-after-send-hook-alist
104 '((mh-letter-mode . (lambda ()
106 (mh-annotate-msg mh-sent-from-msg
109 "-component" mh-annotate-field
113 (mh-get-field "Cc:"))))))
116 (defvar tm-comp/message-inserter-alist nil)
122 (defun tm-comp::mime-insert-file (file)
123 "Insert a message from a file."
124 (interactive "fInsert file as MIME message: ")
125 (let* ((guess (mime-find-file-type file))
126 (pritype (nth 0 guess))
127 (subtype (nth 1 guess))
128 (parameters (nth 2 guess))
129 (default (nth 3 guess)) ;Guess encoding from its file name.
131 (if (not (interactive-p))
134 (concat "What transfer encoding"
137 (if (string-equal default "") "\"\"" default)
141 mime-transfer-encoders nil t nil))))
142 (if (string-equal encoding "")
143 (setq encoding default))
144 (if (consp parameters)
145 (let ((rest parameters) cell attribute value)
148 (setq cell (car rest))
149 (setq attribute (car cell))
150 (setq value (cdr cell))
152 (setq value (file-name-nondirectory file))
154 (setq parameters (concat parameters "; " attribute "=" value))
155 (setq rest (cdr rest))
157 (mime-insert-tag pritype subtype parameters)
158 (mime-insert-binary-file file encoding)
161 ;; Insert the binary content after MIME tag.
162 ;; modified by MORITA Masahiro <hiro@isl.ntt.JP>
164 (defun tm-comp::mime-insert-binary-file (file &optional encoding)
165 "Insert binary FILE at point.
166 Optional argument ENCODING specifies an encoding method such as base64."
167 (let ((tmpbuf (get-buffer-create " *MIME insert*")))
171 (let ((mc-flag nil) ;Mule
172 (file-coding-system-for-read
173 (if (featurep 'mule) *noconv*))
174 (kanji-flag nil) ;NEmacs
175 (emx-binary-mode t) ;Stop CRLF to LF conversion in OS/2
177 (let (jka-compr-compression-info-list
178 jam-zcat-filename-list)
179 (insert-file-contents file))))
181 (if (and (stringp encoding)
182 (string-equal (downcase encoding) "x-uue"))
183 (let ((mime-transfer-encoders
184 (copy-alist (cons (list "x-uue" "uuencode"
185 (file-name-nondirectory file))
186 mime-transfer-encoders))))
187 (mime-insert-binary-buffer tmpbuf encoding))
188 (mime-insert-binary-buffer tmpbuf encoding))
189 (kill-buffer tmpbuf))))
191 ;; Insert the binary content after MIME tag.
192 ;; modified by MORITA Masahiro <hiro@isl.ntt.JP>
194 (defun tm-comp::mime-insert-binary-buffer (buffer &optional encoding)
195 "Insert binary BUFFER at point.
196 Optional argument ENCODING specifies an encoding method such as base64."
197 (let* ((tagend (1- (point))) ;End of the tag
198 (hide-p (and mime-auto-hide-body
200 (let ((en (downcase encoding)))
201 (or (string-equal en "base64")
202 (string-equal en "x-uue")
206 (narrow-to-region (1- (point)) (point))
207 (let ((start (point))
208 (emx-binary-mode t)) ;Stop LF to CRLF conversion in OS/2
209 (insert-buffer-substring buffer)
210 ;; Encode binary message if necessary.
212 (mime-encode-region encoding start (point-max))))
215 (mime-flag-region (point-min) (1- (point-max)) ?\^M)
216 (goto-char (point-max)))
218 ;; Define encoding even if it is 7bit.
219 (if (stringp encoding)
221 (goto-char tagend) ;Make sure which line the tag is on.
222 (mime-define-encoding encoding)))
226 (defun tm-comp/insert-message (&optional message)
228 (let ((inserter (assoc-value major-mode tm-comp/message-inserter-alist)))
229 (if (and inserter (fboundp inserter))
231 (mime-insert-tag "message" "rfc822")
232 (funcall inserter message)
234 (message "Sorry, I don't have message inserter for your MUA.")
241 (defun mime/split-and-send (&optional cmd)
243 (let ((mime/message-max-length
244 (or (cdr (assq major-mode mime/message-max-length-alist))
245 mime/message-default-max-length))
246 (lines (count-lines (point-min) (point-max)))
248 (if (<= lines mime/message-max-length)
250 (or cmd (cdr (assq major-mode mime/message-default-sender-alist))))
251 (let* ((mime/draft-file-name
252 (or (buffer-file-name)
253 (make-temp-name (expand-file-name "tm-draft" mime/tmp-dir))))
254 (separator mail-header-separator)
255 (config (eval (cdr (assq major-mode mime/window-config-alist))))
257 (replace-space-with-underline (current-time-string))
258 "@" (system-name) "\"")))
260 (let ((hook (cdr (assq major-mode
261 mime/message-before-send-hook-alist))))
263 (let* ((header (rfc822/get-header-string-except
264 mime/message-nuke-headers separator))
265 (orig-header (rfc822/get-header-string-except
266 mime/message-blind-headers separator))
267 (subject (mail-fetch-field "subject"))
268 (total (+ (/ lines mime/message-max-length)
269 (if (> (mod lines mime/message-max-length) 0)
272 (l mime/message-max-length)
273 (the-buf (current-buffer))
274 (buf (get-buffer "*tmp-send*"))
277 (cdr (assq major-mode mime/message-sender-alist))
278 (cdr (assq major-mode mime/message-default-sender-alist))))
280 (goto-char (point-min))
281 (if (re-search-forward (concat "^" (regexp-quote separator) "$")
287 (switch-to-buffer buf)
289 (switch-to-buffer the-buf)
291 (setq buf (get-buffer-create "*tmp-send*"))
293 (switch-to-buffer buf)
294 (make-variable-buffer-local 'mail-header-separator)
295 (setq mail-header-separator separator)
296 (switch-to-buffer the-buf)
297 (goto-char (point-min))
298 (re-search-forward "^$" nil t)
300 (setq buf (get-buffer "*tmp-send*"))
301 (setq data (buffer-substring
307 (switch-to-buffer buf)
310 (format "Subject: %s (%d/%d)\n" subject (+ i 1) total))
312 (format "Mime-Version: 1.0 (split by tm-comp %s)\n"
313 mime/composer-version))
316 "Content-Type: message/partial; id=%s; number=%d; total=%d\n%s\n"
317 id (+ i 1) total separator))
319 (insert orig-header))
322 (call-interactively command))
324 (switch-to-buffer the-buf)
325 (setq l (+ l mime/message-max-length))
330 (cdr (assq major-mode mime/message-after-send-hook-alist))))
332 (set-buffer-modified-p nil)
333 (cond ((y-or-n-p "Kill draft buffer? ")
334 (kill-buffer (current-buffer))
336 (set-window-configuration config))))
340 (defun tm-comp::mime-mode-exit-and-run ()
343 (call-interactively 'mime/split-and-send)
350 (add-hook 'mime-mode-hook
353 (if (not (fboundp 'original::mime-insert-file))
355 (fset 'original::mime-insert-file
356 (symbol-function 'mime-insert-file))
357 (fset 'mime-insert-file 'tm-comp::mime-insert-file)
359 (if (not (fboundp 'original::mime-insert-binary-file))
361 (fset 'original::mime-insert-binary-file
362 (symbol-function 'mime-insert-binary-file))
363 (fset 'mime-insert-binary-file
364 'tm-comp::mime-insert-binary-file)
366 (if (not (fboundp 'original::mime-insert-binary-buffer))
368 (fset 'original::mime-insert-binary-buffer
369 (symbol-function 'mime-insert-binary-buffer))
370 (fset 'mime-insert-binary-buffer
371 'tm-comp::mime-insert-binary-buffer)
373 (if (not (fboundp 'original::mime-mode-exit-and-run))
375 (fset 'original::mime-mode-exit-and-run
376 (symbol-function 'mime-mode-exit-and-run))
377 (fset 'mime-mode-exit-and-run
378 'tm-comp::mime-mode-exit-and-run)
380 (define-key (lookup-key (current-local-map) mime-prefix)
381 "m" 'tm-comp/insert-message)
387 ;; by "OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
388 ;; Mon, 10 Apr 1995 20:03:07 +0900
390 (defvar mime/draft-header-separator-alist
391 '((news-reply-mode . mail-header-separator)
392 (mh-letter-mode . mail-header-separator)
395 (defvar mime::article/draft-header-separator nil)
397 (defun mime/draft-preview ()
399 (let ((sep (assoc-value major-mode mime/draft-header-separator-alist)))
400 (or (stringp sep) (setq sep (eval sep)))
401 (make-variable-buffer-local 'mime::article/draft-header-separator)
402 (goto-char (point-min))
404 (concat "^\\(" (regexp-quote sep) "\\)?$"))
405 (setq mime::article/draft-header-separator
406 (buffer-substring (match-beginning 0) (match-end 0)))
408 (mime/viewer-mode (current-buffer))
409 (pop-to-buffer (current-buffer))
412 (defun mime-viewer::quitting-method/draft-preview ()
413 (let ((mother mime/mother-buffer))
415 (switch-to-buffer mother)
416 (goto-char (point-min))
420 (regexp-quote mime::article/draft-header-separator)
424 (insert mime::article/draft-header-separator)
425 (set-buffer-modified-p (buffer-modified-p))
427 (mime-viewer/kill-buffer)
428 (pop-to-buffer mother)
431 (set-alist 'mime-viewer/quitting-method-alist
433 (function mime-viewer::quitting-method/draft-preview)
436 (set-alist 'mime-viewer/quitting-method-alist
438 (function mime-viewer::quitting-method/draft-preview)
445 (defun rfc822/get-header-string-except (pat boundary)
446 (let ((case-fold-search t))
449 (narrow-to-region (goto-char (point-min))
452 (concat "^\\(" (regexp-quote boundary) "\\)?$")
456 (goto-char (point-min))
458 (while (re-search-forward rfc822/field-top-regexp nil t)
459 (setq field (buffer-substring (match-beginning 0)
462 (if (not (string-match pat field))
463 (setq header (concat header field "\n"))
468 (defun replace-space-with-underline (str)
483 (run-hooks 'tm-comp-load-hook)