--- /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
sequences locals system splitting tools.deploy.backend
tools.deploy.config tools.deploy.config.editor assocs hashtables
prettyprint combinators windows.kernel32 windows.shell32 windows.user32
-alien.c-types vocabs.metadata vocabs.loader ;
+alien.c-types vocabs.metadata vocabs.loader tools.deploy.windows.ico ;
IN: tools.deploy.windows
CONSTANT: app-icon-resource-id "APPICON"
dup copy-dll
deploy-ui? get ".exe" ".com" ? copy-vm ;
-:: (embed-ico) ( vm ico-bytes -- )
- vm 0 BeginUpdateResource :> hUpdate
- hUpdate [
- hUpdate RT_ICON app-icon-resource-id 0 ico-bytes dup byte-length
- UpdateResource drop
- hUpdate 0 EndUpdateResource drop
- ] when ;
-
: embed-ico ( vm vocab -- )
dup vocab-windows-icon-path vocab-append-path dup exists?
- [ binary file-contents (embed-ico) ]
+ [ binary file-contents app-icon-resource-id embed-icon-resource ]
[ 2drop ] if ;
M: winnt deploy*