Permalink
Browse files

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

  • Loading branch information...
1 parent 5eb3d8e commit 9e130a5153390480bf10d75f4317ec1d0192097e Slava Pestov committed May 12, 2009
@@ -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
@@ -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 ;
@@ -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
@@ -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 ( -- )
@@ -18,7 +18,7 @@ IN: mason.notify
<process>
_ [ +closed+ ] unless* >>stdin
_ >>command
- try-output-process
+ short-running-process
] retry
] [ 2drop ] if ;
@@ -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 {

0 comments on commit 9e130a5

Please sign in to comment.