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

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