# Created with: ./make_t.pl

# Contents:
#1 lop.lop
#2 switch_plain.def
#3 switch_plain.switch_plain
#4 sot.def
#5 sot.sot
#6 prune.def
#7 align33.def
#8 gnu7.def
#9 gnu7.gnu
#10 git33.def
#11 git33.git33
#12 rt133130.def
#13 rt133130.rt133130
#14 nib.def
#15 nib.nib1
#16 nib.nib2
#17 scbb-csc.def
#18 scbb-csc.scbb-csc
#19 here_long.def

# To locate test #13 you can search for its name or the string '#13'

use strict;
use Test::More;
use Carp;
use Perl::Tidy;
my $rparams;
my $rsources;
my $rtests;

BEGIN {

    ###########################################
    # BEGIN SECTION 1: Parameter combinations #
    ###########################################
    $rparams = {
        'def'   => "",
        'git33' => <<'----------',
-wls='->' -wrs='->'

----------
        'gnu'  => "-gnu",
        'lop'  => "-nlop",
        'nib1' => "-nnib",
        'nib2' => <<'----------',
-nib -nibp='#\+\+'
----------
        'rt133130' => <<'----------',
# only the method should get a csc:
-csc -cscl=sub -sal=method
----------
        'scbb-csc'     => "-scbb -csc",
        'sot'          => "-sot -sct",
        'switch_plain' => "-nola",
    };

    ############################
    # BEGIN SECTION 2: Sources #
    ############################
    $rsources = {

        'align33' => <<'----------',
$wl  = int( $wl * $f + .5 );
$wr  = int( $wr * $f + .5 );
$pag = int( $pageh * $f + .5 );
$fe  = $opt_F ? "t" : "f";
$cf  = $opt_U ? "t" : "f";
$tp  = $opt_t ? "t" : "f";
$rm  = $numbstyle ? "t" : "f";
$pa = $showurl   ? "t" : "f";
$nh = $seq_number ? "t" : "f";
----------

        'git33' => <<'----------',
# test -wls='->' -wrs='->'
use Net::Ping;
my ($ping) = Net::Ping->new();
$ping->ping($host);

----------

        'gnu7' => <<'----------',
# hanging side comments
if ( $seen == 1 ) {    # We're the first word so far to have
    # this abbreviation.
    $hashref->{$abbrev} = $word;
}
elsif ( $seen == 2 ) {    # We're the second word to have this
    # abbreviation, so we can't use it.
    delete $hashref->{$abbrev};
}
else {                    # We're the third word to have this
    # abbreviation, so skip to the next word.
    next WORD;
}
----------

        'here_long' => <<'----------',
# must not break after here target regardless of maximum-line-length
$sth= $dbh->prepare (<<"END_OF_SELECT") or die "Couldn't prepare SQL" ;
    SELECT COUNT(duration),SUM(duration) 
    FROM logins WHERE username='$user'
END_OF_SELECT

----------

        'lop' => <<'----------',
# logical padding examples
$same =
  (      ( $aP eq $bP )
      && ( $aS eq $bS )
      && ( $aT eq $bT )
      && ( $a->{'title'} eq $b->{'title'} )
      && ( $a->{'href'} eq $b->{'href'} ) );

$bits =
    $top > 0xffff ? 32
  : $top > 0xff   ? 16
  : $top > 1      ? 8
  :                 1;

lc( $self->mime_attr('content-type')
        || $self->{MIH_DefaultType}
        || 'text/plain' );

# Padding can also remove spaces; here the space after the '(' is lost:
elsif ( $statement_type =~ /^sub\b/
    || $paren_type[$paren_depth] =~ /^sub\b/ )
----------

        'nib' => <<'----------',
{    #<<<
{    #<<<
{    #++
    print "hello world\n";
}
}
}

{    #++
    {    #++
        {    #<<<
        print "hello world\n";
        }
    }
}

----------

        'prune' => <<'----------',
# some tests for 'sub prune_alignment_tree'

$request->header( 'User-Agent' => $agent )              if $agent;
$request->header( 'From'       => $from )               if $from;
$request->header( 'Range'      => "bytes=0-$max_size" ) if $max_size;

for (
    [ 'CONSTANT', sub { join "foo", "bar" },         0, "bar" ],
    [ 'CONSTANT', sub { join "foo", "bar", 3 },      1, "barfoo3" ],
    [ '$var',     sub { join $_, "bar" },            0, "bar" ],
    [ '$myvar',   sub { my $var; join $var, "bar" }, 0, "bar" ],
);

[
    [ [NewXSHdr],     [ NewXSName, NewXSArgs ],            "XSHdr" ],
    [ [NewXSCHdrs],   [ NewXSName, NewXSArgs, GlobalNew ], "XSCHdrs" ],
    [ [DefSyms],      [StructName],                        "MkDefSyms" ],
    [ [NewXSSymTab],  [ DefSyms, NewXSArgs ],              "AddArgsyms" ],
    [ [NewXSLocals],  [NewXSSymTab],                       "Sym2Loc" ],
    [ [IsAffineFlag], [],                                  sub { return "0" } ],
];

@degen_nums[ 1, 2, 4, 8 ]         = ( 'a', 'c', 'g', 't' );
@degen_nums[ 5, 10, 9, 6, 3, 12 ] = ( 'r', 'y', 'w', 's', 'm', 'k' );
@degen_nums[ 14, 13, 11, 7, 15 ]  = ( 'b', 'd', 'h', 'v', 'n' );

$_CreateFile   = ff( "k32", "CreateFile",   [ P, N, N, N, N, N, N ], N );
$_CloseHandle  = ff( "k32", "CloseHandle",  [N],                     N );
$_GetCommState = ff( "k32", "GetCommState", [ N, P ],                I );
$_SetCommState = ff( "k32", "SetCommState", [ N, P ],                I );
$_SetupComm    = ff( "k32", "SetupComm",    [ N, N, N ],             I );
$_PurgeComm    = ff( "k32", "PurgeComm",    [ N, N ],                I );
$_CreateEvent  = ff( "k32", "CreateEvent",  [ P, I, I, P ],          N );


is_deeply \@t, [

 [3],  [0],  [1],  [0],
 3,   [1],  3,   [1],
 2,   [0],  [1],  [0],
 [1],  [1],  [1],  2,
 3,   [1],  2,   [3],
 4,   [ 7, 8 ],  9,   ["a"],
 "b",  3,   2,   5,
 3,   2,   5,   3,
  [2],    5,      4,      5,
  [ 3, 2, 1 ],  1,      2,      3,
  [ -1, -2, -3 ], [ -1, -2, -3 ], [ -1, -2, -3 ], [ -1, -2 ],
  3,      [ -1, -2 ],   3,      [ -1, -2, -3 ],
  [ !1 ],   [ 8, 7, 6 ],  [ 8, 7, 6 ],  [4],
  !!0,
];
----------

        'rt133130' => <<'----------',
method sum_radlinks {
    my ( $global_radiation_matrix, $local_radiation_matrix, $rngg ) = @_;
    my ( $i, $j, $n1, $n2, $num );
    my $rggij;
    $num = @$rngg;
    for ( $i = 0 ; $i < $num ; $i++ ) {
        $n1 = $rngg->[$i];
        for ( $j = 0 ; $j < $num ; $j++ ) {
            $n2    = $rngg->[$j];
            $rggij = $local_radiation_matrix->[$i][$j];
            if ( $rggij && ( $n1 != $n2 ) ) {
                $global_radiation_matrix->[$n1][$n2] += $rggij;
            }
        }
    }
}
----------

        'scbb-csc' => <<'----------',
sub perlmod_install_advice
{
my(@mod) = @_;
if ($auto_install_cpan) {
require AutoInstall::Tk;
my $r = AutoInstall::Tk::do_autoinstall_tk(@mod);
if ($r > 0) {
for my $mod (@mod) {
warn "Re-require $mod...\n";
eval "require $mod";
die __LINE__ . ": $@" if $@;
}}
} 
else {
my $shell = ($os eq 'win' ? M"Eingabeaufforderung" : M"Shell");
status_message
(
Mfmt(
(
@mod > 1
? "Die fehlenden Perl-Module können aus der %s mit dem Kommando\n"
: "Das fehlende Perl-Modul kann aus der %s mit dem Kommando\n"
),
$shell
)
.
"    perl -MCPAN -e \"install " . join(", ", @mod) . "\"\n" .
"aus dem Internet geholt und installiert werden.\n",
"err"
);
} 
} 

----------

        'sot' => <<'----------',
$opt_c = Text::CSV_XS->new(
{
    binary       => 1, sep_char     => $opt_c, always_quote => 1,
}
);

$c->Tk::bind(
'<Control-f>' => sub {
my ($c) = @_;
my $e = $c->XEvent;
itemsUnderArea $c;
} );

__PACKAGE__->load_components( qw(
PK::Auto
Core
) );
----------

        'switch_plain' => <<'----------',
# run with -nola to keep default from outdenting
use Switch::Plain;
my $r = 'fail';
my $x = int rand 100_000;
nswitch (1 + $x * 2) {
    case $x: {}
    default: {
        $r = 'ok';
    }
}

my @words = qw(cinnamon ginger nutmeg cloves);
my $test = 1;
$r = $test
  ? do {
    sswitch( $words[ rand @words ] ) {
        case $words[0]:
        case $words[1]:
        case $words[2]:
        case $words[3]: { 'ok' }
      default: { 'default case' }
    }
  }
  : 'not ok';
----------
    };

    ####################################
    # BEGIN SECTION 3: Expected output #
    ####################################
    $rtests = {

        'lop.lop' => {
            source => "lop",
            params => "lop",
            expect => <<'#1...........',
# logical padding examples
$same =
  ( ( $aP eq $bP )
      && ( $aS eq $bS )
      && ( $aT eq $bT )
      && ( $a->{'title'} eq $b->{'title'} )
      && ( $a->{'href'} eq $b->{'href'} ) );

$bits =
  $top > 0xffff ? 32
  : $top > 0xff ? 16
  : $top > 1    ? 8
  :               1;

lc( $self->mime_attr('content-type')
      || $self->{MIH_DefaultType}
      || 'text/plain' );

# Padding can also remove spaces; here the space after the '(' is lost:
elsif ( $statement_type =~ /^sub\b/
    || $paren_type[$paren_depth] =~ /^sub\b/ )
#1...........
        },

        'switch_plain.def' => {
            source => "switch_plain",
            params => "def",
            expect => <<'#2...........',
# run with -nola to keep default from outdenting
use Switch::Plain;
my $r = 'fail';
my $x = int rand 100_000;
nswitch( 1 + $x * 2 ) {
    case $x: { }
  default: {
        $r = 'ok';
    }
}

my @words = qw(cinnamon ginger nutmeg cloves);
my $test  = 1;
$r = $test
  ? do {
    sswitch( $words[ rand @words ] ) {
        case $words[0]:
        case $words[1]:
        case $words[2]:
        case $words[3]: { 'ok' }
      default: { 'default case' }
    }
  }
  : 'not ok';
#2...........
        },

        'switch_plain.switch_plain' => {
            source => "switch_plain",
            params => "switch_plain",
            expect => <<'#3...........',
# run with -nola to keep default from outdenting
use Switch::Plain;
my $r = 'fail';
my $x = int rand 100_000;
nswitch( 1 + $x * 2 ) {
    case $x: { }
    default: {
        $r = 'ok';
    }
}

my @words = qw(cinnamon ginger nutmeg cloves);
my $test  = 1;
$r = $test
  ? do {
    sswitch( $words[ rand @words ] ) {
        case $words[0]:
        case $words[1]:
        case $words[2]:
        case $words[3]: { 'ok' }
        default: { 'default case' }
    }
  }
  : 'not ok';
#3...........
        },

        'sot.def' => {
            source => "sot",
            params => "def",
            expect => <<'#4...........',
$opt_c = Text::CSV_XS->new(
    {
        binary       => 1,
        sep_char     => $opt_c,
        always_quote => 1,
    }
);

$c->Tk::bind(
    '<Control-f>' => sub {
        my ($c) = @_;
        my $e = $c->XEvent;
        itemsUnderArea $c;
    }
);

__PACKAGE__->load_components(
    qw(
      PK::Auto
      Core
    )
);
#4...........
        },

        'sot.sot' => {
            source => "sot",
            params => "sot",
            expect => <<'#5...........',
$opt_c = Text::CSV_XS->new( {
    binary       => 1,
    sep_char     => $opt_c,
    always_quote => 1,
} );

$c->Tk::bind(
    '<Control-f>' => sub {
        my ($c) = @_;
        my $e = $c->XEvent;
        itemsUnderArea $c;
    } );

__PACKAGE__->load_components( qw(
      PK::Auto
      Core
) );
#5...........
        },

        'prune.def' => {
            source => "prune",
            params => "def",
            expect => <<'#6...........',
# some tests for 'sub prune_alignment_tree'

$request->header( 'User-Agent' => $agent )              if $agent;
$request->header( 'From'       => $from )               if $from;
$request->header( 'Range'      => "bytes=0-$max_size" ) if $max_size;

for (
    [ 'CONSTANT', sub { join "foo", "bar" },         0, "bar" ],
    [ 'CONSTANT', sub { join "foo", "bar", 3 },      1, "barfoo3" ],
    [ '$var',     sub { join $_, "bar" },            0, "bar" ],
    [ '$myvar',   sub { my $var; join $var, "bar" }, 0, "bar" ],
);

[
    [ [NewXSHdr],     [ NewXSName, NewXSArgs ],            "XSHdr" ],
    [ [NewXSCHdrs],   [ NewXSName, NewXSArgs, GlobalNew ], "XSCHdrs" ],
    [ [DefSyms],      [StructName],                        "MkDefSyms" ],
    [ [NewXSSymTab],  [ DefSyms, NewXSArgs ],              "AddArgsyms" ],
    [ [NewXSLocals],  [NewXSSymTab],                       "Sym2Loc" ],
    [ [IsAffineFlag], [],                                  sub { return "0" } ],
];

@degen_nums[ 1, 2, 4, 8 ]         = ( 'a', 'c', 'g', 't' );
@degen_nums[ 5, 10, 9, 6, 3, 12 ] = ( 'r', 'y', 'w', 's', 'm', 'k' );
@degen_nums[ 14, 13, 11, 7, 15 ]  = ( 'b', 'd', 'h', 'v', 'n' );

$_CreateFile   = ff( "k32", "CreateFile",   [ P, N, N, N, N, N, N ], N );
$_CloseHandle  = ff( "k32", "CloseHandle",  [N],                     N );
$_GetCommState = ff( "k32", "GetCommState", [ N, P ],                I );
$_SetCommState = ff( "k32", "SetCommState", [ N, P ],                I );
$_SetupComm    = ff( "k32", "SetupComm",    [ N, N, N ],             I );
$_PurgeComm    = ff( "k32", "PurgeComm",    [ N, N ],                I );
$_CreateEvent  = ff( "k32", "CreateEvent",  [ P, I, I, P ],          N );

is_deeply \@t, [

    [3],            [0],            [1],            [0],
    3,              [1],            3,              [1],
    2,              [0],            [1],            [0],
    [1],            [1],            [1],            2,
    3,              [1],            2,              [3],
    4,              [ 7, 8 ],       9,              ["a"],
    "b",            3,              2,              5,
    3,              2,              5,              3,
    [2],            5,              4,              5,
    [ 3, 2, 1 ],    1,              2,              3,
    [ -1, -2, -3 ], [ -1, -2, -3 ], [ -1, -2, -3 ], [ -1, -2 ],
    3,              [ -1, -2 ],     3,              [ -1, -2, -3 ],
    [ !1 ],         [ 8, 7, 6 ],    [ 8, 7, 6 ],    [4],
    !!0,
];
#6...........
        },

        'align33.def' => {
            source => "align33",
            params => "def",
            expect => <<'#7...........',
$wl  = int( $wl * $f + .5 );
$wr  = int( $wr * $f + .5 );
$pag = int( $pageh * $f + .5 );
$fe  = $opt_F      ? "t" : "f";
$cf  = $opt_U      ? "t" : "f";
$tp  = $opt_t      ? "t" : "f";
$rm  = $numbstyle  ? "t" : "f";
$pa  = $showurl    ? "t" : "f";
$nh  = $seq_number ? "t" : "f";
#7...........
        },

        'gnu7.def' => {
            source => "gnu7",
            params => "def",
            expect => <<'#8...........',
# hanging side comments
if ( $seen == 1 ) {    # We're the first word so far to have
                       # this abbreviation.
    $hashref->{$abbrev} = $word;
}
elsif ( $seen == 2 ) {    # We're the second word to have this
                          # abbreviation, so we can't use it.
    delete $hashref->{$abbrev};
}
else {    # We're the third word to have this
          # abbreviation, so skip to the next word.
    next WORD;
}
#8...........
        },

        'gnu7.gnu' => {
            source => "gnu7",
            params => "gnu",
            expect => <<'#9...........',
# hanging side comments
if ($seen == 1)
{    # We're the first word so far to have
     # this abbreviation.
    $hashref->{$abbrev} = $word;
}
elsif ($seen == 2)
{    # We're the second word to have this
     # abbreviation, so we can't use it.
    delete $hashref->{$abbrev};
}
else
{    # We're the third word to have this
     # abbreviation, so skip to the next word.
    next WORD;
}
#9...........
        },

        'git33.def' => {
            source => "git33",
            params => "def",
            expect => <<'#10...........',
# test -wls='->' -wrs='->'
use Net::Ping;
my ($ping) = Net::Ping->new();
$ping->ping($host);

#10...........
        },

        'git33.git33' => {
            source => "git33",
            params => "git33",
            expect => <<'#11...........',
# test -wls='->' -wrs='->'
use Net::Ping;
my ($ping) = Net::Ping -> new();
$ping -> ping($host);

#11...........
        },

        'rt133130.def' => {
            source => "rt133130",
            params => "def",
            expect => <<'#12...........',
method sum_radlinks {
    my ( $global_radiation_matrix, $local_radiation_matrix, $rngg ) = @_;
    my ( $i, $j, $n1, $n2, $num );
    my $rggij;
    $num = @$rngg;
    for ( $i = 0 ; $i < $num ; $i++ ) {
        $n1 = $rngg->[$i];
        for ( $j = 0 ; $j < $num ; $j++ ) {
            $n2    = $rngg->[$j];
            $rggij = $local_radiation_matrix->[$i][$j];
            if ( $rggij && ( $n1 != $n2 ) ) {
                $global_radiation_matrix->[$n1][$n2] += $rggij;
            }
        }
    }
}
#12...........
        },

        'rt133130.rt133130' => {
            source => "rt133130",
            params => "rt133130",
            expect => <<'#13...........',
method sum_radlinks {
    my ( $global_radiation_matrix, $local_radiation_matrix, $rngg ) = @_;
    my ( $i, $j, $n1, $n2, $num );
    my $rggij;
    $num = @$rngg;
    for ( $i = 0 ; $i < $num ; $i++ ) {
        $n1 = $rngg->[$i];
        for ( $j = 0 ; $j < $num ; $j++ ) {
            $n2    = $rngg->[$j];
            $rggij = $local_radiation_matrix->[$i][$j];
            if ( $rggij && ( $n1 != $n2 ) ) {
                $global_radiation_matrix->[$n1][$n2] += $rggij;
            }
        }
    }
} ## end sub sum_radlinks
#13...........
        },

        'nib.def' => {
            source => "nib",
            params => "def",
            expect => <<'#14...........',
{ #<<<
{ #<<<
{    #++
    print "hello world\n";
}
}
}

{    #++
    {    #++
        { #<<<
        print "hello world\n";
        }
    }
}

#14...........
        },

        'nib.nib1' => {
            source => "nib",
            params => "nib1",
            expect => <<'#15...........',
{    #<<<
    {    #<<<
        {    #++
            print "hello world\n";
        }
    }
}

{    #++
    {    #++
        {    #<<<
            print "hello world\n";
        }
    }
}

#15...........
        },

        'nib.nib2' => {
            source => "nib",
            params => "nib2",
            expect => <<'#16...........',
{    #<<<
    {    #<<<
        { #++
        print "hello world\n";
        }
    }
}

{ #++
{ #++
{    #<<<
    print "hello world\n";
}
}
}

#16...........
        },

        'scbb-csc.def' => {
            source => "scbb-csc",
            params => "def",
            expect => <<'#17...........',
sub perlmod_install_advice {
    my (@mod) = @_;
    if ($auto_install_cpan) {
        require AutoInstall::Tk;
        my $r = AutoInstall::Tk::do_autoinstall_tk(@mod);
        if ( $r > 0 ) {
            for my $mod (@mod) {
                warn "Re-require $mod...\n";
                eval "require $mod";
                die __LINE__ . ": $@" if $@;
            }
        }
    }
    else {
        my $shell = ( $os eq 'win' ? M "Eingabeaufforderung" : M "Shell" );
        status_message(
            Mfmt(
                (
                    @mod > 1
                    ? "Die fehlenden Perl-Module können aus der %s mit dem Kommando\n"
                    : "Das fehlende Perl-Modul kann aus der %s mit dem Kommando\n"
                ),
                $shell
              )
              . "    perl -MCPAN -e \"install "
              . join( ", ", @mod ) . "\"\n"
              . "aus dem Internet geholt und installiert werden.\n",
            "err"
        );
    }
}

#17...........
        },

        'scbb-csc.scbb-csc' => {
            source => "scbb-csc",
            params => "scbb-csc",
            expect => <<'#18...........',
sub perlmod_install_advice {
    my (@mod) = @_;
    if ($auto_install_cpan) {
        require AutoInstall::Tk;
        my $r = AutoInstall::Tk::do_autoinstall_tk(@mod);
        if ( $r > 0 ) {
            for my $mod (@mod) {
                warn "Re-require $mod...\n";
                eval "require $mod";
                die __LINE__ . ": $@" if $@;
            }
        } ## end if ( $r > 0 )
    } ## end if ($auto_install_cpan)
    else {
        my $shell = ( $os eq 'win' ? M "Eingabeaufforderung" : M "Shell" );
        status_message(
            Mfmt(
                (
                    @mod > 1
                    ? "Die fehlenden Perl-Module können aus der %s mit dem Kommando\n"
                    : "Das fehlende Perl-Modul kann aus der %s mit dem Kommando\n"
                ),
                $shell
              )
              . "    perl -MCPAN -e \"install "
              . join( ", ", @mod ) . "\"\n"
              . "aus dem Internet geholt und installiert werden.\n",
            "err"
        );
    } ## end else [ if ($auto_install_cpan)]
} ## end sub perlmod_install_advice

#18...........
        },

        'here_long.def' => {
            source => "here_long",
            params => "def",
            expect => <<'#19...........',
# must not break after here target regardless of maximum-line-length
$sth = $dbh->prepare(<<"END_OF_SELECT") or die "Couldn't prepare SQL";
    SELECT COUNT(duration),SUM(duration) 
    FROM logins WHERE username='$user'
END_OF_SELECT

#19...........
        },
    };

    my $ntests = 0 + keys %{$rtests};
    plan tests => $ntests;
}

