From 5e247325b27f266d0de711d157dd726071046243 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 16 Aug 2008 17:20:18 -0500
Subject: [PATCH] refactor smtp to not clone the email add email>headers word
 instead

---
 basis/smtp/smtp-tests.factor | 19 ++++-----
 basis/smtp/smtp.factor       | 79 ++++++++++++++++--------------------
 2 files changed, 41 insertions(+), 57 deletions(-)

diff --git a/basis/smtp/smtp-tests.factor b/basis/smtp/smtp-tests.factor
index 5d350d80c4..7cc0e7efbb 100755
--- a/basis/smtp/smtp-tests.factor
+++ b/basis/smtp/smtp-tests.factor
@@ -3,12 +3,6 @@ smtp.server kernel sequences namespaces logging accessors
 assocs sorting ;
 IN: smtp.tests
 
-[ t ] [
-    <email>
-    dup clone "a" "b" set-header drop
-    headers>> assoc-empty?
-] unit-test
-
 { 0 0 } [ [ ] with-smtp-connection ] must-infer-as
 
 [ "hello\nworld" validate-address ] must-fail
@@ -60,12 +54,13 @@ IN: smtp.tests
             "Ed <dharmatech@factorcode.org>"
         } >>to
         "Doug <erg@factorcode.org>" >>from
-    prepare
-    dup headers>> >alist sort-keys [
-        drop { "Date" "Message-Id" } member? not
-    ] assoc-filter
-    over to>>
-    rot from>>
+    [
+        email>headers sort-keys [
+            drop { "Date" "Message-Id" } member? not
+        ] assoc-filter
+    ]
+    [ to>> [ extract-email ] map ]
+    [ from>> extract-email ] tri
 ] unit-test
 
 [ ] [ [ 4321 mock-smtp-server ] "SMTP server" spawn drop ] unit-test
diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor
index 62fd9caab1..7dbb105142 100755
--- a/basis/smtp/smtp.factor
+++ b/basis/smtp/smtp.factor
@@ -23,6 +23,14 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
         call
     ] with-client ; inline
 
+TUPLE: email
+    { from string }
+    { to array }
+    { subject string }
+    { body string } ;
+
+: <email> ( -- email ) email new ;
+
 : crlf ( -- ) "\r\n" write ;
 
 : command ( string -- ) write crlf flush ;
@@ -123,43 +131,12 @@ ERROR: invalid-header-string string ;
     [ invalid-header-string ] unless ;
 
 : write-header ( key value -- )
-    swap
-    validate-header write
-    ": " write
-    validate-header write
-    crlf ;
+    [ validate-header write ]
+    [ ": " write validate-header write ] bi* crlf ;
 
 : write-headers ( assoc -- )
     [ write-header ] assoc-each ;
 
-TUPLE: email
-    { from string }
-    { to array }
-    { subject string }
-    { headers hashtable }
-    { body string } ;
-
-: <email> ( -- email ) email new ;
-
-M: email clone
-    call-next-method [ clone ] change-headers ;
-
-: (send) ( email -- )
-    [
-        helo get-ok
-        dup from>> mail-from get-ok
-        dup to>> [ rcpt-to get-ok ] each
-        data get-ok
-        dup headers>> write-headers
-        crlf
-        body>> send-body get-ok
-        quit get-ok
-    ] with-smtp-connection ;
-
-: extract-email ( recepient -- email )
-    #! This could be much smarter.
-    " " last-split1 swap or "<" ?head drop ">" ?tail drop ;
-
 : message-id ( -- string )
     [
         "<" %
@@ -171,21 +148,33 @@ M: email clone
         ">" %
     ] "" make ;
 
-: set-header ( email value key -- email )
-    pick headers>> set-at ;
+: extract-email ( recepient -- email )
+    #! This could be much smarter.
+    " " last-split1 swap or "<" ?head drop ">" ?tail drop ;
 
-: prepare ( email -- email )
-    clone
-    dup from>> "From" set-header
-    [ extract-email ] change-from
-    dup to>> ", " join "To" set-header
-    [ [ extract-email ] map ] change-to
-    dup subject>> "Subject" set-header
-    now timestamp>rfc822 "Date" set-header
-    message-id "Message-Id" set-header ;
+: email>headers ( email -- hashtable )
+    [
+        [ from>> "From" set ]
+        [ to>> ", " join "To" set ]
+        [ subject>> "Subject" set ] tri
+        now timestamp>rfc822 "Date" set
+        message-id "Message-Id" set
+    ] { } make-assoc ;
+
+: (send-email) ( headers email -- )
+    [
+        helo get-ok
+        dup from>> extract-email mail-from get-ok
+        dup to>> [ extract-email rcpt-to get-ok ] each
+        data get-ok
+        swap write-headers
+        crlf
+        body>> send-body get-ok
+        quit get-ok
+    ] with-smtp-connection ;
 
 : send-email ( email -- )
-    prepare (send) ;
+    [ email>headers ] keep (send-email) ;
 
 ! Dirk's old AUTH CRAM-MD5 code. I don't know anything about
 ! CRAM MD5, and the old code didn't work properly either, so here