#!/usr/bin/perl -w
#
# Simple program to extract and dump the version information from a PE
+/COFF file
# (mostly for Win32 executables, crude implementation)
#
# I use this program to automagically create ZIP files with the right
# filename depending on the version of the executable packaged in them
+.
# Of course it would be (under Win32) better to question the version A
+PI about
# the file version, but I am lazy and this is even cross-platform like
+ that :)
#
# The whole thing could be made into a module, but again, I wrote this
+ thing as
# a one-off script and only use it in one place...
#
# This code was written for Perl 5.005 and thus dosen't use
# the new (and not completely ironed out) Unicode features
# of Perl 5.6.

sub MakeUnicode {
  my ($S) = @_;
  $S =~ s/(.)/$1\x00/g;
  return $S;
};

sub MakeASCII {
  my ($S) = @_;
  $S =~ s/(.)\x00/$1/g;
  return $S;
};

# This is the routine that actually reads the version information into
+ a hash
sub dumpfile {
  my ($Filename) = @_;
  my $SearchString = "......" . MakeUnicode("StringFileInfo") .
                     "(?:\x00\x00)+((..)..\x00\x00(?:[0-9A-F]\x00)+?(?
+:\x00\x00)+?)". "(.*)";
  my %Result = ();

  open EXE, "< $Filename" or die "Error opening $Filename : $!\n";
  binmode EXE;
  undef $/;
  $ExeData = <EXE>;                        # sluuuuurp
  close EXE;
  if ($ExeData =~ /$SearchString/gms) {
    my ($Crap, $Len, $Info) = ($1,$2,$3);
    undef $ExeData;

    $Len = unpack( "v", $Len );
    $Len = $Len - length( $Crap ) +2;
    $Info = substr( $Info, 0, $Len );

    while ($Info) {
      my $Sublen;

      my ($Next, $Value, $Type) = unpack("vvv", substr( $Info, 0, 6 ))
+;
      $Sublen = $Next - 6;
      while ($Next % 4) { $Next++ };
      last unless $Next;

      my $Item = substr($Info,6,$Sublen);
      my (@Info) = ();
      # Extract the key :
      $Item =~ s/^((?:..)+?)(\x00\x00)+//sm;
      my ($Key) = MakeASCII( $1 );
      while ($Item =~ s/^((?:..)+?)(\x00\x00)+//sm) {
        push @Info, MakeASCII( $1 );
      };
      $Result{$Key} = $Info[0];
      shift @Info;

      if ($Next != length( $Info )) {
        $Info = substr( $Info, $Next );
      } else {
        $Info = "";
      };
    };
  } else {
    print "StringFileInfo not found in $Filename";
  };

  return \%Result;
};

while ($fn = shift) {
  $Data = dumpfile( $fn );
  print $Data->{ProductVersion}
};
[download]