# No Shebang. Windows only script.

use strict;
use warnings;
use File::Copy;

# This config script is used to reconfigure a number of perl config files, particularly CPAN's Config.pm, so that they point to the directory structures on my U3 Flash drive.
# Requires U3 commmand prompt which configures a bunch of really useful U3 environment variables.

# Version 0.01: Reconfigures CPAN's Config.pm to the 'local' path.
# Version 0.02: Reconfigures Perl's Config.pm to the local path.
# Version 0.03: Code cleanup. Move a few things to subs. reduced double looping.
# Version 0.04: Reconfigures Config_heavy.pl
# Version 0.05: Now obatains include paths from the INCLUDE environment varaible, oh and some of the real idiot debugging code's gone.
# Version 0.10: Final revised version. Less idiot debugging. more Perly style code. Freezing code until I fix includes etc. for compiling C++ with minGW

my $debug = undef;

# Find, check and nofify U3_DEVICE_PATH
my $u3drive = $ENV{'U3_DEVICE_PATH'} or die "HALT: U3_DEVICE_PATH is empty or undefined!\n";
print "Starting U3 Strawberry Perl configuration on $u3drive\n";

# Set directories
my $strawberry_dir = $u3drive."\\strawberry";
my $perl_dir = $strawberry_dir."\\perl";
my $cpanDir = $strawberry_dir."\\cpan";
my $cpanLibDir = $perl_dir."\\lib\\cpan";
my $cpanBuildDir = $cpanDir."\\build";
my $cpanSourceDir = $cpanDir."\\sources";
my $sysRoot = $ENV{"SYSTEMROOT"};

# include paths
my $strawberry_include = $strawberry_dir."\\c\\include";
my @include = split ";", $ENV{'INCLUDE'};

# lib paths
my $strawberry_lib = $strawberry_dir."\\c\\lib";
my $GTK_lib = $u3drive."\\GTK\\lib";
my $usr_lib = $u3drive."\\usr\\lib";

#Checking those directories are there
for(($strawberry_dir, $perl_dir, $cpanDir, $cpanLibDir, $cpanBuildDir, $cpanSourceDir, $sysRoot, $strawberry_include, $strawberry_lib, $GTK_lib, $usr_lib, @include)){
	-d or die "Error checking the directory $_ ($!)";
}

my $perlConfig = $perl_dir."\\lib\\Config.pm";
print "Reconfiguring Perl, $perlConfig\n";
{ # Closure used to limit scope... and my editor collapses them...
	my @content = load_array($perlConfig);
	backup ($perlConfig);

	open PERLCONFIG, ">", $perlConfig or die "HALT! Could not open $perlConfig ($!)\n";
	$strawberry_dir =~ s/\\/\\\\/g; # need to write \\ instead of \
	for(@content){
		s/.:\\\\strawberry/$strawberry_dir/g;
		print PERLCONFIG;
	}
	$strawberry_dir =~ s/\\\\/\\/g; # change it back
	close PERLCONFIG;
}
print "Done configuring Perl's Config.pm\n";

my $perl_heavy = $perl_dir."\\lib\\Config_heavy.pl";
# Config_heavy.pl is... large ~1200 lines of code and comments,
print "Recongfiguring $perl_heavy\n";
{  # Closure used to limit scope... and my editor collapses them...
	my @content = load_array($perl_heavy);
	backup($perl_heavy);
	open CONFIGHEAVY, ">", $perl_heavy or die "HALT! Could not open $perl_heavy ($!)\n";
	my $heavy_include = join " ", @include;
	for (@content){
		if (/^(glibpth|locincpth|xlibpth)=/){
			s/'.*'/'$heavy_include'/;
		}
		if(/^strings=/){
			my $strings_dir = $strawberry_include."\\string.h";
			s/'.*'/'$strings_dir'/;
		}
		if(/^timeincl=/){
			my $time_dir = $strawberry_include."\\time.h";
			s/'.*'/'$time_dir'/;
		}
		if(/^sysman=/){
			my $sysman_dir = $u3drive."\\usr\\man\\man1";
			s/'.*'/'$sysman_dir'/;
		}
		if(/^loclibpth=/){
			s/'.*'/'$strawberry_lib $GTK_lib $usr_lib'/;
		}
		s!.:(/|\\)strawberry!$strawberry_dir!g;
		print CONFIGHEAVY;
	}
	close CONFIGHEAVY;
}
print "Done configuring Config_heavy.pl\n";

