Merge branch 'master' of git://factorcode.org/git/factor

extra/builder/builder.factor

@@ -3,68 +3,18 @@ USING: kernel parser io io.files io.launcher io.sockets hashtables math threads
        arrays system continuations namespaces sequences splitting math.parser
        prettyprint tools.time calendar bake vars http.client
        combinators bootstrap.image bootstrap.image.download
-       combinators.cleave benchmark ;
+       combinators.cleave benchmark
+       classes strings quotations words parser-combinators new-slots accessors
+       assocs.lib smtp builder.util ;
 
 IN: builder
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: runtime ( quot -- time ) benchmark nip ;
-
-: minutes>ms ( min -- ms ) 60 * 1000 * ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: builder-recipients
-
-: host-name* ( -- name ) host-name "." split first ;
-
-: tag-subject ( str -- str ) `{ "builder@" ,[ host-name* ] ": " , } concat ;
-
-: email-string ( subject -- )
-  `{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] }
-  [ ] with-process-stream drop ;
-
-: email-file ( subject file -- )
-  `{
-    { +stdin+ , }
-    { +arguments+
-      { "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] } }
-  }
-  >hashtable run-process drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ;
-
-: factor-binary ( -- name )
-  os
-  { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
-    { "winnt" [ "./factor-nt.exe" ] }
-    [ drop "./factor" ] }
-  case ;
-
-: git-pull ( -- desc )
-  {
-    "git"
-    "pull"
-    "--no-summary"
-    "git://factorcode.org/git/factor.git"
-    "master"
-  } ;
-
 : git-clone ( -- desc ) { "git" "clone" "../factor" } ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: datestamp ( -- string )
-  now `{ ,[ dup timestamp-year   ]
-         ,[ dup timestamp-month  ]
-         ,[ dup timestamp-day    ]
-         ,[ dup timestamp-hour   ]
-         ,[     timestamp-minute ] }
-  [ pad-00 ] map "-" join ;
-
 VAR: stamp
 
 : enter-build-dir ( -- )
@@ -82,47 +32,40 @@ VAR: stamp
 
 : make-clean ( -- desc ) { "make" "clean" } ;
 
-: make-vm ( -- )
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  `{
+
-     { +arguments+ { "make" ,[ target ] } }
+: target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ;
-     { +stdout+    "../compile-log" }
+
-     { +stderr+    +stdout+ }
+: make-vm ( -- desc )
-   }
+  <process*>
-  >hashtable ;
+    { "make" target } to-strings >>arguments
+    "../compile-log"             >>stdout
+    +stdout+                     >>stderr
+  >desc ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: factor-binary ( -- name )
+  os
+  { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
+    { "winnt"  [ "./factor-nt.exe" ] }
+    [ drop       "./factor" ] }
+  case ;
+
+: bootstrap-cmd ( -- cmd )
+  { factor-binary [ "-i=" my-boot-image-name append ] "-no-user-init" }
+  to-strings ;
 
 : bootstrap ( -- desc )
-  `{
+  <process*>
-     { +arguments+ {
+    bootstrap-cmd >>arguments
-                     ,[ factor-binary ]
+    "../boot-log" >>stdout
-                     ,[ "-i=" my-boot-image-name append ]
+    +stdout+      >>stderr
-                     "-no-user-init"
+    20 minutes>ms >>timeout
-                   } }
+  >desc ;
-     { +stdout+   "../boot-log" }
-     { +stderr+   +stdout+ }
-     { +timeout+  ,[ 20 minutes>ms ] }
-   } ;
 
