extra/windows/version/version.factor

   1 USING:
   2     alien alien.data alien.libraries alien.syntax
   3     destructors formatting io.binary kernel libc locals
   4     math math.bitwise
   5     sequences windows.types
   6 ;
   7
   8 IN: windows.version
   9
  10 << "version" "version.dll" stdcall add-library >>
  11
  12 LIBRARY: version
  13
  14 FUNCTION: DWORD GetFileVersionInfoSizeA (
  15     LPCSTR  lptstrFilename,
  16     LPDWORD lpdwHandle )
  17 FUNCTION: DWORD GetFileVersionInfoSizeW (
  18     LPCWSTR lptstrFilename,
  19     LPDWORD lpdwHandle )
  20 ALIAS: GetFileVersionInfoSize GetFileVersionInfoSizeW
  21
  22 FUNCTION: BOOL GetFileVersionInfoA (
  23     LPCSTR lptstrFilename,
  24     DWORD  dwHandle,
  25     DWORD  dwLen,
  26     LPVOID lpData )
  27 FUNCTION: BOOL GetFileVersionInfoW (
  28     LPCWSTR lptstrFilename,
  29     DWORD  dwHandle,
  30     DWORD  dwLen,
  31     LPVOID lpData )
  32 ALIAS: GetFileVersionInfo GetFileVersionInfoW
  33
  34 FUNCTION: BOOL VerQueryValueA (
  35     LPCVOID pBlock,
  36     LPCSTR  lpSubBlock,
  37     LPVOID  *lplpBuffer,
  38     PUINT   puLen )
  39 FUNCTION: BOOL VerQueryValueW (
  40     LPCVOID pBlock,
  41     LPCSTR  lpSubBlock,
  42     LPVOID  *lplpBuffer,
  43     PUINT   puLen )
  44 ALIAS: VerQueryValue VerQueryValueW
  45
  46 : high-low ( integer -- high low )
  47     [ -16 shift ] [ 16 bits ] [ compose ] keep bi ;
  48
  49 : translation-prefix ( integer -- string )
  50     high-low swap "\\StringFileInfo\\%04x%04x\\" sprintf ;
  51
  52 : version-query ( integer -- string )
  53     translation-prefix "FileVersion" append ;
  54
  55 :: query-dword ( data query -- integer/f )
  56     f LPDWORD <ref> :> result
  57     data query result f VerQueryValue [
  58         result LPDWORD deref 4 memory>byte-array le>
  59     ] [ f ] if ;
  60
  61 :: query-str ( data query -- string/f )
  62     f LPCSTR <ref> :> result
  63     data query result f VerQueryValue [ result LPCSTR deref ] [ f ] if ;
  64
  65 : first-translation ( data -- integer/f )
  66     "\\VarFileInfo\\Translation" query-dword ;
  67
  68 :: (file-version) ( path data-size -- string/f )
  69     f :> res! [
  70         data-size malloc &free :> data
  71         path 0 data-size data GetFileVersionInfo [
  72             data first-translation [
  73                 data swap version-query query-str res!
  74             ] when*
  75         ] when
  76     ] with-destructors res ;
  77
  78 : file-version ( path -- string/f )
  79     dup f GetFileVersionInfoSize dup 0 > [ (file-version) ] [ 2drop f ] if ;