#!/usr/bin/perl
##############################################################################
# vs201xfix.pl, version: 1.0.20160318 (c) Cristian Chiru <cristian.chiru@dcsi.eu>
##############################################################################
# This script will add the missing x64 build profiles from the upgraded
# Apache HTTPD projects. It is designed to work with the newer VS project
# formats that are XML based, not the old .dsp.
# You will still need to run "perl srclib\apr\build\lineends.pl --force"
# and "perl srclib\apr\build\cvtdsp.pl -2005", then upgrade the .dsp
# projects in VS 201x before running this script.
##############################################################################

use strict;
use warnings FATAL => 'all';

use XML::Simple qw(:strict);
use Data::Dumper;
use Storable qw( dclone );
use IO::File;
use File::Copy;
use File::Find;

$ARGV[0] //= '-h';
my @SOLUTIONCONF = qw(Release Debug);
my $ARCH = 'x64';

my %GLOBAL_VARS;
$GLOBAL_VARS{'ver'} = substr( $ARGV[0], 1 ) if ($ARGV[0] ne '');
$GLOBAL_VARS{'backup_ext'} = '.~';

if ($GLOBAL_VARS{'ver'} eq '2013') {
    $GLOBAL_VARS{'ext'} = '.vcproj';
    $GLOBAL_VARS{'toolset'} = 'v120';
    find( \&fixVS, '.' );
} elsif ($GLOBAL_VARS{'ver'} eq '2015') {
    $GLOBAL_VARS{'ext'} = '.vcxproj';
    $GLOBAL_VARS{'toolset'} = 'v140';
    find( \&fixVS, '.' );
} elsif ($GLOBAL_VARS{'ver'} eq 'rollback') {
    find( \&rollback, '.' );
} else {
    print "Parameters:\n";
    print "-2013\t Fix Visual Studio 2013 projects !!Not tested yet!!\n";
    print "-2015\t Fix Visual Studio 2015 projects\n";
    print "-source\t Fix the .C/.H source files !!Experimental!!\n";
    print "-rollback\t Restore from backup files\n";
    die "[ERROR] Invalid or missing argument";
}

