The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/bin/perl

use strict;
use warnings;
use 5.010;

use version ; our $VERSION = qv('1.1.2');

use autodie qw(:all);  
no indirect ':fatal';

use Carp;

use VSGDR::UnitTest::TestSet::Test;
use VSGDR::UnitTest::TestSet::Test::TestCondition;
use VSGDR::UnitTest::TestSet::Representation;

use VSGDR::UnitTest::TestSet::Resx;

use Getopt::Euclid qw( :vars<opt_> );
use List::MoreUtils qw{firstidx} ;
use Data::Dumper;
#use Smart::Comments ;
use File::Basename;

my %ValidParserMakeArgs = ( vb  => "NET::VB"
                          , cs  => "NET::CS"
                          , xls => "XLS"
                          , xml => "XML"
                          ) ;
my %ValidParserMakeArgs2 = ( vb  => "NET2::VB"
                           , cs  => "NET2::CS"
                           ) ;                          


### get and validate parameters

our $opt_infile;
our $opt_outfile;
our $opt_version;
our @opt_enable;
our @opt_disable;


croak 'no input file'               unless defined($opt_infile);
croak 'no output file'              unless defined($opt_outfile);

my $version             = $opt_version ;

my $inFile  = $opt_infile ;
my $outFile = $opt_outfile ;

(my $inpfx  = $inFile)  =~ s{^(.*)[.][^.]*$}{$1}smx;
(my $insfx  = $inFile)  =~ s/^.*\.//g;
croak 'Invalid input file'   unless defined $insfx ;
$insfx      = lc $insfx ;

(my $outpfx = $outFile) =~ s{^(.*)[.][^.]*$}{$1}smx;
(my $outsfx = $outFile) =~ s/^.*\.//g;
croak 'Invalid output file'   unless defined $outsfx ;
$outsfx     = lc $outsfx ;

my $outResxFile = "${outpfx}.resx" ;

croak 'Invalid input file'  unless exists $ValidParserMakeArgs{$insfx} ;
croak 'Invalid output file' unless exists $ValidParserMakeArgs{$outsfx} ;

### check output files can be written to 
# yes so it's a race-condition anyway

croak 'Output resource file cannot be written to' unless -f $outResxFile or ! -e $outResxFile ;

### build parsers


my %Parsers            = () ;
$Parsers{${insfx}}     = VSGDR::UnitTest::TestSet::Representation->make( { TYPE => $ValidParserMakeArgs{${insfx}} } );
# if input is in a .net language, add in a .net2 parser to the list
if ( firstidx { $_ eq ${insfx} } ['cs','vb']  != -1 ) {
    $Parsers{"${insfx}2"}  = VSGDR::UnitTest::TestSet::Representation->make( { TYPE => $ValidParserMakeArgs2{${insfx}} } );
}
# if output is needed in ssdt unit test format  add in a .net2 parser to the list
if ($version == 1)  {
    $Parsers{${outsfx}}    = VSGDR::UnitTest::TestSet::Representation->make( { TYPE => $ValidParserMakeArgs{${outsfx}} } );
}
else {
    $Parsers{"${outsfx}2"} = VSGDR::UnitTest::TestSet::Representation->make( { TYPE => $ValidParserMakeArgs2{${outsfx}} } );
}

### build internal representations of input

my $o_resx = VSGDR::UnitTest::TestSet::Resx->new() ;

my $testSet         = undef ;
eval {
    $testSet         = $Parsers{$insfx}->deserialise($inFile);
    } ;
if ( not defined $testSet ) {
    if ( exists $Parsers{"${insfx}2"}) {
        eval {
            $testSet         = $Parsers{$insfx}->deserialise($inFile);
            }
    }            
    else {
        croak 'Parsing failed.'; 
    }
}


my $resx_data       = ''; { $/ = undef ; open (my $aa, "<", "${inpfx}.resx"); $resx_data = <$aa> ; close $aa ;} ; 
my $rh_testScripts  = $o_resx->parse($resx_data) ; 


my $ra_tests        = $testSet->tests() ;

### filter input to output


my $newTestSet = VSGDR::UnitTest::TestSet->new( { NAMESPACE        => $testSet->nameSpace()
                                                 , CLASSNAME        => $testSet->className()
                                                 } 
                                               ) ;
$newTestSet->initializeConditions($testSet->initializeConditions()) ;
$newTestSet->cleanupConditions($testSet->cleanupConditions()) ;
$newTestSet->tests($ra_tests) ;

