Rename parent-dir to parent-directory, add copy-file and copy-directory words, start Windows deploy tool

core/io/files/files-docs.factor

@@ -7,7 +7,7 @@ ARTICLE: "file-streams" "Reading and writing files"
 { $subsection <file-writer> }
 { $subsection <file-appender> }
 "Pathname manipulation:"
-{ $subsection parent-dir }
+{ $subsection parent-directory }
 { $subsection file-name }
 { $subsection last-path-separator }
 { $subsection path+ }
@@ -101,10 +101,10 @@ HELP: file-modified
 { $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
 { $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ;
 
-HELP: parent-dir
+HELP: parent-directory
 { $values { "path" "a pathname string" } { "parent" "a pathname string" } }
 { $description "Strips the last component off a pathname." }
-{ $examples { $example "USE: io.files" "\"/etc/passwd\" parent-dir print" "/etc" } } ;
+{ $examples { $example "USE: io.files" "\"/etc/passwd\" parent-directory print" "/etc" } } ;
 
 HELP: file-name
 { $values { "path" "a pathname string" } { "string" string } }

core/io/files/files.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: io.files
-USING: io.backend io.files.private hashtables kernel math memory
+USING: io.backend io.files.private io hashtables kernel math
-namespaces sequences strings arrays definitions system
+memory namespaces sequences strings arrays definitions system
 combinators splitting ;
 
 HOOK: <file-reader> io-backend ( path -- stream )
@@ -58,11 +58,14 @@ M: object root-directory? ( path -- ? ) "/" = ;
 
 TUPLE: no-parent-directory path ;
 
-: parent-dir ( path -- parent )
+: no-parent-directory ( path -- * )
+    \ no-parent-directory construct-boa throw ;
+
+: parent-directory ( path -- parent )
     {
         { [ dup root-directory? ] [ ] }
         { [ dup "/\\" split ".." over member? "." rot member? or ]
-            [ \ no-parent-directory construct-boa throw ] }
+            [ no-parent-directory ] }
         { [ t ] [ dup last-path-separator
             [ 1+ head ] [ 2drop "." ] if ] }
     } cond ;
@@ -72,7 +75,7 @@ TUPLE: no-parent-directory path ;
     [ 1+ tail ] [ drop ] if ;
 
 : resource-path ( path -- newpath )
-    \ resource-path get [ image parent-dir ] unless*
+    \ resource-path get [ image parent-directory ] unless*
     swap path+ ;
 
 : ?resource-path ( path -- newpath )
@@ -86,7 +89,7 @@ TUPLE: no-parent-directory path ;
         { [ dup empty? ] [ ] }
         { [ dup exists? ] [ ] }
         { [ t ] [
-            dup parent-dir make-directories
+            dup parent-directory make-directories
             dup make-directory
         ] }
     } cond drop ;
@@ -103,3 +106,18 @@ M: pathname <=> [ pathname-string ] compare ;
         { [ wince? ] [ "" resource-path ] }
         { [ unix? ] [ "HOME" os-env ] }
     } cond ;
+
+: copy-file ( from to -- )
+    dup parent-directory make-directories
+    <file-writer> [
+        stdio get swap
+        <file-reader> [
+            stdio get swap stream-copy
+        ] with-stream
+    ] with-stream ;
+
+: copy-directory ( from to -- )
+    dup make-directories
+    >r dup directory swap r> [
+        >r >r first r> over path+ r> rot path+ copy-file
+    ] 2curry each ;

extra/tools/deploy/config/config-docs.factor

@@ -30,6 +30,11 @@ ARTICLE: "prepare-deploy" "Preparing to deploy an application"
 
 ABOUT: "prepare-deploy"
 
+HELP: deploy-name
+{ $description "Deploy setting. The name of the executable."
+$nl
+"On Mac OS X, this becomes the name of the application bundle, with " { $snippet ".app" } " appended. On Windows, this becomes the name of the directory containing the executable." } ;
+
 HELP: deploy-word-props?
 { $description "Deploy flag. If set, the deploy tool retains all word properties. Otherwise, it applies various heuristics to strip out un-needed word properties from words in the dictionary."
 $nl
@@ -95,8 +100,8 @@ HELP: deploy-reflection
 "The defalut value is 1, no reflection. Programs which use the above features will need to be deployed with a higher level of reflection support." } ;
 
 HELP: default-config
-{ $values { "assoc" assoc } }
+{ $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } }
-{ $description "Outputs the default deployment configuration." } ;
+{ $description "Outputs the default deployment configuration for a vocabulary." } ;
 
 HELP: deploy-config
 { $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } }

extra/tools/deploy/config/config.factor

@@ -1,9 +1,12 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: vocabs.loader io.files io kernel sequences assocs
-splitting parser prettyprint namespaces math ;
+splitting parser prettyprint namespaces math vocabs
+hashtables ;
 IN: tools.deploy.config
 
+SYMBOL: deploy-name
+
 SYMBOL: deploy-ui?
 SYMBOL: deploy-compiler?
 SYMBOL: deploy-math?
@@ -46,8 +49,8 @@ SYMBOL: deploy-c-types?
 SYMBOL: deploy-vm
 SYMBOL: deploy-image
 
-: default-config ( -- assoc )
+: default-config ( vocab -- assoc )
-    V{
+    vocab-name deploy-name associate H{
         { deploy-ui?                f }
         { deploy-io                 2 }
         { deploy-reflection         1 }
@@ -56,15 +59,15 @@ SYMBOL: deploy-image
         { deploy-word-props?        f }
         { deploy-word-defs?         f }
         { deploy-c-types?           f }
-        ! default value for deploy.app
+        ! default value for deploy.macosx
         { "stop-after-last-window?" t }
-    } clone ;
+    } union ;
 
 : deploy-config-path ( vocab -- string )
     vocab-dir "deploy.factor" path+ ;
 
 : deploy-config ( vocab -- assoc )
