From 2840ee474d12191c041f908970a850cde6cc0328 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 27 Jan 2006 22:01:12 +0000
Subject: [PATCH] added a clone operation to the send window

svn: r2005
---
 collects/sirmail/sendr.ss    | 37 +++++++++++++++++++++++++++++-------
 collects/sirmail/sirmailr.ss |  2 +-
 2 files changed, 31 insertions(+), 8 deletions(-)

diff --git a/collects/sirmail/sendr.ss b/collects/sirmail/sendr.ss
index 801e455655..f6dbb075ee 100644
--- a/collects/sirmail/sendr.ss
+++ b/collects/sirmail/sendr.ss
@@ -32,6 +32,7 @@
 	      sirmail:utils^
 	      sirmail:options^
 	      sirmail:read^
+	      (env : sirmail:environment^)
 	      mred^
 	      net:imap^
 	      net:smtp^
@@ -582,7 +583,19 @@
                 [demand-callback (lambda (m)
                                    (send m enable (send enclosure-list get-selected)))])
               enable #f)
-        
+	(instantiate menu-item% ("Clone Message" edit-menu)
+		     [callback (lambda (i e)
+				 (let ([p (open-input-text-editor message-editor)]
+				       [s (make-semaphore)])
+				   (env:start-new-window
+				    (lambda ()
+				      (new-mailer p "" "" "" "" "" 
+						  (map (lambda (i) (send i user-data)) 
+						       (send enclosure-list get-items))
+						  0)
+				      (semaphore-post s)))
+				   (semaphore-wait s)))]
+		     [shortcut #\K])
         
         (add-preferences-menu-items edit-menu)
         
@@ -613,9 +626,19 @@
         
         (send message-editor begin-edit-sequence)
         (if file
-            ;; Resume a composition...
-            (send message-editor load-file file)
-            ;; Build message skeleton
+            ;; Resume/clone a composition...
+	    (begin
+	      (if (port? file)
+		  (send message-editor insert-port file)
+		  (send message-editor load-file file))
+	      (let ([pos (send message-editor
+			       find-string (string-append "\n" SEPARATOR "\n")
+			       'forward 0)])
+		(when pos
+		  (send message-editor set-no-change-region 
+			pos
+			(+ pos 2 (string-length SEPARATOR))))))
+	    ;; Build message skeleton
             (begin
               (send message-editor insert "To: ")
               (send message-editor insert (string-crlf->lf to))
@@ -655,9 +678,9 @@
                           find-named-style
                           (editor:get-default-color-style-name))
                     0 
-                    (send message-editor last-position))
-              (send message-editor clear-undos)))
-        
+                    (send message-editor last-position))))
+
+	(send message-editor clear-undos)
         (send message-editor set-modified #f)
         (send message-editor scroll-to-position 0)
         (send message-editor end-edit-sequence)
diff --git a/collects/sirmail/sirmailr.ss b/collects/sirmail/sirmailr.ss
index c7ef4e27dd..1dc6f09f6d 100644
--- a/collects/sirmail/sirmailr.ss
+++ b/collects/sirmail/sirmailr.ss
@@ -49,6 +49,6 @@
 		  MRED IMAP SMTP HEAD BASE64 MIME QP HIER)]
 	   [SEND : sirmail:send^
 		 (send@
-		  (ENV : (exit-sirmail)) UTILS OPTIONS READ
+		  (ENV : (exit-sirmail)) UTILS OPTIONS READ ENV
 		  MRED IMAP SMTP HEAD BASE64 QP HIER)])
      (export))))