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

diff --git a/extra/mason/build/build.factor b/extra/mason/build/build.factor
index 5031b5d93068e39f3facd95dc5a932091460228f..a9e32e5315faa7712982daf8bf0c105421d104ef 100644 (file)
--- a/extra/mason/build/build.factor
+++ b/extra/mason/build/build.factor
@@ -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

diff --git a/extra/mason/cleanup/cleanup.factor b/extra/mason/cleanup/cleanup.factor
index 3e6209fed0777d0b95cabdd5debd6b531b4a641b..fb8e2e893a1f339e0872692593f48582458b3006 100755 (executable)
--- a/extra/mason/cleanup/cleanup.factor
+++ b/extra/mason/cleanup/cleanup.factor
@@ -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 ;

diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor
index a743c3fe9a4dafbe958a326d89562721897830c7..bc1b182734c5d057c2ffa89918c0460723aceec9 100755 (executable)
--- a/extra/mason/common/common.factor
+++ b/extra/mason/common/common.factor
@@ -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
 

diff --git a/extra/mason/help/help.factor b/extra/mason/help/help.factor
index 9ed9653a081de64787772b717c4b8b7417bf9e89..6b44e49c61c6e9d7595cb38516b3832476987c34 100644 (file)
--- a/extra/mason/help/help.factor
+++ b/extra/mason/help/help.factor
@@ -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 ( -- )

diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor
index 6c643d64d5e04f1d60c26ff259dacd96d7b3c53f..30da0c8286418fd0fef83bd6828462a4e83aab71 100644 (file)
--- a/extra/mason/notify/notify.factor
+++ b/extra/mason/notify/notify.factor
@@ -18,7 +18,7 @@ IN: mason.notify
             <process>
                 _ [ +closed+ ] unless* >>stdin
                 _ >>command
-            try-output-process
+            short-running-process
         ] retry
     ] [ 2drop ] if ;
 

diff --git a/extra/mason/release/archive/archive.factor b/extra/mason/release/archive/archive.factor
index 79d6993a911a0a73f17b739833ed966fb0ac4f5d..51534edccde8c91a1c80e3d875f5afb0e1067bb5 100755 (executable)
--- a/extra/mason/release/archive/archive.factor
+++ b/extra/mason/release/archive/archive.factor
@@ -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 {