Improved deploy tool caches staging images

db4
Slava Pestov 2008-01-29 02:03:06 -06:00
parent cb0d1561c7
commit b0dcb68f70
3 changed files with 54 additions and 29 deletions

View File

@ -9,50 +9,77 @@ quotations io.launcher words.private tools.deploy.config
bootstrap.image ;
IN: tools.deploy.backend
: boot-image-name ( -- string )
"boot." my-arch ".image" 3append ;
: stage1 ( -- )
#! If stage1 image doesn't exist, create one.
boot-image-name resource-path exists?
[ my-arch make-image ] unless ;
: (copy-lines) ( stream -- stream )
dup stream-readln [ print flush (copy-lines) ] when* ;
: copy-lines ( stream -- )
[ (copy-lines) ] [ stream-close ] [ ] cleanup ;
: ?append swap [ append ] [ drop ] if ;
: run-with-output ( descriptor -- )
<process-stream>
dup duplex-stream-out stream-close
copy-lines ;
: profile-string ( config -- string )
: boot-image-name ( -- string )
"boot." my-arch ".image" 3append ;
: make-boot-image ( -- )
#! If stage1 image doesn't exist, create one.
boot-image-name resource-path exists?
[ my-arch make-image ] unless ;
: ?, [ , ] [ drop ] if ;
: bootstrap-profile ( config -- profile )
[
""
deploy-math? get " math" ?append
deploy-compiler? get " compiler" ?append
deploy-ui? get " ui" ?append
native-io? " io" ?append
[
"math" deploy-math? get ?,
"compiler" deploy-compiler? get ?,
"ui" deploy-ui? get ?,
"io" native-io? ?,
] { } make
] bind ;
: deploy-command-line ( vm image vocab config -- vm flags )
: staging-image-name ( profile -- name )
"staging." swap bootstrap-profile "-" join ".image" 3append ;
: staging-command-line ( config -- flags )
[
"-include=" swap profile-string append ,
"-i=" boot-image-name append ,
"-deploy-vocab=" swap append ,
"-output-image=" over staging-image-name append ,
"-output-image=" swap append ,
"-include=" swap bootstrap-profile " " join append ,
"-no-stack-traces" ,
"-no-user-init" ,
] { } make ;
: stage2 ( vm image vocab config -- )
deploy-command-line
>r "-i=" boot-image-name append 2array r> append dup .
<process-stream>
dup duplex-stream-out stream-close
copy-lines ;
: run-factor ( vm flags -- )
dup . swap add* run-with-output ; inline
: make-staging-image ( vm config -- )
staging-command-line run-factor ;
: deploy-command-line ( image vocab config -- flags )
[
"-i=" swap staging-image-name append ,
"-run=tools.deploy.shaker" ,
"-deploy-vocab=" swap append ,
"-output-image=" swap append ,
"-no-stack-traces" ,
] { } make ;
: make-deploy-image ( vm image vocab config -- )
dup staging-image-name exists? [
>r pick r> tuck make-staging-image
] unless
deploy-command-line run-factor ;
SYMBOL: deploy-implementation

View File

@ -72,13 +72,12 @@ T{ macosx-deploy-implementation } deploy-implementation set-global
-> selectFile:inFileViewerRootedAtPath: drop ;
M: macosx-deploy-implementation deploy* ( vocab -- )
stage1
".app deploy tool" assert.app
"." resource-path cd
dup deploy-config [
bundle-name rm
[ bundle-name create-app-dir ] keep
[ bundle-name deploy.app-image ] keep
namespace stage2
namespace make-deploy-image
bundle-name show-in-finder
] bind ;

View File

@ -34,11 +34,10 @@ TUPLE: windows-deploy-implementation ;
T{ windows-deploy-implementation } deploy-implementation set-global
M: windows-deploy-implementation deploy*
stage1
"." resource-path cd
dup deploy-config [
[ deploy-name get create-exe-dir ] keep
[ deploy-name get image-name ] keep
[ namespace stage2 ] keep
[ namespace make-deploy-image ] keep
open-in-explorer
] bind ;