my $cpanConfig = $cpanLibDir."\\Config.pm";
print "Reconfiguring CPAN, $cpanConfig\n";
{ # Closure used to limit scope... and my editor collapses them...
	my @contents = load_array($cpanConfig);
	backup ($cpanConfig);
	# double those \\ to \\\\ for CPAN's Config.pm
	map s/\\/\\\\/g,($strawberry_dir, $perl_dir, $cpanDir, $cpanLibDir, $cpanBuildDir, $cpanSourceDir, $sysRoot, $strawberry_include, $strawberry_lib, $GTK_lib, $usr_lib, @include);
	open CPANCONFIG, ">", $cpanConfig or die "HALT! Could not open $cpanConfig ($!)\n";
	for(@contents){
		if (/build_dir\s/) {
			s/\[.*\]/\[$cpanBuildDir\]/;
		}
		if (/cpan_home\s/){
			s/\[.*\]/\[$cpanDir\]/;
		}
		if (/\sftp\s/){
			s/\[.*\]/\[$sysRoot\\\\system32\\\\ftp.exe\]/;
		}
		if (/histfile\s/){
			s/\[.*\]/\[$cpanDir\\\\histfile\]/;
		}
		if (/keep_source_where\s/){
			s/\[.*\]/\[$cpanSourceDir\]/;
		}
		if (/\smake\s/){
			s/\[.*\]/\[$strawberry_dir\\c\\bin\\dmake.exe\]/;
		}
		if (/make_install_arg\s/){
			s/\[.*\]/\[PREFIX=$perl_dir]/;
		}
		if (/makepl_arg\s/){ #Note: This one might need to be modified further
			my $cpan_include = "-I".join " -I", @include;
			s/\[.*\]/\[PREFIX=$perl_dir LIBS=$strawberry_lib INC="$cpan_include"\]/;
		}
		if (/pager\s/){
			s/\[.*\]/\[$sysRoot\\\\system32\\\\more.com]/;
		}
		if (/prefs_dir\s/){
			s/\[.*\]/\[$cpanDir\\\\prefs]/;
		}
		if (/shell\s/){ # This one probably needs to be changed to use the U3 command prompt
			s/\[.*\]/\[$sysRoot\\\\system32\\\\cmd.exe]/;
		}
		print CPANCONFIG;
	}
	close CPANCONFIG;
	# Undo the doubleup
	map s/\\\\/\\/g,($strawberry_dir, $perl_dir, $cpanDir, $cpanLibDir, $cpanBuildDir, $cpanSourceDir, $sysRoot, $strawberry_include, $strawberry_lib, $GTK_lib, $usr_lib, @include);
}
print "Done configuring CPAN\n";

print "Done configuring U3 Strawberry Perl\n";

# Subroutines only after this

# Returns a files contents in an array. No chomping we need those newlines.
sub load_array{
	my $file_name = shift;
	open THEFILE, "<", $file_name or die "HALT! Could not open $file_name ($!)\n";
	my @content = ();
	push @content, $_ while (<THEFILE>);
	close THEFILE;
	@content;
}

# Back it up! If there is no file appended .orig back it up to there, otherwise back it up to .last
sub backup {
	for my $original (@_){
		my $backup = $original.".orig";
		if (-e $backup){
			$backup = $original.".last";
			print "$backup of original exists, using \"$backup\" instead.\n" if $debug;
		}
		else {
			print "$backup doesn't exist, assuming $original is the original.\n" if $debug;
		}
		unlink $backup; # yes, we don't care if this fails.
		copy $original, $backup or die "HALT! Could not copy to $backup ($!)\n";
		}
	}
}