-    default-config swap
+    dup default-config swap
     dup deploy-config-path vocab-file-contents
     parse-fresh dup empty? [ drop ] [ first union ] if ;
 

extra/tools/deploy/deploy.factor

@@ -49,7 +49,7 @@ IN: tools.deploy
 
         "\"-output-image=" swap "\"" 3append ,
 
-        ! "-no-stack-traces" ,
+        "-no-stack-traces" ,
         
         "-no-user-init" ,
     ] { } make ;
@@ -59,6 +59,10 @@ PRIVATE>
 : deploy* ( vm image vocab config -- )
     deploy-command-line stage2 ;
 
-: deploy ( vocab -- )
+SYMBOL: deploy-implementation
-    "" resource-path cd
+
-    vm over ".image" append rot dup deploy-config deploy* ;
+HOOK: deploy deploy-implementation ( vocab -- )
+
+USE-IF: macosx? tools.deploy.macosx
+
+USE-IF: winnt? tools.deploy.windows

extra/tools/deploy/macosx/macosx.factor

@@ -3,10 +3,7 @@
 USING: io io.files io.launcher kernel namespaces sequences
 system cocoa.plists cocoa.application tools.deploy
 tools.deploy.config assocs hashtables prettyprint ;
-IN: tools.deploy.app
+IN: tools.deploy.macosx
-
-: mkdir ( path -- )
-    "mkdir -p \"" swap "\"" 3append run-process ;
 
 : touch ( path -- )
     "touch \"" swap "\"" 3append run-process ;
@@ -14,22 +11,19 @@ IN: tools.deploy.app
 : rm ( path -- )
     "rm -rf \"" swap "\"" 3append run-process ;
 
-: cp ( from to -- )
+: bundle-dir ( -- dir )
-    "Copying " write over write " to " write dup print
+    vm parent-directory parent-directory ;
-    dup parent-dir mkdir
-    [ "cp -R \"" % swap % "\" \"" % % "\"" % ] "" make
-    run-process ;
 
 : copy-bundle-dir ( name dir -- )
-    vm parent-dir parent-dir over path+ -rot
+    bundle-dir over path+ -rot
-    >r "Contents" path+ r> path+ cp ;
+    >r "Contents" path+ r> path+ copy-directory ;
 
 : copy-vm ( executable bundle-name -- vm )
-    "Contents/MacOS/" path+ swap path+ vm swap [ cp ] keep ;
+    "Contents/MacOS/" path+ swap path+ vm swap [ copy-file ] keep ;
 
 : copy-fonts ( name -- )
     "fonts/" resource-path
-    swap "Contents/Resources/fonts/" path+ cp ;
+    swap "Contents/Resources/fonts/" path+ copy-directory ;
 
 : print-app-plist ( executable bundle-name -- )
     [
@@ -57,16 +51,19 @@ IN: tools.deploy.app
 : deploy.app-image ( vocab bundle-name -- str )
     [ % "/Contents/Resources/" % % ".image" % ] "" make ;
 
-: deploy.app-config ( vocab -- assoc )
+: bundle-name ( -- string )
-    [ ".app" append "bundle-name" associate ] keep
+    deploy-name get ".app" append ;
-    deploy-config union ;
 
-: deploy.app ( vocab -- )
+TUPLE: macosx-deploy-implementation ;
+
+T{ macosx-deploy-implementation } deploy-implementation set-global
+
+M: macosx-deploy-implementation deploy ( vocab -- )
     ".app deploy tool" assert.app
     "." resource-path cd
-    dup deploy.app-config [
+    dup deploy-config [
-        "bundle-name" get rm
+        bundle-name rm
-        [ "bundle-name" get create-app-dir ] keep
+        [ bundle-name create-app-dir ] keep
-        [ "bundle-name" get deploy.app-image ] keep
+        [ bundle-name deploy.app-image ] keep
         namespace
     ] bind deploy* ;

extra/tools/deploy/windows/summary.txt

@@ -0,0 +1 @@
+Deploying minimal stand-alone Windows executables

extra/tools/deploy/windows/tags.txt

@@ -0,0 +1 @@
+tools

extra/tools/deploy/windows/windows.factor

@@ -0,0 +1,41 @@
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.files kernel namespaces sequences system
+tools.deploy tools.deploy.config assocs hashtables prettyprint ;
+IN: tools.deploy.windows
+
+: copy-vm ( executable bundle-name -- vm )
+    swap path+ ".exe" append vm swap [ copy-file ] keep ;
+
+: copy-fonts ( bundle-name -- )
+    "fonts/" resource-path
+    swap "fonts/" path+ copy-directory ;
+
+: copy-dlls ( bundle-name -- )
+    {
+        "freetype6.dll"
+        "zlib1.dll"
+        "factor-nt.dll"
+    } [
+        dup resource-path -rot path+ copy-file
+    ] curry* each ;
+
+: create-exe-dir ( vocab bundle-name -- vm )
+    dup copy-dlls
+    dup copy-fonts
+    copy-vm ;
+
+: image-name ( vocab bundle-name -- str )
+    swap path+ ".image" append ;
+
+TUPLE: windows-deploy-implementation ;
+
+T{ windows-deploy-implementation } deploy-implementation set-global
+
+M: windows-deploy-implementation deploy
+    "." resource-path cd
+    dup deploy-config [
+        [ deploy-name get create-exe-dir ] keep
+        [ deploy-name get image-name ] keep
+        namespace
+    ] bind deploy* ;