###############
# EXECUTE TESTS
###############

foreach my $key ( sort keys %{$rtests} ) {
    my $output;
    my $sname  = $rtests->{$key}->{source};
    my $expect = $rtests->{$key}->{expect};
    my $pname  = $rtests->{$key}->{params};
    my $source = $rsources->{$sname};
    my $params = defined($pname) ? $rparams->{$pname} : "";
    my $stderr_string;
    my $errorfile_string;
    my $err = Perl::Tidy::perltidy(
        source      => \$source,
        destination => \$output,
        perltidyrc  => \$params,
        argv        => '',             # for safety; hide any ARGV from perltidy
        stderr      => \$stderr_string,
        errorfile   => \$errorfile_string,    # not used when -se flag is set
    );
    if ( $err || $stderr_string || $errorfile_string ) {
        print STDERR "Error output received for test '$key'\n";
        if ($err) {
            print STDERR "An error flag '$err' was returned\n";
            ok( !$err );
        }
        if ($stderr_string) {
            print STDERR "---------------------\n";
            print STDERR "<<STDERR>>\n$stderr_string\n";
            print STDERR "---------------------\n";
            ok( !$stderr_string );
        }
        if ($errorfile_string) {
            print STDERR "---------------------\n";
            print STDERR "<<.ERR file>>\n$errorfile_string\n";
            print STDERR "---------------------\n";
            ok( !$errorfile_string );
        }
    }
    else {
        if ( !is( $output, $expect, $key ) ) {
            my $leno = length($output);
            my $lene = length($expect);
            if ( $leno == $lene ) {
                print STDERR
"#> Test '$key' gave unexpected output.  Strings differ but both have length $leno\n";
            }
            else {
                print STDERR
"#> Test '$key' gave unexpected output.  String lengths differ: output=$leno, expected=$lene\n";
            }
        }
    }
}
