1 # Created with: ./make_t.pl
6 #3 switch_plain.switch_plain
24 # To locate test #13 you can search for its name or the string '#13'
36 ###########################################
37 # BEGIN SECTION 1: Parameter combinations #
38 ###########################################
41 'git33' => <<'----------',
48 'nib2' => <<'----------',
51 'rt133130' => <<'----------',
52 # only the method should get a csc:
53 -csc -cscl=sub -sal=method
55 'scbb-csc' => "-scbb -csc",
57 'switch_plain' => "-nola",
60 ############################
61 # BEGIN SECTION 2: Sources #
62 ############################
65 'align33' => <<'----------',
66 $wl = int( $wl * $f + .5 );
67 $wr = int( $wr * $f + .5 );
68 $pag = int( $pageh * $f + .5 );
69 $fe = $opt_F ? "t" : "f";
70 $cf = $opt_U ? "t" : "f";
71 $tp = $opt_t ? "t" : "f";
72 $rm = $numbstyle ? "t" : "f";
73 $pa = $showurl ? "t" : "f";
74 $nh = $seq_number ? "t" : "f";
77 'git33' => <<'----------',
78 # test -wls='->' -wrs='->'
80 my ($ping) = Net::Ping->new();
85 'gnu7' => <<'----------',
86 # hanging side comments
87 if ( $seen == 1 ) { # We're the first word so far to have
89 $hashref->{$abbrev} = $word;
91 elsif ( $seen == 2 ) { # We're the second word to have this
92 # abbreviation, so we can't use it.
93 delete $hashref->{$abbrev};
95 else { # We're the third word to have this
96 # abbreviation, so skip to the next word.
101 'here_long' => <<'----------',
102 # must not break after here target regardless of maximum-line-length
103 $sth= $dbh->prepare (<<"END_OF_SELECT") or die "Couldn't prepare SQL" ;
104 SELECT COUNT(duration),SUM(duration)
105 FROM logins WHERE username='$user'
110 'lop' => <<'----------',
111 # logical padding examples
116 && ( $a->{'title'} eq $b->{'title'} )
117 && ( $a->{'href'} eq $b->{'href'} ) );
125 lc( $self->mime_attr('content-type')
126 || $self->{MIH_DefaultType}
129 # Padding can also remove spaces; here the space after the '(' is lost:
130 elsif ( $statement_type =~ /^sub\b/
131 || $paren_type[$paren_depth] =~ /^sub\b/ )
134 'nib' => <<'----------',
138 print "hello world\n";
146 print "hello world\n";
153 'prune' => <<'----------',
154 # some tests for 'sub prune_alignment_tree'
156 $request->header( 'User-Agent' => $agent ) if $agent;
157 $request->header( 'From' => $from ) if $from;
158 $request->header( 'Range' => "bytes=0-$max_size" ) if $max_size;
161 [ 'CONSTANT', sub { join "foo", "bar" }, 0, "bar" ],
162 [ 'CONSTANT', sub { join "foo", "bar", 3 }, 1, "barfoo3" ],
163 [ '$var', sub { join $_, "bar" }, 0, "bar" ],
164 [ '$myvar', sub { my $var; join $var, "bar" }, 0, "bar" ],
168 [ [NewXSHdr], [ NewXSName, NewXSArgs ], "XSHdr" ],
169 [ [NewXSCHdrs], [ NewXSName, NewXSArgs, GlobalNew ], "XSCHdrs" ],
170 [ [DefSyms], [StructName], "MkDefSyms" ],
171 [ [NewXSSymTab], [ DefSyms, NewXSArgs ], "AddArgsyms" ],
172 [ [NewXSLocals], [NewXSSymTab], "Sym2Loc" ],
173 [ [IsAffineFlag], [], sub { return "0" } ],
176 @degen_nums[ 1, 2, 4, 8 ] = ( 'a', 'c', 'g', 't' );
177 @degen_nums[ 5, 10, 9, 6, 3, 12 ] = ( 'r', 'y', 'w', 's', 'm', 'k' );
178 @degen_nums[ 14, 13, 11, 7, 15 ] = ( 'b', 'd', 'h', 'v', 'n' );
180 $_CreateFile = ff( "k32", "CreateFile", [ P, N, N, N, N, N, N ], N );
181 $_CloseHandle = ff( "k32", "CloseHandle", [N], N );
182 $_GetCommState = ff( "k32", "GetCommState", [ N, P ], I );
183 $_SetCommState = ff( "k32", "SetCommState", [ N, P ], I );
184 $_SetupComm = ff( "k32", "SetupComm", [ N, N, N ], I );
185 $_PurgeComm = ff( "k32", "PurgeComm", [ N, N ], I );
186 $_CreateEvent = ff( "k32", "CreateEvent", [ P, I, I, P ], N );
196 4, [ 7, 8 ], 9, ["a"],
200 [ 3, 2, 1 ], 1, 2, 3,
201 [ -1, -2, -3 ], [ -1, -2, -3 ], [ -1, -2, -3 ], [ -1, -2 ],
202 3, [ -1, -2 ], 3, [ -1, -2, -3 ],
203 [ !1 ], [ 8, 7, 6 ], [ 8, 7, 6 ], [4],
208 'rt133130' => <<'----------',
209 method sum_radlinks {
210 my ( $global_radiation_matrix, $local_radiation_matrix, $rngg ) = @_;
211 my ( $i, $j, $n1, $n2, $num );
214 for ( $i = 0 ; $i < $num ; $i++ ) {
216 for ( $j = 0 ; $j < $num ; $j++ ) {
218 $rggij = $local_radiation_matrix->[$i][$j];
219 if ( $rggij && ( $n1 != $n2 ) ) {
220 $global_radiation_matrix->[$n1][$n2] += $rggij;
227 'scbb-csc' => <<'----------',
228 sub perlmod_install_advice
231 if ($auto_install_cpan) {
232 require AutoInstall::Tk;
233 my $r = AutoInstall::Tk::do_autoinstall_tk(@mod);
236 warn "Re-require $mod...\n";
238 die __LINE__ . ": $@" if $@;
242 my $shell = ($os eq 'win' ? M"Eingabeaufforderung" : M"Shell");
248 ? "Die fehlenden Perl-Module können aus der %s mit dem Kommando\n"
249 : "Das fehlende Perl-Modul kann aus der %s mit dem Kommando\n"
254 " perl -MCPAN -e \"install " . join(", ", @mod) . "\"\n" .
255 "aus dem Internet geholt und installiert werden.\n",
263 'sot' => <<'----------',
264 $opt_c = Text::CSV_XS->new(
266 binary => 1, sep_char => $opt_c, always_quote => 1,
271 '<Control-f>' => sub {
277 __PACKAGE__->load_components( qw(
283 'switch_plain' => <<'----------',
284 # run with -nola to keep default from outdenting
287 my $x = int rand 100_000;
288 nswitch (1 + $x * 2) {
295 my @words = qw(cinnamon ginger nutmeg cloves);
299 sswitch( $words[ rand @words ] ) {
303 case $words[3]: { 'ok' }
304 default: { 'default case' }
311 ####################################
312 # BEGIN SECTION 3: Expected output #
313 ####################################
319 expect => <<'#1...........',
320 # logical padding examples
325 && ( $a->{'title'} eq $b->{'title'} )
326 && ( $a->{'href'} eq $b->{'href'} ) );
334 lc( $self->mime_attr('content-type')
335 || $self->{MIH_DefaultType}
338 # Padding can also remove spaces; here the space after the '(' is lost:
339 elsif ( $statement_type =~ /^sub\b/
340 || $paren_type[$paren_depth] =~ /^sub\b/ )
344 'switch_plain.def' => {
345 source => "switch_plain",
347 expect => <<'#2...........',
348 # run with -nola to keep default from outdenting
351 my $x = int rand 100_000;
352 nswitch( 1 + $x * 2 ) {
359 my @words = qw(cinnamon ginger nutmeg cloves);
363 sswitch( $words[ rand @words ] ) {
367 case $words[3]: { 'ok' }
368 default: { 'default case' }
375 'switch_plain.switch_plain' => {
376 source => "switch_plain",
377 params => "switch_plain",
378 expect => <<'#3...........',
379 # run with -nola to keep default from outdenting
382 my $x = int rand 100_000;
383 nswitch( 1 + $x * 2 ) {
390 my @words = qw(cinnamon ginger nutmeg cloves);
394 sswitch( $words[ rand @words ] ) {
398 case $words[3]: { 'ok' }
399 default: { 'default case' }
409 expect => <<'#4...........',
410 $opt_c = Text::CSV_XS->new(
419 '<Control-f>' => sub {
426 __PACKAGE__->load_components(
438 expect => <<'#5...........',
439 $opt_c = Text::CSV_XS->new( {
446 '<Control-f>' => sub {
452 __PACKAGE__->load_components( qw(
462 expect => <<'#6...........',
463 # some tests for 'sub prune_alignment_tree'
465 $request->header( 'User-Agent' => $agent ) if $agent;
466 $request->header( 'From' => $from ) if $from;
467 $request->header( 'Range' => "bytes=0-$max_size" ) if $max_size;
470 [ 'CONSTANT', sub { join "foo", "bar" }, 0, "bar" ],
471 [ 'CONSTANT', sub { join "foo", "bar", 3 }, 1, "barfoo3" ],
472 [ '$var', sub { join $_, "bar" }, 0, "bar" ],
473 [ '$myvar', sub { my $var; join $var, "bar" }, 0, "bar" ],
477 [ [NewXSHdr], [ NewXSName, NewXSArgs ], "XSHdr" ],
478 [ [NewXSCHdrs], [ NewXSName, NewXSArgs, GlobalNew ], "XSCHdrs" ],
479 [ [DefSyms], [StructName], "MkDefSyms" ],
480 [ [NewXSSymTab], [ DefSyms, NewXSArgs ], "AddArgsyms" ],
481 [ [NewXSLocals], [NewXSSymTab], "Sym2Loc" ],
482 [ [IsAffineFlag], [], sub { return "0" } ],
485 @degen_nums[ 1, 2, 4, 8 ] = ( 'a', 'c', 'g', 't' );
486 @degen_nums[ 5, 10, 9, 6, 3, 12 ] = ( 'r', 'y', 'w', 's', 'm', 'k' );
487 @degen_nums[ 14, 13, 11, 7, 15 ] = ( 'b', 'd', 'h', 'v', 'n' );
489 $_CreateFile = ff( "k32", "CreateFile", [ P, N, N, N, N, N, N ], N );
490 $_CloseHandle = ff( "k32", "CloseHandle", [N], N );
491 $_GetCommState = ff( "k32", "GetCommState", [ N, P ], I );
492 $_SetCommState = ff( "k32", "SetCommState", [ N, P ], I );
493 $_SetupComm = ff( "k32", "SetupComm", [ N, N, N ], I );
494 $_PurgeComm = ff( "k32", "PurgeComm", [ N, N ], I );
495 $_CreateEvent = ff( "k32", "CreateEvent", [ P, I, I, P ], N );
504 4, [ 7, 8 ], 9, ["a"],
508 [ 3, 2, 1 ], 1, 2, 3,
509 [ -1, -2, -3 ], [ -1, -2, -3 ], [ -1, -2, -3 ], [ -1, -2 ],
510 3, [ -1, -2 ], 3, [ -1, -2, -3 ],
511 [ !1 ], [ 8, 7, 6 ], [ 8, 7, 6 ], [4],
520 expect => <<'#7...........',
521 $wl = int( $wl * $f + .5 );
522 $wr = int( $wr * $f + .5 );
523 $pag = int( $pageh * $f + .5 );
524 $fe = $opt_F ? "t" : "f";
525 $cf = $opt_U ? "t" : "f";
526 $tp = $opt_t ? "t" : "f";
527 $rm = $numbstyle ? "t" : "f";
528 $pa = $showurl ? "t" : "f";
529 $nh = $seq_number ? "t" : "f";
536 expect => <<'#8...........',
537 # hanging side comments
538 if ( $seen == 1 ) { # We're the first word so far to have
540 $hashref->{$abbrev} = $word;
542 elsif ( $seen == 2 ) { # We're the second word to have this
543 # abbreviation, so we can't use it.
544 delete $hashref->{$abbrev};
546 else { # We're the third word to have this
547 # abbreviation, so skip to the next word.
556 expect => <<'#9...........',
557 # hanging side comments
559 { # We're the first word so far to have
561 $hashref->{$abbrev} = $word;
564 { # We're the second word to have this
565 # abbreviation, so we can't use it.
566 delete $hashref->{$abbrev};
569 { # We're the third word to have this
570 # abbreviation, so skip to the next word.
579 expect => <<'#10...........',
580 # test -wls='->' -wrs='->'
582 my ($ping) = Net::Ping->new();
591 expect => <<'#11...........',
592 # test -wls='->' -wrs='->'
594 my ($ping) = Net::Ping -> new();
595 $ping -> ping($host);
601 source => "rt133130",
603 expect => <<'#12...........',
604 method sum_radlinks {
605 my ( $global_radiation_matrix, $local_radiation_matrix, $rngg ) = @_;
606 my ( $i, $j, $n1, $n2, $num );
609 for ( $i = 0 ; $i < $num ; $i++ ) {
611 for ( $j = 0 ; $j < $num ; $j++ ) {
613 $rggij = $local_radiation_matrix->[$i][$j];
614 if ( $rggij && ( $n1 != $n2 ) ) {
615 $global_radiation_matrix->[$n1][$n2] += $rggij;
623 'rt133130.rt133130' => {
624 source => "rt133130",
625 params => "rt133130",
626 expect => <<'#13...........',
627 method sum_radlinks {
628 my ( $global_radiation_matrix, $local_radiation_matrix, $rngg ) = @_;
629 my ( $i, $j, $n1, $n2, $num );
632 for ( $i = 0 ; $i < $num ; $i++ ) {
634 for ( $j = 0 ; $j < $num ; $j++ ) {
636 $rggij = $local_radiation_matrix->[$i][$j];
637 if ( $rggij && ( $n1 != $n2 ) ) {
638 $global_radiation_matrix->[$n1][$n2] += $rggij;
642 } ## end sub sum_radlinks
649 expect => <<'#14...........',
653 print "hello world\n";
661 print "hello world\n";
672 expect => <<'#15...........',
676 print "hello world\n";
684 print "hello world\n";
695 expect => <<'#16...........',
699 print "hello world\n";
707 print "hello world\n";
716 source => "scbb-csc",
718 expect => <<'#17...........',
719 sub perlmod_install_advice {
721 if ($auto_install_cpan) {
722 require AutoInstall::Tk;
723 my $r = AutoInstall::Tk::do_autoinstall_tk(@mod);
726 warn "Re-require $mod...\n";
728 die __LINE__ . ": $@" if $@;
733 my $shell = ( $os eq 'win' ? M "Eingabeaufforderung" : M "Shell" );
738 ? "Die fehlenden Perl-Module können aus der %s mit dem Kommando\n"
739 : "Das fehlende Perl-Modul kann aus der %s mit dem Kommando\n"
743 . " perl -MCPAN -e \"install "
744 . join( ", ", @mod ) . "\"\n"
745 . "aus dem Internet geholt und installiert werden.\n",
754 'scbb-csc.scbb-csc' => {
755 source => "scbb-csc",
756 params => "scbb-csc",
757 expect => <<'#18...........',
758 sub perlmod_install_advice {
760 if ($auto_install_cpan) {
761 require AutoInstall::Tk;
762 my $r = AutoInstall::Tk::do_autoinstall_tk(@mod);
765 warn "Re-require $mod...\n";
767 die __LINE__ . ": $@" if $@;
769 } ## end if ( $r > 0 )
770 } ## end if ($auto_install_cpan)
772 my $shell = ( $os eq 'win' ? M "Eingabeaufforderung" : M "Shell" );
777 ? "Die fehlenden Perl-Module können aus der %s mit dem Kommando\n"
778 : "Das fehlende Perl-Modul kann aus der %s mit dem Kommando\n"
782 . " perl -MCPAN -e \"install "
783 . join( ", ", @mod ) . "\"\n"
784 . "aus dem Internet geholt und installiert werden.\n",
787 } ## end else [ if ($auto_install_cpan)]
788 } ## end sub perlmod_install_advice
794 source => "here_long",
796 expect => <<'#19...........',
797 # must not break after here target regardless of maximum-line-length
798 $sth = $dbh->prepare(<<"END_OF_SELECT") or die "Couldn't prepare SQL";
799 SELECT COUNT(duration),SUM(duration)
800 FROM logins WHERE username='$user'
807 my $ntests = 0 + keys %{$rtests};
808 plan tests => $ntests;
815 foreach my $key ( sort keys %{$rtests} ) {
817 my $sname = $rtests->{$key}->{source};
818 my $expect = $rtests->{$key}->{expect};
819 my $pname = $rtests->{$key}->{params};
820 my $source = $rsources->{$sname};
821 my $params = defined($pname) ? $rparams->{$pname} : "";
823 my $errorfile_string;
824 my $err = Perl::Tidy::perltidy(
826 destination => \$output,
827 perltidyrc => \$params,
828 argv => '', # for safety; hide any ARGV from perltidy
829 stderr => \$stderr_string,
830 errorfile => \$errorfile_string, # not used when -se flag is set
832 if ( $err || $stderr_string || $errorfile_string ) {
833 print STDERR "Error output received for test '$key'\n";
835 print STDERR "An error flag '$err' was returned\n";
838 if ($stderr_string) {
839 print STDERR "---------------------\n";
840 print STDERR "<<STDERR>>\n$stderr_string\n";
841 print STDERR "---------------------\n";
842 ok( !$stderr_string );
844 if ($errorfile_string) {
845 print STDERR "---------------------\n";
846 print STDERR "<<.ERR file>>\n$errorfile_string\n";
847 print STDERR "---------------------\n";
848 ok( !$errorfile_string );
852 if ( !is( $output, $expect, $key ) ) {
853 my $leno = length($output);
854 my $lene = length($expect);
855 if ( $leno == $lene ) {
857 "#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
861 "#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";