basis/tools/deploy/windows/ico/ico.factor

   1 USING: accessors alien alien.data alien.c-types classes.struct
   2 combinators io.backend kernel locals
   3 math sequences specialized-arrays splitting
   4 windows.kernel32 windows.types ;
   5 IN: tools.deploy.windows.ico
   6
   7 <PRIVATE
   8
   9 STRUCT: ico-header
  10     { Reserved WORD }
  11     { Type WORD }
  12     { ImageCount WORD } ;
  13
  14 STRUCT: ico-directory-entry
  15     { Width        BYTE  }
  16     { Height       BYTE  }
  17     { Colors       BYTE  }
  18     { Reserved     BYTE  }
  19     { Planes       WORD  }
  20     { BitsPerPixel WORD  }
  21     { ImageSize    DWORD }
  22     { ImageOffset  DWORD } ;
  23 SPECIALIZED-ARRAY: ico-directory-entry
  24
  25 STRUCT: group-directory-entry
  26     { Width        BYTE  }
  27     { Height       BYTE  }
  28     { Colors       BYTE  }
  29     { Reserved     BYTE  }
  30     { Planes       WORD  }
  31     { BitsPerPixel WORD  }
  32     { ImageSize    DWORD }
  33     { ImageResourceID WORD } ;
  34
  35 : ico>group-directory-entry ( ico i -- group )
  36     [ {
  37         [ Width>> ] [ Height>> ] [ Colors>> ] [ Reserved>> ]
  38         [ Planes>> ] [ BitsPerPixel>> ] [ ImageSize>> ]
  39     } cleave ] [ 1 + ] bi* group-directory-entry <struct-boa> >c-ptr ; inline
  40
  41 : ico-icon ( directory-entry bytes -- subbytes )
  42     [ [ ImageOffset>> dup ] [ ImageSize>> + ] bi ] dip subseq ; inline
  43
  44 :: ico-group-and-icons ( bytes -- group-bytes icon-bytes )
  45     bytes ico-header memory>struct :> header
  46
  47     ico-header heap-size bytes <displaced-alien>
  48     header ImageCount>> ico-directory-entry <c-direct-array> :> directory
  49
  50     directory dup length iota [ ico>group-directory-entry ] { } 2map-as
  51         :> group-directory
  52     directory [ bytes ico-icon ] { } map-as :> icon-bytes
  53
  54     header clone >c-ptr group-directory concat append
  55     icon-bytes ; inline
  56
  57 ERROR: unsupported-ico-format bytes format ;
  58
  59 : check-ico-type ( bytes -- bytes )
  60     dup "PNG" head? [
  61         "PNG" unsupported-ico-format
  62     ] when
  63     dup B{ 0 0 } head? [
  64         "UNKNOWN" unsupported-ico-format
  65     ] unless ;
  66
  67 PRIVATE>
  68
  69 :: embed-icon-resource ( exe ico-bytes id -- )
  70     exe normalize-path 1 BeginUpdateResource :> hUpdate
  71     hUpdate [
  72         ico-bytes check-ico-type ico-group-and-icons :> ( group icons )
  73         hUpdate RT_GROUP_ICON id 0 group dup byte-length
  74         UpdateResource drop
  75
  76         icons [| icon i |
  77             hUpdate RT_ICON i 1 + MAKEINTRESOURCE 0 icon dup byte-length
  78             UpdateResource drop
  79         ] each-index
  80
  81         hUpdate 0 EndUpdateResource drop
  82     ] when ;