$VERSION = 0.2;

$origperl = $^X;
($guiperl = $origperl) =~ s/\w+\.exe$/wperl.exe/i or die "Oooops, how come your perl doesn't have .exe extension?\n";

if (-e $guiperl) {
	print "You already have wperl.exe :-)\n";
} else {
	print "Create the GUI version of this perl? : $origperl (y/N) ";
	exit(0) unless <STDIN> =~ /^y$/i;

	use File::Copy;
	copy $origperl, $guiperl;

	Windoize($guiperl);
}

use Win32::Registry;
die "You have to set up the file extension mapping by hand :-(\n"
 unless \&Win32::Registry::CopyKey;

while (1) {
 print "What extension(s) do you want to map to guiperl? Eg \"gpl ptk\" : ";
 $extensions = <STDIN>;
 chomp $extensions;
 last if $extensions;
}

foreach $extension (split ' ',$extensions) {
 Win32::Registry::SetValues("HKEY_CLASSES_ROOT\\.$extension",
  '' => REG_SZ, 'GUIPerl',
  'Content Type' => REG_SZ, 'text/plain'
 );
}

$PerlType = Win32::Registry::GetValue("HKEY_CLASSES_ROOT\\.pl",'');

if ($PerlType) {
 Win32::Registry::CopyKey("HKEY_CLASSES_ROOT\\$PerlType",'HKEY_CLASSES_ROOT','GUIPerl');
 print "Copied settings for *.pl\n";
 $shell = $HKCR->Open("GUIPerl\\Shell");
 $open = $shell->Open('Open');
 unless ($open) {
  my $default = $shell->GetValue('');
  $open = $shell->Open($default) if $default;
 }
 unless ($open) {
  print "Ooops, your settings for *.pl are broken! I'll fix it.\n";
  $open = $HKCR->Create("$PerlType\\Open");
  $open->SetValues('',REG_SZ,'E&xecute');
  $open->Create('Command')->SetValues('' => REG_SZ, qq{$origperl "%1" %*});
 }
 print "Changing the mapping from perl.exe to guiperl.exe.\n";
 $open = $shell->Create('Open');
 $open->SetValues('',REG_SZ,'E&xecute');
 $open->Create('Command')->SetValues('' => REG_SZ, qq{$guiperl "%1" %*});

 print "Adding \"Execute in GUI\" action to rightclick menu of *.pl.\n";
 $plopen = $HKCR->Create("$PerlType\\Shell\\GUIOpen");
 $plopen->SetValues('',REG_SZ,'Execute in &GUI');
 $plopen->Create('Command')->SetValues('' => REG_SZ, qq{$guiperl "%1" %*});

} else {
 print "You do not have any association for *.pl!?!\n";
 print "OK, I'll do my best.\n";
}

#==========================

sub Windoize {
 my ($record,$magic,$offset,$size);
 open EXE, "+< $_[0]" or die "Cannot open $_[0]: $!";
 binmode EXE;
 read EXE, $record, 32*4;
 ($magic,$offset) = unpack "Sx58L", $record;
 die "Not an MSDOS executable file" unless $magic == 0x5a4d;
 seek EXE, $offset, 0;
 read EXE, $record, 24;
 ($magic,$size) = unpack "Lx16S", $record;
 die "PE header not found" unless $magic == 0x4550;
 die "Optional header not in NT32 format" unless $size == 224;
 seek EXE, $offset+24+68, 0;
 print EXE pack "S", 2;
 close EXE;
}