-: builder-test ( -- desc ) `{ ,[ factor-binary ] "-run=builder.test" } ;
+: builder-test ( -- desc ) { factor-binary "-run=builder.test" } to-strings ;
   
-SYMBOL: build-status
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: milli-seconds>time ( n -- string )
-  1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
-
-: eval-file ( file -- obj ) <file-reader> contents eval ;
-  
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cat ( file -- ) <file-reader> contents print ;
-
-: run-or-bail ( desc quot -- )
-  [ [ try-process ] curry ]
-  [ [ throw       ] curry ]
-  bi*
-  recover ;
-
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : (build) ( -- )
@@ -180,12 +123,32 @@ SYMBOL: build-status
 
   ] with-file-out ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: builder-recipients
+
+: tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ;
+
 : build ( -- )
   [ (build) ] [ drop ] recover
-  "report" "../report" email-file ;
+  <email>
+    "ed@factorcode.org"     >>from
+    builder-recipients get  >>to
+    "report" tag-subject    >>subject
+    "../report" file>string >>body
+  send ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+: git-pull ( -- desc )
+  {
+    "git"
+    "pull"
+    "--no-summary"
+    "git://factorcode.org/git/factor.git"
+    "master"
+  } ;
+
 : updates-available? ( -- ? )
   git-id
   git-pull run-process drop

extra/builder/server/server.factor

@@ -41,28 +41,28 @@ IN: builder.server
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: build-server ( -- )
+! : build-server ( -- )
-  receive
+!   receive
-  {
+!   {
-    {
+!     {
-      "start"
+!       "start"
-      [
+!       [
-        build-status get "idle" =
+!         build-status get "idle" =
-        build-status get f      =
+!         build-status get f      =
-        or
+!         or
-        [
+!         [
-          [ [ build ] [ drop ] recover "idle" build-status set-global ]
+!           [ [ build ] [ drop ] recover "idle" build-status set-global ]
-          in-thread
+!           in-thread
-        ]
+!         ]
-        when
+!         when
-      ]
+!       ]
-    }
+!     }
 
-    {
+!     {
-      { ?from ?tag "status" }
+!       { ?from ?tag "status" }
-      [ `{ ?tag ,[ build-status get ] } ?from send ]
+!       [ `{ ?tag ,[ build-status get ] } ?from send ]
-    }
+!     }
-  }
+!   }
-  match-cond
+!   match-cond
-  build-server ;
+!   build-server ;
 

extra/builder/test/test.factor

@@ -6,7 +6,7 @@ USING: kernel namespaces sequences assocs builder continuations
        prettyprint
        tools.browser
        tools.test
-       bootstrap.stage2 benchmark ;
+       bootstrap.stage2 benchmark builder.util ;
 
 IN: builder.test
 

extra/builder/util/util.factor

@@ -0,0 +1,82 @@
+
+USING: kernel words namespaces classes parser continuations
+       io io.files io.launcher io.sockets
+       math math.parser
+       combinators sequences splitting quotations arrays strings tools.time
+       parser-combinators accessors assocs.lib
+       combinators.cleave bake calendar new-slots ;
+
+IN: builder.util
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: runtime ( quot -- time ) benchmark nip ;
+
+: minutes>ms ( min -- ms ) 60 * 1000 * ;
+
+: file>string ( file -- string ) [ stdio get contents ] with-file-in ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: to-strings
+
+: to-string ( obj -- str )
+  dup class
+    {
+      { string    [ ] }
+      { quotation [ call ] }
+      { word      [ execute ] }
+      { fixnum    [ number>string ] }
+      { array     [ to-strings concat ] }
+    }
+  case ;
+
+: to-strings ( seq -- str )
+  dup [ string? ] all?
+    [ ]
+    [ [ to-string ] map flatten ]
+  if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: process* arguments stdout stderr timeout ;
+
+: <process*> process* construct-empty ;
+
+: >desc ( process* -- desc )
+  H{ } clone
+    over arguments>> [ +arguments+ swap put-at ] when*
+    over stdout>>    [ +stdout+    swap put-at ] when*
+    over stderr>>    [ +stderr+    swap put-at ] when*
+    over timeout>>   [ +timeout+   swap put-at ] when*
+  nip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: host-name* ( -- name ) host-name "." split first ;
+
+: datestamp ( -- string )
+  now `{ ,[ dup timestamp-year   ]
+         ,[ dup timestamp-month  ]
+         ,[ dup timestamp-day    ]
+         ,[ dup timestamp-hour   ]
+         ,[     timestamp-minute ] }
+  [ pad-00 ] map "-" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: milli-seconds>time ( n -- string )
+  1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
+
+: eval-file ( file -- obj ) <file-reader> contents eval ;
+
+: cat ( file -- ) <file-reader> contents print ;
+
+: run-or-bail ( desc quot -- )
+  [ [ try-process ] curry ]
+  [ [ throw       ] curry ]
+  bi*
+  recover ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+

extra/smtp/smtp.factor

@@ -169,3 +169,15 @@ LOG: smtp-response DEBUG
 ! : cram-md5-auth ( key login  -- )
 !     "AUTH CRAM-MD5\r\n" get-ok 
 !     (cram-md5-auth) "\r\n" append get-ok ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: new-slots
+
+TUPLE: email from to subject body ;
+
+: <email> ( -- email ) email construct-empty ;
+
+: send ( email -- )
+  { email-body email-subject email-to email-from } get-slots
+  send-simple-message ;