Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
35abb02630
|
|
@ -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 ] } }
|
||||
{ +stdout+ "../compile-log" }
|
||||
{ +stderr+ +stdout+ }
|
||||
}
|
||||
>hashtable ;
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ;
|
||||
|
||||
: make-vm ( -- desc )
|
||||
<process*>
|
||||
{ "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 )
|
||||
`{
|
||||
{ +arguments+ {
|
||||
,[ factor-binary ]
|
||||
,[ "-i=" my-boot-image-name append ]
|
||||
"-no-user-init"
|
||||
} }
|
||||
{ +stdout+ "../boot-log" }
|
||||
{ +stderr+ +stdout+ }
|
||||
{ +timeout+ ,[ 20 minutes>ms ] }
|
||||
} ;
|
||||
<process*>
|
||||
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 ) <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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -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 ;
|
||||
Loading…
Reference in New Issue