;;;
;;; tm-comp.el: attachment for MIME composer
;;;
;;; by  MORIOKA Tomohiko <morioka@jaist.ac.jp>
;;; and   OKABE Yasuo    <okabe@kudpc.kyoto-u.ac.jp>
;;; modified by MORITA Masahiro <hiro@isl.ntt.JP>
;;;             MORIOKA Tomohiko,
;;;      Kazushi (Jam) MARUKAWA <kazusi-m@is.aist-nara.ac.jp>,
;;;             OKABE Yasuo,
;;;            KOBAYASHI Shuhei <shuhei@cmpt01.phys.tohoku.ac.jp>,
;;;         and YAMAOKA Katsumi <yamaoka@ga.sony.co.jp>
;;;

(require 'tm-misc)
(require 'tm-view)
(require 'tl-header)
(require 'tl-list)
(require 'mail-utils)


;;; @ version
;;;

(defconst mime/composer-RCS-ID
  "$Id: tm-comp.el,v 6.3 1995/04/18 16:38:42 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
  "\\(^[Cc]ontent-\\|^[Ss]ubject:\\|^[Mm][Ii][Mm][Ee]-[Vv]ersion:\\)")
(defvar mime/message-blind-headers
  "\\(^[BDFbdf][Cc][Cc]:\\|^[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))
			      ))
    (news-reply-mode . (lambda ()
			 (interactive)
			 (widen)
			 (goto-char (point-min))
			 (save-restriction
			   (narrow-to-region
			    (point-min)
			    (progn
			      (goto-char (point-min))
			      (search-forward (concat "\n" mail-header-separator "\n"))
			      (point)))
			   ;; Mail the message too if To: or Cc: exists.
			   (if (or (mail-fetch-field "to" nil t)
				   (mail-fetch-field "cc" nil t))
			       (if gnus-mail-send-method
				   (progn
				     (message
				      (format "Sending (%d/%d) via mail..." (+ i 1) total))
				     (widen)
				     (funcall gnus-mail-send-method)
				     (message
				      (format "Sending (%d/%d) via mail... done" (+ i 1) total))
				 (ding)
				 (message "No mailer defined.  To: and/or Cc: fields ignored.")
				 (sit-for 1)))))
			 (message
			  (format "Posting %d/%d to USENET..." (+ i 1) total))
			 (if (gnus-inews-article)
			     (message 
			      (format "Posting %d/%d to USENET... done" (+ i 1) total))
			   ;; We cannot signal an error.
			   (ding)
			   (message
			    (format "Article %d/%d rejected: %s" (+ i 1) total (gnus-status-message)))
			   (sit-for 3))
			   ))
    ))
		     

(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)
			 ))
    ))

(defvar mime/news-reply-mode-server-running nil)

(defvar mime/message-before-send-hook-alist
  '((mh-letter-mode  . mh-before-send-letter-hook))
    (news-reply-mode . '(lambda ()
			  (let ((case-fold-search nil))
			    (or (boundp 'mime/news-reply-mode-server-running)
				(make-variable-buffer-local 'mime/news-reply-mode-server-running))
			    (setq mime/news-reply-mode-server-running (gnus-server-opened))
			    (save-excursion
			      (gnus-start-server-process)
			      (widen)
			      (goto-char (point-min))
			      (run-hooks 'news-inews-hook)
			      (save-restriction
				(narrow-to-region
				 (point-min)
				 (progn
				   (goto-char (point-min))
				   (search-forward (concat "\n" mail-header-separator "\n"))
				   (point)))
				
				(goto-char (point-min))
				(if (search-forward-regexp "^Newsgroups: +" nil t)
				    (save-restriction
				      (narrow-to-region
				       (point)
				       (if (re-search-forward "^[^ \t]" nil 'end)
					   (match-beginning 0)
					 (point-max)))
				      (goto-char (point-min))
				      (replace-regexp "\n[ \t]+" " ")
				      (goto-char (point-min))
				      (replace-regexp "[ \t\n]*,[ \t\n]*\\|[ \t]+" ",")
				      ))
				))))
		     ))

(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:"))))))
    (news-reply-mode . '(lambda ()
			  (or mime/news-reply-mode-server-running
			      (gnus-close-server))
			  (and (fboundp 'bury-buffer) (bury-buffer))))
    ))

(defvar tm-comp/message-inserter-alist nil)


;;; @ edit
;;;

;; 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
	(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)))
	(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 (eval (cdr (assq major-mode mime/message-before-send-hook-alist)))))
	  (run-hooks 'hook))
	(let* ((header (message/get-header-string-except
		      mime/message-nuke-headers separator))
	       (orig-header (message/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\n"))
	    (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 (eval (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-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 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)
			  ))
      (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 "")
  )


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

(provide 'tm-comp)