-USING: tools.test system io io.encodings.ascii io.pathnames\r
-io.files io.files.info io.files.temp kernel tools.deploy.config\r
-tools.deploy.config.editor tools.deploy.backend math sequences\r
-io.launcher arrays namespaces continuations layouts accessors\r
-urls math.parser io.directories tools.deploy.test ;\r
-IN: tools.deploy.tests\r
-\r
-[ ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test\r
-\r
-[ ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test\r
-\r
-[ ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test\r
-\r
-[ "staging.math-threads-compiler-ui.image" ] [\r
- "hello-ui" deploy-config\r
- [ bootstrap-profile staging-image-name file-name ] bind\r
-] unit-test\r
-\r
-[ ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test\r
-\r
-[ ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test\r
-\r
-[ ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test\r
-\r
-[ ] [ "terrain" shake-and-bake 1700000 small-enough? ] unit-test\r
-\r
-[ ] [ "gpu.demos.raytrace" shake-and-bake 2500000 small-enough? ] unit-test\r
-\r
-[ ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test\r
-\r
-[ ] [ "gpu.demos.bunny" shake-and-bake 3500000 small-enough? ] unit-test\r
-\r
-os macosx? [\r
- [ ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test\r
-] when\r
-\r
-[ ] [ "benchmark.regex-dna" shake-and-bake 900000 small-enough? ] unit-test\r
-\r
-{\r
- "tools.deploy.test.1"\r
- "tools.deploy.test.2"\r
- "tools.deploy.test.3"\r
- "tools.deploy.test.4"\r
-} [\r
- [ ] swap [\r
- shake-and-bake\r
- run-temp-image\r
- ] curry unit-test\r
-] each\r
-\r
-USING: http.client http.server http.server.dispatchers\r
-http.server.responses http.server.static io.servers.connection ;\r
-\r
-SINGLETON: quit-responder\r
-\r
-M: quit-responder call-responder*\r
- 2drop stop-this-server "Goodbye" "text/html" <content> ;\r
-\r
-: add-quot-responder ( responder -- responder )\r
- quit-responder "quit" add-responder ;\r
-\r
-: test-httpd ( responder -- )\r
- [\r
- main-responder set\r
- <http-server>\r
- 0 >>insecure\r
- f >>secure\r
- dup start-server*\r
- sockets>> first addr>> port>>\r
- dup number>string "resource:temp/port-number" ascii set-file-contents\r
- ] with-scope\r
- "port" set ;\r
-\r
-[ ] [\r
- <dispatcher>\r
- add-quot-responder\r
- "vocab:http/test" <static> >>default\r
-\r
- test-httpd\r
-] unit-test\r
-\r
-[ ] [\r
- "tools.deploy.test.5" shake-and-bake\r
- run-temp-image\r
-] unit-test\r
-\r
-: add-port ( url -- url' )\r
- >url clone "port" get >>port ;\r
-\r
-[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test\r
-\r
-{\r
- "tools.deploy.test.6"\r
- "tools.deploy.test.7"\r
- "tools.deploy.test.9"\r
- "tools.deploy.test.10"\r
- "tools.deploy.test.11"\r
- "tools.deploy.test.12"\r
-} [\r
- [ ] swap [\r
- shake-and-bake\r
- run-temp-image\r
- ] curry unit-test\r
-] each\r
-\r
-os windows? os macosx? or [\r
- [ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test\r
-] when\r
-\r
-os macosx? [\r
- [ ] [ "tools.deploy.test.14" shake-and-bake run-temp-image ] unit-test\r
-] when\r
-\r
-[ { "a" "b" "c" } ] [\r
- "tools.deploy.test.15" shake-and-bake deploy-test-command\r
- { "a" "b" "c" } append\r
- ascii [ lines ] with-process-reader\r
- rest\r
-] unit-test\r
-\r
-[ ] [ "tools.deploy.test.16" shake-and-bake run-temp-image ] unit-test\r
-\r
-[ ] [ "tools.deploy.test.17" shake-and-bake run-temp-image ] unit-test\r
-\r
-[ t ] [\r
- "tools.deploy.test.18" shake-and-bake\r
- deploy-test-command ascii [ readln ] with-process-reader\r
- "test.image" temp-file =\r
-] unit-test\r
+USING: tools.test system io io.encodings.ascii io.pathnames
+io.files io.files.info io.files.temp kernel tools.deploy.config
+tools.deploy.config.editor tools.deploy.backend math sequences
+io.launcher arrays namespaces continuations layouts accessors
+urls math.parser io.directories tools.deploy.test ;
+IN: tools.deploy.tests
+
+[ ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test
+
+[ ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test
+
+[ ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test
+
+[ "staging.math-threads-compiler-ui.image" ] [
+ "hello-ui" deploy-config
+ [ bootstrap-profile staging-image-name file-name ] bind
+] unit-test
+
+[ ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test
+
+[ ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test
+
+[ ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test
+
+[ ] [ "terrain" shake-and-bake 1700000 small-enough? ] unit-test
+
++[ ] [ "gpu.demos.raytrace" shake-and-bake 2500000 small-enough? ] unit-test
++
+[ ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test
+
++[ ] [ "gpu.demos.bunny" shake-and-bake 3500000 small-enough? ] unit-test
++
+os macosx? [
+ [ ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test
+] when
+
+[ ] [ "benchmark.regex-dna" shake-and-bake 900000 small-enough? ] unit-test
+
+{
+ "tools.deploy.test.1"
+ "tools.deploy.test.2"
+ "tools.deploy.test.3"
+ "tools.deploy.test.4"
+} [
+ [ ] swap [
+ shake-and-bake
+ run-temp-image
+ ] curry unit-test
+] each
+
+USING: http.client http.server http.server.dispatchers
+http.server.responses http.server.static io.servers.connection ;
+
+SINGLETON: quit-responder
+
+M: quit-responder call-responder*
+ 2drop stop-this-server "Goodbye" "text/html" <content> ;
+
+: add-quot-responder ( responder -- responder )
+ quit-responder "quit" add-responder ;
+
+: test-httpd ( responder -- )
+ [
+ main-responder set
+ <http-server>
+ 0 >>insecure
+ f >>secure
+ dup start-server*
+ sockets>> first addr>> port>>
+ dup number>string "resource:temp/port-number" ascii set-file-contents
+ ] with-scope
+ "port" set ;
+
+[ ] [
+ <dispatcher>
+ add-quot-responder
+ "vocab:http/test" <static> >>default
+
+ test-httpd
+] unit-test
+
+[ ] [
+ "tools.deploy.test.5" shake-and-bake
+ run-temp-image
+] unit-test
+
+: add-port ( url -- url' )
+ >url clone "port" get >>port ;
+
+[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
+
+{
+ "tools.deploy.test.6"
+ "tools.deploy.test.7"
+ "tools.deploy.test.9"
+ "tools.deploy.test.10"
+ "tools.deploy.test.11"
+ "tools.deploy.test.12"
+} [
+ [ ] swap [
+ shake-and-bake
+ run-temp-image
+ ] curry unit-test
+] each
+
+os windows? os macosx? or [
+ [ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test
+] when
+
+os macosx? [
+ [ ] [ "tools.deploy.test.14" shake-and-bake run-temp-image ] unit-test
+] when
+
+[ { "a" "b" "c" } ] [
+ "tools.deploy.test.15" shake-and-bake deploy-test-command
+ { "a" "b" "c" } append
+ ascii [ lines ] with-process-reader
+ rest
+] unit-test
+
+[ ] [ "tools.deploy.test.16" shake-and-bake run-temp-image ] unit-test
+
+[ ] [ "tools.deploy.test.17" shake-and-bake run-temp-image ] unit-test
+
+[ t ] [
+ "tools.deploy.test.18" shake-and-bake
+ deploy-test-command ascii [ readln ] with-process-reader
+ "test.image" temp-file =
+] unit-test
--- /dev/null
-USING: accessors alien alien.c-types arrays classes.struct combinators\r
-io.backend kernel locals math sequences specialized-arrays\r
-tools.deploy.windows windows.kernel32 windows.types ;\r
-IN: tools.deploy.windows.ico\r
-\r
-<PRIVATE\r
-\r
-STRUCT: ico-header\r
- { Reserved WORD }\r
- { Type WORD }\r
- { ImageCount WORD } ;\r
-\r
-STRUCT: ico-directory-entry\r
- { Width BYTE }\r
- { Height BYTE }\r
- { Colors BYTE }\r
- { Reserved BYTE }\r
- { Planes WORD }\r
- { BitsPerPixel WORD }\r
- { ImageSize DWORD }\r
- { ImageOffset DWORD } ;\r
-SPECIALIZED-ARRAY: ico-directory-entry\r
-\r
-STRUCT: group-directory-entry\r
- { Width BYTE }\r
- { Height BYTE }\r
- { Colors BYTE }\r
- { Reserved BYTE }\r
- { Planes WORD }\r
- { BitsPerPixel WORD }\r
- { ImageSize DWORD }\r
- { ImageResourceID WORD } ;\r
-\r
-: ico>group-directory-entry ( ico i -- group )\r
- [ {\r
- [ Width>> ] [ Height>> ] [ Colors>> ] [ Reserved>> ]\r
- [ Planes>> ] [ BitsPerPixel>> ] [ ImageSize>> ]\r
- } cleave ] [ 1 + ] bi* group-directory-entry <struct-boa> >c-ptr ; inline\r
-\r
-: ico-icon ( directory-entry bytes -- subbytes )\r
- [ [ ImageOffset>> dup ] [ ImageSize>> + ] bi ] dip subseq ; inline\r
-\r
-:: ico-group-and-icons ( bytes -- group-bytes icon-bytes )\r
- bytes ico-header memory>struct :> header\r
-\r
- ico-header heap-size bytes <displaced-alien> \r
- header ImageCount>> <direct-ico-directory-entry-array> :> directory\r
-\r
- directory dup length iota [ ico>group-directory-entry ] { } 2map-as\r
- :> group-directory\r
- directory [ bytes ico-icon ] { } map-as :> icon-bytes\r
-\r
- header clone >c-ptr group-directory concat append\r
- icon-bytes ; inline\r
-\r
-PRIVATE>\r
-\r
-:: embed-icon-resource ( exe ico-bytes id -- )\r
- exe normalize-path 1 BeginUpdateResource :> hUpdate\r
- hUpdate [\r
- ico-bytes ico-group-and-icons :> ( group icons )\r
- hUpdate RT_GROUP_ICON id 0 group dup byte-length\r
- UpdateResource drop\r
-\r
- icons [| icon i |\r
- hUpdate RT_ICON i 1 + MAKEINTRESOURCE 0 icon dup byte-length\r
- UpdateResource drop\r
- ] each-index\r
-\r
- hUpdate 0 EndUpdateResource drop\r
- ] when ;\r
-\r
++USING: accessors alien alien.c-types arrays classes.struct combinators
++io.backend kernel locals math sequences specialized-arrays
++tools.deploy.windows windows.kernel32 windows.types ;
++IN: tools.deploy.windows.ico
++
++<PRIVATE
++
++STRUCT: ico-header
++ { Reserved WORD }
++ { Type WORD }
++ { ImageCount WORD } ;
++
++STRUCT: ico-directory-entry
++ { Width BYTE }
++ { Height BYTE }
++ { Colors BYTE }
++ { Reserved BYTE }
++ { Planes WORD }
++ { BitsPerPixel WORD }
++ { ImageSize DWORD }
++ { ImageOffset DWORD } ;
++SPECIALIZED-ARRAY: ico-directory-entry
++
++STRUCT: group-directory-entry
++ { Width BYTE }
++ { Height BYTE }
++ { Colors BYTE }
++ { Reserved BYTE }
++ { Planes WORD }
++ { BitsPerPixel WORD }
++ { ImageSize DWORD }
++ { ImageResourceID WORD } ;
++
++: ico>group-directory-entry ( ico i -- group )
++ [ {
++ [ Width>> ] [ Height>> ] [ Colors>> ] [ Reserved>> ]
++ [ Planes>> ] [ BitsPerPixel>> ] [ ImageSize>> ]
++ } cleave ] [ 1 + ] bi* group-directory-entry <struct-boa> >c-ptr ; inline
++
++: ico-icon ( directory-entry bytes -- subbytes )
++ [ [ ImageOffset>> dup ] [ ImageSize>> + ] bi ] dip subseq ; inline
++
++:: ico-group-and-icons ( bytes -- group-bytes icon-bytes )
++ bytes ico-header memory>struct :> header
++
++ ico-header heap-size bytes <displaced-alien>
++ header ImageCount>> <direct-ico-directory-entry-array> :> directory
++
++ directory dup length iota [ ico>group-directory-entry ] { } 2map-as
++ :> group-directory
++ directory [ bytes ico-icon ] { } map-as :> icon-bytes
++
++ header clone >c-ptr group-directory concat append
++ icon-bytes ; inline
++
++PRIVATE>
++
++:: embed-icon-resource ( exe ico-bytes id -- )
++ exe normalize-path 1 BeginUpdateResource :> hUpdate
++ hUpdate [
++ ico-bytes ico-group-and-icons :> ( group icons )
++ hUpdate RT_GROUP_ICON id 0 group dup byte-length
++ UpdateResource drop
++
++ icons [| icon i |
++ hUpdate RT_ICON i 1 + MAKEINTRESOURCE 0 icon dup byte-length
++ UpdateResource drop
++ ] each-index
++
++ hUpdate 0 EndUpdateResource drop
++ ] when ;
++
projects / factor.git / commitdiff