# Main sub for changing the VC files
sub fixVS {
    my $fname = $_;
    if ($fname =~ m/(?:$GLOBAL_VARS{ext}|\.sln|ApacheMonitor\.r*c|modules\.mk\.win|encoding\.h|Makefile\.win|\.mak)$/) {
        print $File::Find::dir."\\$fname\n";
        # Rollback first the backup, to ensure always have the originals as a starting point. May be removed later on.
        rollback( $fname.$GLOBAL_VARS{'backup_ext'} );
        copy( $fname, $fname.$GLOBAL_VARS{'backup_ext'} ) || die $!;
    }
    # Cleanup cache and generated files
    unlink $fname if ($fname =~ m/\.(suo|sdf|idb|log)$/);

    my $changed;
    # Experimental: try to fix source code for x64 platform
    #    if ($fname =~ m/\.[ch]$/) {
    #        $changed = patchFile ( $fname, [
    #                [ '\b(?:int|unsigned\s+long)\b', '__int64' ],
    #                [ '\blong\s+__int64\b', 'long int' ],
    #                [ '\bunsigned\s+int\b', 'unsigned __int64' ]
    #            ] );
    #    }
    # Fix ApacheMonitor
    if ($fname eq 'ApacheMonitor.c') {
        $changed = patchFile ( $fname, [
                [ '\_setargv\(\);', '//_setargv();' ]
            ] );
    }
    if ($fname eq 'ApacheMonitor.rc') {
        $changed = patchFile ( $fname, [
                [ '^.*ApacheMonitor\.manifest.*$', '' ]
            ] );
    }
    # Fix modules.mk.win to build libapriconv_ces_modules
    if ($fname eq 'modules.mk.win') {
        $changed = patchFile ( $fname, [
                [ '\/Y[cu]iconv\.h', '' ],
                [ $ARCH.'\\\\', '' ]
            ] );
    }
    if ($fname =~ m/(Makefile.win|\.mak)$/) {
        $changed = patchFile ( $fname, [
                [ $ARCH.'\\\\', '' ]
            ] );
    }
    if ($fname eq 'encoding.h') {
        $changed = patchFile ( $fname, [
                [ '(^\s*iconv_t\s+iconv_.*)', sub {"//$1"} ]
            ] );
    }
    # Fix the Solution
    if ($fname =~ m/\.sln$/) {
        $changed = patchSLN( $fname );
    }
    # Fix the projects
    elsif ($fname =~ m/$GLOBAL_VARS{ext}$/) {
        $changed = 0;

        # Perform the preliminary path using simple line by line replace
        my @results = grepFile( $fname, '\|x64' );
        my $rescount = scalar @results;
        # If the project does not containg x64 config
        if ($rescount < 1) {
            $changed = patchFile ( $fname, [
                    [ '\|Win32', '|'.$ARCH ],
                    [ '<(TargetEnvironment|Platform)>Win32', sub {"<$1>$ARCH"} ]
                ] );
        }
        # Still, there are some changes that apply to all projects
        $changed = patchFile ( $fname, [
                [ '<(IntDir|OutDir|TargetName)>.*$', '' ],
                #[ '<(OutputFile)>.*\\\([^<]+)', sub { "<$1>$2"} ],
                [ $ARCH.'\\\\', '' ]
            ] );

        # Parse the xml for advanced editing
        my $xml = XML::Simple->new(
            AttrIndent => 0,
            Cache      => 'memshare',
            ContentKey => '-content',
            ForceArray => 1,
            KeepRoot   => 1,
            KeyAttr    => [ ],
            NoEscape   => 0,
            NoSort     => 1,
            XMLDecl    => '<?xml version="1.0" encoding="utf-8"?>'
        );
        my $data = $xml->XMLin( $fname );
        #print "**DEBUG** ".Dumper($data)."\n";
        patchXML( $data );
        if ($data) {
            my $at_the_end = delete $data->{Project}->[0]->{Import};
            # Output the XML data
            my $parsedxml = $xml->XMLout( $data );
            my $outfile = new IO::File ( $fname, "w" ) || die $!;
            print $outfile $parsedxml;
            undef $outfile;
            # Since XML::Simple does not maintain the order of the elements in the ouput, and OF COURSE that
            # it matters in the VS project files... we have to move the <Import> tags to the end
            postpatchXML( $fname, $at_the_end );
            $changed = 1;
        }
    }

    if ($changed) {
        print "\n\tPrepared for VS $GLOBAL_VARS{'ver'}\n";
    }
    elsif (defined $changed) {
        print "\n\t[NOTHING], deleting backup ... ";
        unlink $fname.$GLOBAL_VARS{'backup_ext'} || die $!;
        print "done.\n";
    }
}

sub patchSLN {
    my ($fname) = @_;
    my @projects;
    my $section = '';
    my $tname = $fname.'.#';
    my $srcfl = new IO::File $fname, "r" || die $!;
    my $dstfl = new IO::File $tname, "w" || die $!;
    # Get first some prerequisite objects
    my $project_deps = "\tProjectSection(ProjectDependencies) = postProject\n";
    for my $ret (grep {/Project\("\{.*\}"\)\s*=\s*"libapr"/} <$srcfl>) {
        $project_deps .= "\t\t$1 = $1\n" if ($ret =~ m/,\s+"({.*})"$/);
    }
    $project_deps .= "\tEndProjectSection\n";
    # Process the file
    seek ( $srcfl, 0, 0 );
    my $canwrite = 1;
    while (my $src = <$srcfl>) {
        my $project_name = '';
        if ($src =~ m/^Project.+?\=\s+"([^"]+)",.*({[^}]+})"$/) {
            $project_name = $1;
            print ".";
            # We exclude some of the projects from solution build - not actually needed?
            #push ( @projects, [ $pguid, (($src !~ m/(?=apr\_dbd\_.|apr\_ldap)/) ? '1' : '0') ] );
            push ( @projects, [ $2, '1' ] );
        }
        if (($src =~ m/= (preSolution|postSolution)$/) && ($src !~ m/GlobalSection\(SolutionProperties\)/)) {
            $section = $1;
        }
        if ($src =~ m/EndGlobalSection$/) {
            $canwrite = 1;
            $section = '';
        }
        if ($canwrite == 1) {
            print $dstfl $src;
            if ($project_name =~ m/((Install|Build)Bin|BuildAll)/) {
                print $dstfl $project_deps;
            }
        } elsif ($canwrite == 2) {
            foreach (@SOLUTIONCONF) {
                print $dstfl "\t\t$_|$ARCH = $_|$ARCH\n";
            }
            $canwrite = 0;
        } elsif ($canwrite == 3) {
            for my $prj (@projects) {
                foreach (@SOLUTIONCONF) {
                    print  $dstfl "\t\t$$prj[0].$_|$ARCH.ActiveCfg = $_|$ARCH\n";
                    print  $dstfl "\t\t$$prj[0].$_|$ARCH.Build.0 = $_|$ARCH\n" if ($$prj[1]);
                }
            }
            $canwrite = 0;
        }
        $canwrite = 2 if (($section eq 'preSolution') && ($canwrite != 0));
        $canwrite = 3 if (($section eq 'postSolution') && ($canwrite != 0));
    }
    undef $srcfl;
    undef $dstfl;
    move ( $tname, $fname );
    return 1;
}

