From eca7c0b739ae778e22d54e8e8b537789b964285a Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 14 Feb 2008 00:43:50 -0600 Subject: [PATCH 1/4] builder: bit refactoring --- extra/builder/builder.factor | 101 ++++++++++----------------------- extra/builder/util/util.factor | 82 ++++++++++++++++++++++++++ 2 files changed, 112 insertions(+), 71 deletions(-) create mode 100644 extra/builder/util/util.factor diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index a3e925338f..eb5b6689b0 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -3,45 +3,25 @@ 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* ": " , } bake to-string ; -: 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 ; +: target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ; : factor-binary ( -- name ) os { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] } - { "winnt" [ "./factor-nt.exe" ] } - [ drop "./factor" ] } + { "winnt" [ "./factor-nt.exe" ] } + [ drop "./factor" ] } case ; : git-pull ( -- desc ) @@ -57,14 +37,6 @@ SYMBOL: builder-recipients ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: 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,49 +54,31 @@ VAR: stamp : make-clean ( -- desc ) { "make" "clean" } ; -: make-vm ( -- ) - `{ - { +arguments+ { "make" ,[ target ] } } - { +stdout+ "../compile-log" } - { +stderr+ +stdout+ } - } - >hashtable ; +: make-vm ( -- desc ) + + { "make" target } to-strings >>arguments + "../compile-log" >>stdout + +stdout+ >>stderr + >desc ; + +: bootstrap-cmd ( -- cmd ) + { factor-binary [ "-i=" my-boot-image-name append ] "-no-user-init" } + to-strings ; : bootstrap ( -- desc ) - `{ - { +arguments+ { - ,[ factor-binary ] - ,[ "-i=" my-boot-image-name append ] - "-no-user-init" - } } - { +stdout+ "../boot-log" } - { +stderr+ +stdout+ } - { +timeout+ ,[ 20 minutes>ms ] } - } ; + + bootstrap-cmd >>arguments + "../boot-log" >>stdout + +stdout+ >>stderr + 20 minutes>ms >>timeout + >desc ; -: 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 ) contents eval ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: cat ( file -- ) contents print ; - -: run-or-bail ( desc quot -- ) - [ [ try-process ] curry ] - [ [ throw ] curry ] - bi* - recover ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : (build) ( -- ) enter-build-dir @@ -182,7 +136,12 @@ SYMBOL: build-status : build ( -- ) [ (build) ] [ drop ] recover - "report" "../report" email-file ; + + "ed@factorcode.org" >>from + builder-recipients get >>to + "report" tag-subject >>subject + "../report" file>string >>body + send ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor new file mode 100644 index 0000000000..9917cbd759 --- /dev/null +++ b/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* 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 ) contents eval ; + +: cat ( file -- ) contents print ; + +: run-or-bail ( desc quot -- ) + [ [ try-process ] curry ] + [ [ throw ] curry ] + bi* + recover ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + From 0cc1c0d5972d2a0ba3be8140ca06f70e24e59d4c Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 14 Feb 2008 00:44:09 -0600 Subject: [PATCH 2/4] smtp: Use email object --- extra/smtp/smtp.factor | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 27aac1202e..ce5c114c00 100755 --- a/extra/smtp/smtp.factor +++ b/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 construct-empty ; + +: send ( email -- ) + { email-body email-subject email-to email-from } get-slots + send-simple-message ; \ No newline at end of file From a8cd31311dfb0ca37244c52a95bfa5b15eb71531 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 14 Feb 2008 01:01:09 -0600 Subject: [PATCH 3/4] builder: more tweaks --- extra/builder/builder.factor | 52 ++++++++++++++++-------------- extra/builder/server/server.factor | 46 +++++++++++++------------- 2 files changed, 51 insertions(+), 47 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index eb5b6689b0..1e1cc2778f 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -11,28 +11,6 @@ IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SYMBOL: builder-recipients - -: tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ; - -: target ( -- target ) { os [ cpu "." split ] } to-strings "-" 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" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -54,6 +32,10 @@ VAR: stamp : make-clean ( -- desc ) { "make" "clean" } ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ; + : make-vm ( -- desc ) { "make" target } to-strings >>arguments @@ -61,6 +43,15 @@ VAR: stamp +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 ; @@ -75,8 +66,6 @@ VAR: stamp : builder-test ( -- desc ) { factor-binary "-run=builder.test" } to-strings ; -SYMBOL: build-status - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : (build) ( -- ) @@ -134,6 +123,12 @@ SYMBOL: build-status ] with-file-out ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: builder-recipients + +: tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ; + : build ( -- ) [ (build) ] [ drop ] recover @@ -145,6 +140,15 @@ SYMBOL: build-status ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: git-pull ( -- desc ) + { + "git" + "pull" + "--no-summary" + "git://factorcode.org/git/factor.git" + "master" + } ; + : updates-available? ( -- ? ) git-id git-pull run-process drop diff --git a/extra/builder/server/server.factor b/extra/builder/server/server.factor index 672de1e47d..f3ec349557 100644 --- a/extra/builder/server/server.factor +++ b/extra/builder/server/server.factor @@ -41,28 +41,28 @@ IN: builder.server ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: build-server ( -- ) - receive - { - { - "start" - [ - build-status get "idle" = - build-status get f = - or - [ - [ [ build ] [ drop ] recover "idle" build-status set-global ] - in-thread - ] - when - ] - } +! : build-server ( -- ) +! receive +! { +! { +! "start" +! [ +! build-status get "idle" = +! build-status get f = +! or +! [ +! [ [ build ] [ drop ] recover "idle" build-status set-global ] +! in-thread +! ] +! when +! ] +! } - { - { ?from ?tag "status" } - [ `{ ?tag ,[ build-status get ] } ?from send ] - } - } - match-cond - build-server ; +! { +! { ?from ?tag "status" } +! [ `{ ?tag ,[ build-status get ] } ?from send ] +! } +! } +! match-cond +! build-server ; From ddd2c5b5e7ab6f1df5269ec9aad51f64468dd865 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 14 Feb 2008 01:07:18 -0600 Subject: [PATCH 4/4] builder.test: fix using --- extra/builder/test/test.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index c18395acc9..7412dd9b36 100644 --- a/extra/builder/test/test.factor +++ b/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