foreach my $re ( @opt_enable) {
    my $qre = qr{$re} ;
    foreach my $cond ( @{$newTestSet->initializeConditions()} ) {
        if ($cond->Name() =~ m{$qre} ) {
            $cond->conditionEnabled('True')  ;
            say STDERR "Enabled @{[ $cond->conditionName() ]}";
        }
    }
    foreach my $cond ( @{$newTestSet->cleanupConditions()} ) {
        if ($cond->Name() =~ m{$qre} ) {
            $cond->conditionEnabled('True')  ;
            say STDERR "Enabled @{[ $cond->conditionName() ]}";
        }
    }
}
foreach my $re ( @opt_disable) {
    my $qre = qr{$re} ;
    foreach my $cond ( @{$newTestSet->initializeConditions()} ) {
        if ($cond->Name() =~ m{$qre} ) {
            $cond->conditionEnabled('False')  ;
            say STDERR "Disabled @{[ $cond->conditionName() ]}";
        }
    }
    foreach my $cond ( @{$newTestSet->cleanupConditions()} ) {
        if ($cond->Name() =~ m{$qre} ) {
            $cond->conditionEnabled('False')  ;
            say STDERR "Disabled @{[ $cond->conditionName() ]}";
        }
    }
}

foreach my $test (@{$newTestSet->tests()}) {
    foreach my $re ( @opt_enable) {
    my $qre = qr{$re} ;
        foreach my $cond ( @{$test->preTest_conditions()} ) {
            if ($cond->conditionName() =~ m{$qre} ) {
                $cond->conditionEnabled('True')  ;
                say STDERR "Enabled @{[ $cond->conditionName() ]}";
            }
        }
        foreach my $cond ( @{$test->test_conditions()} ) {
            if ($cond->conditionName() =~ m{$qre} ) {
                $cond->conditionEnabled('True')  ;
                say STDERR "Enabled @{[ $cond->conditionName() ]}";
            }
        }
        foreach my $cond ( @{$test->postTest_conditions()} ) {
            if ($cond->conditionName() =~ m{$qre} ) {
                $cond->conditionEnabled('True')  ;
                say STDERR "Enabled @{[ $cond->conditionName() ]}";
            }
        }
    }
    foreach my $re ( @opt_disable) {
    my $qre = qr{$re} ;
        foreach my $cond ( @{$test->preTest_conditions()} ) {
            if ($cond->conditionName() =~ m{$qre} ) {
                $cond->conditionEnabled('False')  ;
                say STDERR "Disabled @{[ $cond->conditionName() ]}";
            }
        }
        foreach my $cond ( @{$test->test_conditions()} ) {
            if ($cond->conditionName() =~ m{$qre} ) {
                $cond->conditionEnabled('False')  ;
                say STDERR "Disabled @{[ $cond->conditionName() ]}";
            }
        }
        foreach my $cond ( @{$test->postTest_conditions()} ) {
            if ($cond->conditionName() =~ m{$qre} ) {
                $cond->conditionEnabled('False')  ;
                say STDERR "Disabled @{[ $cond->conditionName() ]}";
            }
        }
    }
}

unlink $outFile if -f $outFile ;

if ($version == 1)  {
    $Parsers{$outsfx}->serialise($outFile,$newTestSet);
}
else {
    $Parsers{"${outsfx}2"}->serialise($outFile,$newTestSet);
}


my $o_resx_clone   = $o_resx->clone() ;
unlink $outResxFile if -f $outResxFile ;
$o_resx_clone->serialise($outResxFile,$o_resx_clone);

### end

exit ;

END {} 


__END__



=head1 NAME


disableGDRTestCondition.pl - Disable/Enable Test Conditions in a GDR Unit Test file.



=head1 VERSION

1.1.1



=head1 USAGE

disableGDRTestCondition.pl -i <file> -o <file> [options]


=head1 REQUIRED ARGUMENTS


=over


=item  -i[n][file]  [=]<file>

Specify input file

=for Euclid:
    file.type:    readable



=item  -o[ut][file] [=]<file>

Specify output file

=for Euclid:
    file.type:    writable



=back


=head1 OPTIONS

=over


=item  -v[er][sion] [=]<outputversion>

Output version type

=for Euclid:
    outputversion.type:    /[12]/
    outputversion.default:  2


=item  -e[n][able] [=]<enable_re>

Specify condition name to enable ( as perl RE ) 

=for Euclid:
    enable_re.type:    string
    repeatable


=item  -d[is][able] [=]<disable_re>

Specify condition name to disable ( as perl RE ) 

=for Euclid:
    disable_re.type:    string
    repeatable



=back



=head1 AUTHOR

Ded MedVed. 



=head1 BUGS

Hopefully none. 



=head1 COPYRIGHT

Copyright (c) 2012, Ded MedVed. All Rights Reserved. 
This module is free software. It may be used, redistributed 
and/or modified under the terms of the Perl Artistic License 
(see http://www.perl.com/perl/misc/Artistic.html)