;;;
;;; 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).
;;;

(require 'tm-view)
(require 'tl-822)
(require 'tl-list)
(require 'mail-utils)


;;; @ 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  . (lambda ()
		    (interactive)
		    (sendmail-send-it)
		    ))
    (mh-letter-mode . (lambda (&optional arg)
			(interactive "P")
			(write-region (point-min) (point-max)
				      mime/draft-file-name)
			(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 . (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)
  (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 (<= 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)
	       (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)
		(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))
	  (re-search-forward "^$" nil t)
	  (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 "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)
	    (save-excursion
	      (call-interactively command))
	    (erase-buffer)
	    (switch-to-buffer the-buf)
	    (setq l (+ l mime/message-max-length))
	    (setq i (+ i 1))
	    )
	  )
	(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 '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
		   (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
			 'tm-comp::mime-mode-exit-and-run)
		   ))
	     (define-key (lookup-key (current-local-map) mime-prefix)
	       "m" 'tm-comp/insert-message)
	     )))


;;; @ 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))
      (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
	      (lambda (arg)
		(char-to-string
		 (if (= arg 32)
		     ?_
		   arg)))) str "")
  )


;;; @ end
;;;

(provide 'tm-comp)

(run-hooks 'tm-comp-load-hook)