1 # Created with: ./make_t.pl
25 # To locate test #13 you can search for its name or the string '#13'
37 ###########################################
38 # BEGIN SECTION 1: Parameter combinations #
39 ###########################################
43 'ce' => "-cuddled-blocks",
47 ############################
48 # BEGIN SECTION 2: Sources #
49 ############################
52 'angle' => <<'----------',
53 # This is an angle operator:
54 @message_list =sort sort_algorithm < INDEX_FILE >;# angle operator
56 # Not an angle operator:
57 # Patched added in guess routine for this case:
58 if ( VERSION < 5.009 && $op->name eq 'aassign' ) {
63 'arrows1' => <<'----------',
64 # remove spaces around arrows
65 my $obj = Bio::Variation::AAChange -> new;
66 my $termcap = Term::Cap -> Tgetent( { TERM => undef } );
69 'arrows2' => <<'----------',
70 $_[ 0]-> Blue -> backColor(( $_[ 0]-> Blue -> backColor == cl::Blue ) ? cl::LightBlue : cl::Blue );
73 'attrib1' => <<'----------',
74 sub be_careful () : locked method {
81 'attrib2' => <<'----------',
84 () # prototype may be on new line, but cannot put line break within prototype
88 print "and your little dog ";
92 'attrib3' => <<'----------',
95 my Canine $spot : Watchful ;
101 sub Y::x : locked { 1 }
105 BEGIN { *bar = \&X::foo; }
107 sub Y::bar : locked ;
110 'bar1' => <<'----------',
111 if ($bigwasteofspace1 && $bigwasteofspace2 || $bigwasteofspace3 && $bigwasteofspace4) { }
114 'block1' => <<'----------',
116 print "start main running\n";
117 die "main now dying\n";
118 END {$a=6; print "1st end, a=$a\n"}
119 CHECK {$a=8; print "1st check, a=$a\n"}
120 INIT {$a=10; print "1st init, a=$a\n"}
121 END {$a=12; print "2nd end, a=$a\n"}
122 BEGIN {$a=14; print "1st begin, a=$a\n"}
123 INIT {$a=16; print "2nd init, a=$a\n"}
124 BEGIN {$a=18; print "2nd begin, a=$a\n"}
125 CHECK {$a=20; print "2nd check, a=$a\n"}
126 END {$a=23; print "3rd end, a=$a\n"}
130 'boc1' => <<'----------',
132 # Running with -boc (break-at-old-comma-breakpoints) should not
133 # allow forming a single line
137 padding => (' ' x $_),
141 'boc2' => <<'----------',
151 'break1' => <<'----------',
153 $self->__print("*** Type 'p' now to show start up log\n") ; # XXX add to banner?
156 'break2' => <<'----------',
157 # break before the '->'
158 ( $current_feature_item->children )[0]->set( $current_feature->primary_tag );
159 $sth->{'Database'}->{'xbase_tables'}->{ $parsed_sql->{'table'}[0] }->field_type($_);
162 'break3' => <<'----------',
163 # keep the anonymous hash block together:
164 my $red_color = $widget->window->get_colormap->color_alloc( { red => 65000, green => 0, blue => 0 } );
167 'break4' => <<'----------',
168 spawn( "$LINTIAN_ROOT/unpack/list-binpkg", "$LINTIAN_LAB/info/binary-packages", $v ) == 0 or fail("cannot create binary package list");
171 'carat' => <<'----------',
172 my $a=${^WARNING_BITS};
173 @{^HOWDY_PARDNER}=(101,102);
178 'ce1' => <<'----------',
179 # test -ce with blank lines and comments between blocks
180 if($value[0] =~ /^(\#)/){ # skip any comment line
185 elsif($value[0] =~ /^(o)$/ or $value[0] =~ /^(os)$/){
190 elsif($value[0] =~ /^(b)$/ or $value[0] =~ /^(dbfile)$/)
196 # Add the additional site
198 $rebase_hash{$name} .= " $site";
203 ####################################
204 # BEGIN SECTION 3: Expected output #
205 ####################################
211 expect => <<'#1...........',
212 # This is an angle operator:
213 @message_list = sort sort_algorithm < INDEX_FILE >; # angle operator
215 # Not an angle operator:
216 # Patched added in guess routine for this case:
217 if ( VERSION < 5.009 && $op->name eq 'aassign' ) {
226 expect => <<'#2...........',
227 # remove spaces around arrows
228 my $obj = Bio::Variation::AAChange->new;
229 my $termcap = Term::Cap->Tgetent( { TERM => undef } );
236 expect => <<'#3...........',
237 $_[0]->Blue->backColor(
238 ( $_[0]->Blue->backColor == cl::Blue ) ? cl::LightBlue : cl::Blue );
245 expect => <<'#4...........',
246 sub be_careful () : locked method {
257 expect => <<'#5...........',
259 () # prototype may be on new line, but cannot put line break within prototype
261 print "and your little dog ";
269 expect => <<'#6...........',
273 my Canine $spot : Watchful;
282 sub Y::x : locked { 1 }
288 BEGIN { *bar = \&X::foo; }
298 expect => <<'#7...........',
299 if ( $bigwasteofspace1 && $bigwasteofspace2
300 || $bigwasteofspace3 && $bigwasteofspace4 ) {
308 expect => <<'#8...........',
309 if ( $bigwasteofspace1 && $bigwasteofspace2
310 || $bigwasteofspace3 && $bigwasteofspace4 )
319 expect => <<'#9...........',
321 print "start main running\n";
322 die "main now dying\n";
323 END { $a = 6; print "1st end, a=$a\n" }
324 CHECK { $a = 8; print "1st check, a=$a\n" }
325 INIT { $a = 10; print "1st init, a=$a\n" }
326 END { $a = 12; print "2nd end, a=$a\n" }
327 BEGIN { $a = 14; print "1st begin, a=$a\n" }
328 INIT { $a = 16; print "2nd init, a=$a\n" }
329 BEGIN { $a = 18; print "2nd begin, a=$a\n" }
330 CHECK { $a = 20; print "2nd check, a=$a\n" }
331 END { $a = 23; print "3rd end, a=$a\n" }
339 expect => <<'#10...........',
341 # Running with -boc (break-at-old-comma-breakpoints) should not
342 # allow forming a single line
347 padding => ( ' ' x $_ ),
356 expect => <<'#11...........',
358 # Running with -boc (break-at-old-comma-breakpoints) should not
359 # allow forming a single line
361 map { { number => $_, character => chr $_, padding => ( ' ' x $_ ), } }
369 expect => <<'#12...........',
384 expect => <<'#13...........',
385 my @list = ( 1, 1, 1, 1, 2, 1, 1, 3, 3, 1, 1, 4, 6, 4, 1, );
393 expect => <<'#14...........',
395 $self->__print("*** Type 'p' now to show start up log\n")
396 ; # XXX add to banner?
403 expect => <<'#15...........',
404 # break before the '->'
405 ( $current_feature_item->children )[0]
406 ->set( $current_feature->primary_tag );
407 $sth->{'Database'}->{'xbase_tables'}->{ $parsed_sql->{'table'}[0] }
415 expect => <<'#16...........',
416 # keep the anonymous hash block together:
417 my $red_color = $widget->window->get_colormap->color_alloc(
418 { red => 65000, green => 0, blue => 0 } );
425 expect => <<'#17...........',
426 spawn( "$LINTIAN_ROOT/unpack/list-binpkg",
427 "$LINTIAN_LAB/info/binary-packages", $v ) == 0
428 or fail("cannot create binary package list");
435 expect => <<'#18...........',
436 my $a = ${^WARNING_BITS};
437 @{^HOWDY_PARDNER} = ( 101, 102 );
446 expect => <<'#19...........',
447 # test -ce with blank lines and comments between blocks
448 if ( $value[0] =~ /^(\#)/ ) { # skip any comment line
451 } elsif ( $value[0] =~ /^(o)$/ or $value[0] =~ /^(os)$/ ) {
455 } elsif ( $value[0] =~ /^(b)$/ or $value[0] =~ /^(dbfile)$/ )
462 # Add the additional site
464 $rebase_hash{$name} .= " $site";
472 expect => <<'#20...........',
473 # test -ce with blank lines and comments between blocks
474 if ( $value[0] =~ /^(\#)/ ) { # skip any comment line
478 elsif ( $value[0] =~ /^(o)$/ or $value[0] =~ /^(os)$/ ) {
483 elsif ( $value[0] =~ /^(b)$/ or $value[0] =~ /^(dbfile)$/ )
490 # Add the additional site
493 $rebase_hash{$name} .= " $site";
499 my $ntests = 0 + keys %{$rtests};
500 plan tests => $ntests;
507 foreach my $key ( sort keys %{$rtests} ) {
509 my $sname = $rtests->{$key}->{source};
510 my $expect = $rtests->{$key}->{expect};
511 my $pname = $rtests->{$key}->{params};
512 my $source = $rsources->{$sname};
513 my $params = defined($pname) ? $rparams->{$pname} : "";
515 my $errorfile_string;
516 my $err = Perl::Tidy::perltidy(
518 destination => \$output,
519 perltidyrc => \$params,
520 argv => '', # for safety; hide any ARGV from perltidy
521 stderr => \$stderr_string,
522 errorfile => \$errorfile_string, # not used when -se flag is set
524 if ( $err || $stderr_string || $errorfile_string ) {
525 print STDERR "Error output received for test '$key'\n";
527 print STDERR "An error flag '$err' was returned\n";
530 if ($stderr_string) {
531 print STDERR "---------------------\n";
532 print STDERR "<<STDERR>>\n$stderr_string\n";
533 print STDERR "---------------------\n";
534 ok( !$stderr_string );
536 if ($errorfile_string) {
537 print STDERR "---------------------\n";
538 print STDERR "<<.ERR file>>\n$errorfile_string\n";
539 print STDERR "---------------------\n";
540 ok( !$errorfile_string );
544 if ( !is( $output, $expect, $key ) ) {
545 my $leno = length($output);
546 my $lene = length($expect);
547 if ( $leno == $lene ) {
549 "#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
553 "#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";