]> gitweb.factorcode.org Git - factor.git/commitdiff
you have to parse the .ico file yourself and update individual RT_ICON and RT_GROUP_I...
authorJoe Groff <arcata@gmail.com>
Mon, 15 Feb 2010 22:04:11 +0000 (14:04 -0800)
committerJoe Groff <arcata@gmail.com>
Mon, 15 Feb 2010 22:04:11 +0000 (14:04 -0800)
basis/tools/deploy/windows/ico/ico.factor [new file with mode: 0755]
basis/tools/deploy/windows/windows.factor [changed mode: 0644->0755]

diff --git a/basis/tools/deploy/windows/ico/ico.factor b/basis/tools/deploy/windows/ico/ico.factor
new file mode 100755 (executable)
index 0000000..8ea7af3
--- /dev/null
@@ -0,0 +1,72 @@
+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
old mode 100644 (file)
new mode 100755 (executable)
index 9df13a9..9f0b228
@@ -5,7 +5,7 @@ io.encodings.ascii kernel namespaces
 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"
@@ -22,17 +22,9 @@ 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*