sub patchXML {
    # Set the PlatformToolset
    for my $pg (@{$_[0]->{Project}->[0]->{PropertyGroup}}) {
        if ((($pg->{Label} // '') eq 'Configuration') && (($pg->{PlatformToolset}->[0] // '') ne $GLOBAL_VARS{'toolset'})) {
            $pg->{PlatformToolset}->[0] = $GLOBAL_VARS{'toolset'};
        }
    }

    # Check the $ARCH Platform for all sections in the project file
    toNewArch( $_[0]->{Project}->[0]->{ItemGroup}->[0]->{ProjectConfiguration},
        'Include',
        { '' => [ '',
                {
                    Include  => [ \&regex_replace, [ 'Win32', $ARCH ] ],
                    Platform => [ $ARCH ]
                }
            ]
        }
    );
    toNewArch( $_[0]->{Project}->[0]->{PropertyGroup},
        'Condition',
        { ''      => [ '',
                {
                    Condition => [ \&regex_replace, [ 'Win32', $ARCH ] ]
                }
            ],
            Label => [ 'Configuration',
                {
                    Condition       => [ \&regex_replace, [ 'Win32', $ARCH ] ],
                    PlatformToolset => [ $GLOBAL_VARS{'toolset'} ]
                }
            ]
        }
    );
    toNewArch( $_[0]->{Project}->[0]->{ImportGroup},
        'Condition',
        { Label => [ 'PropertySheets',
                {
                    Condition => [ \&regex_replace, [ 'Win32', $ARCH ] ]
                }
            ]
        } );
    toNewArch( $_[0]->{Project}->[0]->{ItemDefinitionGroup},
        'Condition',
        { ''          => [ '',
                {
                    Condition => [ \&regex_replace, [ 'Win32', $ARCH ] ]
                }
            ],
            ClCompile => [ '',
                {
                    MultiProcessorCompilation => [ 'true' ]
                }
            ]
        } );

    # Adjust the TargetName and output directories in all configurations
    foreach my $sol (@SOLUTIONCONF) {
        for my $itg (@{$_[0]->{Project}->[0]->{ItemDefinitionGroup}}) {
            if ((($itg->{Condition} // '') =~ m/$sol\|$ARCH/i) && (($itg->{Label} // '') eq '')) {
                #$itg->{ClCompile}->[0]->{MultiProcessorCompilation} = [ 'true' ];
                $itg->{ClCompile}->[0]->{DisableSpecificWarnings} = [ '4018;4090;4101;4244;4267;4311;4312;4996' ];
                $itg->{ClCompile}->[0]->{MinimalRebuild} = [ 'true' ];
                my $src = ($itg->{Lib}->[0]->{OutputFile}->[0] // $itg->{Link}->[0]->{OutputFile}->[0]);
                my ($path, $file) = ( $1, $2 ) if (($src // '') =~ m/(.*?)([^\\]+?)(?:\.[^.]*$|$)/);
                for my $pg (@{$_[0]->{Project}->[0]->{PropertyGroup}}) {
                    if ((($pg->{Condition} // '') =~ m/$sol\|$ARCH/i) && (($pg->{Label} // '') eq '')) {
                        $pg->{TargetName} = [ $file ] if (defined $file);
                        $pg->{IntDir} = [ "$path\$(*B)\\" ] if (defined $path);
                        $pg->{OutDir} = [ "$path" ] if (defined $path);
                        print( "." );
                        last;
                    }
                }
                last;
            }
        }
    }
}

sub postpatchXML {
    my ($fname, $elements) = @_;
    open my $in, '<', $fname or die "Can't read old file: $!";
    open my $out, '>', "$fname.#" or die "Can't write new file: $!";
    while( <$in> ) {
        if (m/^<\/Project>$/) {
            for my $element (@$elements) {
                print $out "  <Import Project=\"".$element->{Project}."\" />\n";
                print( "." );
            }
        }
        print $out $_;
    }
    close $out;
    close $in;
    move ( $fname.".#", $fname ) || die $!;
}

sub patchFile {
    my ($fname, $params) = @_;
    my $changed = 0;
    open my $in, '<', $fname or die "Can't read old file: $!";
    open my $out, '>', "$fname.#" or die "Can't write new file: $!";
    while( <$in> ) {
        for my $par (@$params) {
            print Dumper( $par ) if ($fname eq 'libapr.vxproj');
            if (m/@$par[0]/) {
                my $p = @$par[1];
                if (ref( $p ) eq 'CODE') {
                    s/@$par[0]/&$p/eg;
                }
                else {
                    s/@$par[0]/$p/g;
                }
                print ".";
                $changed = 1;
            }
        }
        print $out $_;
    }
    close $out;
    close $in;
    move ( $fname.".#", $fname ) || die $!;
    return $changed;
}

sub toNewArch {
    my ($conf, $main_key, $inout_map) = @_;
    $inout_map //= { '' => [ '', { } ] };
    foreach (@SOLUTIONCONF) {
        while (my ($ioKey, $ioVal) = each %$inout_map) {
            my $newarch_present = 0;
            my $win32conf;
            for my $pc (@$conf) {
                if (($pc->{$ioKey} // '') eq $ioVal->[0]) {
                    $win32conf = $pc if (($pc->{$main_key} // '') =~ m/$_\|Win32/i);
                    $newarch_present = 1 if (($pc->{$main_key} // '') =~ m/$_\|$ARCH/i);
                }
            }
            # Clone the 32 variant if we do not find the new arch
            if (!$newarch_present && $win32conf) {
                my $i = push ( @$conf, dclone( $win32conf ) ) - 1;
                while (my ($k, $v) = each %{$ioVal->[1]}) {
                    #print Dumper (@$conf[$i]->{$k});
                    if ((ref( $v ) eq 'ARRAY') && (ref( $v->[0] ) eq 'CODE')) {
                        # If the first member of the array is ref to a sub,
                        # we pass as first argument the value of the conf and
                        # as 2nd parameter the array containing the sub parameters
                        @$conf[$i]->{$k} = $v->[0]->( @$conf[$i]->{$k}, $v->[1] );
                    } else {
                        @$conf[$i]->{$k} = $v if (@$conf[$i]->{$k});
                    }
                    print ".";
                }
            }
        }
    }
}

sub getValue {
    my ($searchin, $filter, $returnfrom) = @_;
    $filter //= { '' => '' };
    for my $p (@$searchin) {
        while (my ($ioKey, $ioVal) = each %$filter) {

            print "$p = ".Dumper( $p )."\n";
            if (($p->{$ioKey} // '') eq $ioVal) {
                print "HOORAY!\n";
            }
        }
    }
}

sub grepFile {
    my ($fname, $params) = @_;
    open my $in, '<', $fname or die "Can't read old file: $!";
    my @ret = grep {/$params/} <$in>;
    close $in;
    return @ret;
}

sub regex_replace {
    my ($content, $params) = @_;
    $content =~ s/$params->[0]/$params->[1]/;
    return $content;
}


sub rollback {
    my ($fname) = @_;
    $fname //= '';
    if (($fname =~ m/$GLOBAL_VARS{'backup_ext'}$/) && (-e $fname)) {
        $fname =~ s/$GLOBAL_VARS{'backup_ext'}$//;
        print "\tRestoring $fname ... ";
        if (move( $fname.$GLOBAL_VARS{backup_ext}, $fname )) {
            print "done.\n";
        } else {
            print "$!\n";
        }

    }
}