mason: add timeouts in more places, clean up .dmg creation code

Slava Pestov 2009-05-12 16:52:43 -05:00
parent 5eb3d8e8bd
commit 9e130a5153
6 changed files with 24 additions and 25 deletions

View File

@ -15,7 +15,7 @@ QUALIFIED: continuations
: enter-build-dir ( -- ) build-dir set-current-directory ;
: clone-builds-factor ( -- )
"git" "clone" builds/factor 3array try-output-process ;
"git" "clone" builds/factor 3array short-running-process ;
: begin-build ( -- )
"factor" [ git-id ] with-directory

View File

@ -6,7 +6,7 @@ mason.common mason.config mason.platform namespaces ;
IN: mason.cleanup
: compress ( filename -- )
dup exists? [ "bzip2" swap 2array try-output-process ] [ drop ] if ;
dup exists? [ "bzip2" swap 2array short-running-process ] [ drop ] if ;
: compress-image ( -- )
boot-image-name compress ;

View File

@ -10,25 +10,25 @@ IN: mason.common
SYMBOL: current-git-id
: short-running-process ( command -- )
#! Give network operations and shell commands at most
#! 15 minutes to complete, to catch hangs.
>process
15 minutes >>timeout
+closed+ >>stdin
try-output-process ;
HOOK: really-delete-tree os ( path -- )
M: windows really-delete-tree
#! Workaround: Cygwin GIT creates read-only files for
#! some reason.
[ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix try-output-process ]
[ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix short-running-process ]
[ delete-tree ]
bi ;
M: unix really-delete-tree delete-tree ;
: short-running-process ( command -- )
#! Give network operations at most 15 minutes to complete.
<process>
swap >>command
15 minutes >>timeout
+closed+ >>stdin
try-output-process ;
: retry ( n quot -- )
'[ drop @ f ] attempt-all drop ; inline

View File

@ -6,7 +6,7 @@ IN: mason.help
: make-help-archive ( -- )
"factor/temp" [
{ "tar" "cfz" "docs.tar.gz" "docs" } try-output-process
{ "tar" "cfz" "docs.tar.gz" "docs" } short-running-process
] with-directory ;
: upload-help-archive ( -- )

View File

@ -18,7 +18,7 @@ IN: mason.notify
<process>
_ [ +closed+ ] unless* >>stdin
_ >>command
try-output-process
short-running-process
] retry
] [ 2drop ] if ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators io.directories
USING: arrays combinators locals io.directories
io.directories.hierarchy io.files io.launcher io.pathnames
kernel make mason.common mason.config mason.platform namespaces
prettyprint sequences ;
@ -18,21 +18,20 @@ IN: mason.release.archive
: archive-name ( -- string ) base-name extension append ;
: make-windows-archive ( archive-name -- )
[ "zip" , "-r" , , "factor" , ] { } make try-output-process ;
:: make-windows-archive ( archive-name -- )
{ "zip" "-r" archive-name "factor" } short-running-process ;
:: make-disk-image ( archive-name volume-name dmg-root -- )
{ "hdiutil" "create" "-srcfolder" dmg-root "-fs" "HFS+" "-volname" volume-name archive-name } short-running-process ;
: make-macosx-archive ( archive-name -- )
{ "mkdir" "dmg-root" } try-output-process
{ "cp" "-R" "factor" "dmg-root" } try-output-process
{ "hdiutil" "create"
"-srcfolder" "dmg-root"
"-fs" "HFS+"
"-volname" "factor" }
swap suffix try-output-process
"dmg-root" make-directory
"factor" "dmg-root" copy-tree-into
"factor" "dmg-root" make-disk-image
"dmg-root" really-delete-tree ;
: make-unix-archive ( archive-name -- )
[ "tar" , "-cvzf" , , "factor" , ] { } make try-output-process ;
:: make-unix-archive ( archive-name -- )
{ "tar" "-cvzf" archive-name "factor" } short-running-process ;
: make-archive ( archive-name -- )
target-os get {