1 # Created with: ./make_t.pl
18 #15 code_skipping.code_skipping
24 # To locate test #13 you can search for its name or the string '#13'
36 ###########################################
37 # BEGIN SECTION 1: Parameter combinations #
38 ###########################################
42 'code_skipping' => <<'----------',
43 # same as the default but tests -cs -csb and -cse
45 --code-skipping-begin='#<<V'
46 --code-skipping-end='#>>V'
50 'git106' => "-xlp -gnu -xci",
51 'git108' => "-wn -wfc",
52 'git93' => <<'----------',
55 'lpxl6' => <<'----------',
56 # equivalent to -lpxl='{ [ F(2'
61 ############################
62 # BEGIN SECTION 2: Sources #
63 ############################
66 'bal' => <<'----------',
74 'c133' => <<'----------',
75 # this will make 1 line unless -boc is used
77 $x * cos($a) - $y * sin($a),
78 $x * sin($a) + $y * cos($a)
81 # broken list - issue c133
83 $x * cos($a) - $y * sin($a),
84 $x * sin($a) + $y * cos($a)
90 $x * cos($a) - $y * sin($a),
91 $x * sin($a) + $y * cos($a);
94 'c139' => <<'----------',
95 # The '&' has trailing spaces
100 # This '$' has trailing spaces
104 # this arrow has trailing spaces
106 sql_set_env_attr( $evh, $SQL_ATTR_ODBC_VERSION, $SQL_OV_ODBC2, 0 );
108 # spaces and blank line
114 # spaces and blank line
117 sql_set_env_attr( $evh, $SQL_ATTR_ODBC_VERSION, $SQL_OV_ODBC2, 0 );
120 'c154' => <<'----------',
124 $start_order * $nbSubOrderByOrder + $start_suborder ;
125 !exists $level_hash{$level}->{$order}
127 $stop_order * $nbSubOrderByOrder + $stop_suborder ;
139 $f ^ ( $w = ( $z = $m . $e ) ^ substr $e, $q )
140 ^ ( $n = $b ^ $d | $a ^ $l )
141 ) & ( $w | $z ^ $f ^ $n ) & ( $l | $g )
148 $j = 0, $match_j = -1 ;
152 # changed from naive_string_matcher
153 $sub->[$j] eq $big->[ $i + $j ] ; $j++
161 'c158' => <<'----------',
162 my $meta = try { $package->meta }
163 or die "$package does not have a ->meta method\n";
165 my ($curr) = current();
169 'code_skipping' => <<'----------',
170 %Hdr=%U2E=%E2U=%Fallback=();
171 $in_charmap=$nerror=$nwarning=0;
173 #<<V code skipping: perltidy will pass this verbatim without error checking
182 'drc' => <<'----------',
183 ignoreSpec( $file, "file",, \%spec,,, \%Rspec );
186 'git105' => <<'----------',
189 use experimental 'for_list';
191 for my ( $k, $v ) ( 1, 2, 3, 4 ) {
198 'git106' => <<'----------',
199 is( $module->VERSION, $expected,
200 "$main_module->VERSION matches $module->VERSION ($expected)" );
202 ok( ( $@ eq "" && "@b" eq "1 4 5 9" ),
203 'redefinition should not take effect during the sort' );
206 ( map { $points->slice($_) } @sls1 ),
207 ( map { $n->slice($_) } @sls1 ),
208 ( map { $this->{Colors}->slice($_) } @sls1 )
212 "0123456789012345678901234567890123456789",
213 "0123456789012345678901234567890123456789"
217 "0123456789012345678901234567890123456789",
218 "0123456789012345678901234567890123456789"
222 return !( $elem->isa('PPI::Statement::End')
223 || $elem->isa('PPI::Statement::Data') );
226 $s = $dbobj->seq( $k, $v, R_LAST ) ;
228 $s = $dbobj->seq( $k, $v, R_PREV )
234 # excess without -xci
235 fresh_perl_is( '-C-',
236 <<'abcdefghijklmnopq', {}, "ambiguous unary operator check doesn't crash" );
237 Warning: Use of "-C-" without parentheses is ambiguous at - line 1.
245 "One moment please, I shall display the groups with agendas:" );
251 'git108' => <<'----------',
255 some_other_arg3 => $bar->{'baz'},
260 my $species = new Bio::Species(
263 sapiens Homo Hominidae
264 Catarrhini Primates Eutheria
266 Chordata Metazoa Eukaryota
272 'git93' => <<'----------',
275 use IPC::Cmd qw{can_run run QUOTE};
276 use File::Path qw/mkpath/;
277 use File::Temp qw[tempdir];
278 use Params::Check qw<check>;
279 use Module::Load::Conditional qw#can_load#;
280 use Locale::Maketext::Simple Style => 'gettext'; # does not align
282 # do not align on these 'q' token types - not use statements...
283 my $gene_color_sets = [
284 [ qw( blue blue blue blue ) => 'blue' ],
285 [ qw( brown blue blue blue ) => 'brown' ],
286 [ qw( brown brown green green ) => 'brown' ],
289 sub quux : PluginKeyword { 'quux' }
290 sub qaax : PluginKeyword(qiix) { die "unimplemented" }
292 use vars qw($curdir);
296 'lpxl' => <<'----------',
297 # simple function call
298 my $loanlength = getLoanLength(
299 $borrower->{'categorycode'}, # sc1
300 $iteminformation->{'itemtype'},
301 $borrower->{'branchcode'} # sc3
304 # function call, more than one level deep
305 my $o = very::long::class::name->new(
313 # function call with sublist
316 "Extra-Parameters: " . join("<->", $extra_parms),
317 "Config: " . join("<->", %config)
320 # simple function call with code block
321 $m->command(-label => 'Save',
322 -command => sub { print "DOS\n"; save_dialog($win); });
324 # function call, ternary in list
326 OptArgs2::Result->usage(
327 $style == OptArgs2::STYLE_FULL ? 'FullUsage' : 'NormalUsage',
328 'usage: ' . $usage . "\n" );
330 # not a function call
338 # 'local' is a keyword, not a user function
340 $len, $pts, @colspec, $char, $cols,
341 $repeat, $celldata, $at_text, $after_text
344 # square bracket with sublists
346 ListElem->new(id => 0, val => 100),
347 ListElem->new(id => 2, val => 50),
348 ListElem->new(id => 1, val => 10),
351 # curly brace with sublists
353 cat => {nap => "lap", eat => "meat"},
354 dog => {prowl => "growl", pool => "drool"},
355 mouse => {nibble => "kibble"},
359 'wtc' => <<'----------',
360 # both single and multiple line lists:
362 [ "fred", "barney", ],
363 [ "george", "jane", "elroy" ],
364 [ "homer", "marge", "bart", ],
368 ( $name, $body ) = ( $2, $3, );
370 # multiline, but not bare
371 $text = $main->Scrolled( TextUndo, $yyy, $zzz, $wwwww,
372 selectbackgroundxxxxx => 'yellow', );
374 # this will pass for 'h'
390 'rectangle', 40, 60, 80, 80,
398 $target_binary = $fs->Show( -popover => 'cursor', -create => 1, );
400 )->pack( -side => 'left', );
404 { ':key' => { name => \&string, list => { value => \&string }, }, }, };
410 ####################################
411 # BEGIN SECTION 3: Expected output #
412 ####################################
418 expect => <<'#1...........',
428 expect => <<'#2...........',
440 expect => <<'#3...........',
441 # simple function call
442 my $loanlength = getLoanLength(
443 $borrower->{'categorycode'}, # sc1
444 $iteminformation->{'itemtype'},
445 $borrower->{'branchcode'} # sc3
448 # function call, more than one level deep
449 my $o = very::long::class::name->new(
457 # function call with sublist
460 "Extra-Parameters: " . join( "<->", $extra_parms ),
461 "Config: " . join( "<->", %config )
464 # simple function call with code block
467 -command => sub { print "DOS\n"; save_dialog($win); }
470 # function call, ternary in list
471 return OptArgs2::Result->usage(
472 $style == OptArgs2::STYLE_FULL ? 'FullUsage' : 'NormalUsage',
473 'usage: ' . $usage . "\n" );
475 # not a function call
483 # 'local' is a keyword, not a user function
485 $len, $pts, @colspec, $char, $cols,
486 $repeat, $celldata, $at_text, $after_text
489 # square bracket with sublists
491 ListElem->new( id => 0, val => 100 ),
492 ListElem->new( id => 2, val => 50 ),
493 ListElem->new( id => 1, val => 10 ),
496 # curly brace with sublists
498 cat => { nap => "lap", eat => "meat" },
499 dog => { prowl => "growl", pool => "drool" },
500 mouse => { nibble => "kibble" },
508 expect => <<'#4...........',
509 # this will make 1 line unless -boc is used
511 $x * cos($a) - $y * sin($a),
512 $x * sin($a) + $y * cos($a)
515 # broken list - issue c133
517 $x * cos($a) - $y * sin($a),
518 $x * sin($a) + $y * cos($a)
524 $x * cos($a) - $y * sin($a),
525 $x * sin($a) + $y * cos($a);
532 expect => <<'#5...........',
533 # this will make 1 line unless -boc is used
534 return ( $x * cos($a) - $y * sin($a), $x * sin($a) + $y * cos($a) );
536 # broken list - issue c133
538 $x * cos($a) - $y * sin($a),
539 $x * sin($a) + $y * cos($a)
545 $x * cos($a) - $y * sin($a),
546 $x * sin($a) + $y * cos($a);
553 expect => <<'#6...........',
556 use IPC::Cmd qw{can_run run QUOTE};
557 use File::Path qw/mkpath/;
558 use File::Temp qw[tempdir];
559 use Params::Check qw<check>;
560 use Module::Load::Conditional qw#can_load#;
561 use Locale::Maketext::Simple Style => 'gettext'; # does not align
563 # do not align on these 'q' token types - not use statements...
564 my $gene_color_sets = [
565 [ qw( blue blue blue blue ) => 'blue' ],
566 [ qw( brown blue blue blue ) => 'brown' ],
567 [ qw( brown brown green green ) => 'brown' ],
570 sub quux : PluginKeyword { 'quux' }
571 sub qaax : PluginKeyword(qiix) { die "unimplemented" }
573 use vars qw($curdir);
581 expect => <<'#7...........',
584 use IPC::Cmd qw{can_run run QUOTE};
585 use File::Path qw/mkpath/;
586 use File::Temp qw[tempdir];
587 use Params::Check qw<check>;
588 use Module::Load::Conditional qw#can_load#;
589 use Locale::Maketext::Simple Style => 'gettext'; # does not align
591 # do not align on these 'q' token types - not use statements...
592 my $gene_color_sets = [
593 [ qw( blue blue blue blue ) => 'blue' ],
594 [ qw( brown blue blue blue ) => 'brown' ],
595 [ qw( brown brown green green ) => 'brown' ],
598 sub quux : PluginKeyword { 'quux' }
599 sub qaax : PluginKeyword(qiix) { die "unimplemented" }
601 use vars qw($curdir);
609 expect => <<'#8...........',
610 # The '&' has trailing spaces
613 # This '$' has trailing spaces
616 # this arrow has trailing spaces
617 $r = $c->sql_set_env_attr( $evh, $SQL_ATTR_ODBC_VERSION, $SQL_OV_ODBC2, 0 );
619 # spaces and blank line
624 # spaces and blank line
627 sql_set_env_attr( $evh, $SQL_ATTR_ODBC_VERSION, $SQL_OV_ODBC2, 0 );
634 expect => <<'#9...........',
635 ignoreSpec( $file, "file",, \%spec,,, \%Rspec );
642 expect => <<'#10...........',
643 ignoreSpec( $file, "file", \%spec, \%Rspec );
650 expect => <<'#11...........',
653 use experimental 'for_list';
655 for my ( $k, $v ) ( 1, 2, 3, 4 ) {
666 expect => <<'#12...........',
667 is( $module->VERSION, $expected,
668 "$main_module->VERSION matches $module->VERSION ($expected)" );
670 ok( ( $@ eq "" && "@b" eq "1 4 5 9" ),
671 'redefinition should not take effect during the sort' );
674 ( map { $points->slice($_) } @sls1 ),
675 ( map { $n->slice($_) } @sls1 ),
676 ( map { $this->{Colors}->slice($_) } @sls1 )
680 "0123456789012345678901234567890123456789",
681 "0123456789012345678901234567890123456789"
685 "0123456789012345678901234567890123456789",
686 "0123456789012345678901234567890123456789"
690 return !( $elem->isa('PPI::Statement::End')
691 || $elem->isa('PPI::Statement::Data') );
694 $s = $dbobj->seq( $k, $v, R_LAST ) ;
696 $s = $dbobj->seq( $k, $v, R_PREV )
702 # excess without -xci
703 fresh_perl_is( '-C-',
704 <<'abcdefghijklmnopq', {}, "ambiguous unary operator check doesn't crash" );
705 Warning: Use of "-C-" without parentheses is ambiguous at - line 1.
713 "One moment please, I shall display the groups with agendas:" );
723 expect => <<'#13...........',
724 is($module->VERSION, $expected,
725 "$main_module->VERSION matches $module->VERSION ($expected)");
727 ok(($@ eq "" && "@b" eq "1 4 5 9"),
728 'redefinition should not take effect during the sort');
730 &$f((map { $points->slice($_) } @sls1),
731 (map { $n->slice($_) } @sls1),
732 (map { $this->{Colors}->slice($_) } @sls1));
734 AA("0123456789012345678901234567890123456789",
735 "0123456789012345678901234567890123456789");
737 AAAAAA("0123456789012345678901234567890123456789",
738 "0123456789012345678901234567890123456789");
741 return !( $elem->isa('PPI::Statement::End')
742 || $elem->isa('PPI::Statement::Data'));
744 for ($s = $dbobj->seq($k, $v, R_LAST) ;
746 $s = $dbobj->seq($k, $v, R_PREV))
751 # excess without -xci
753 <<'abcdefghijklmnopq', {}, "ambiguous unary operator check doesn't crash");
754 Warning: Use of "-C-" without parentheses is ambiguous at - line 1.
762 "One moment please, I shall display the groups with agendas:"
773 expect => <<'#14...........',
780 $start_order * $nbSubOrderByOrder + $start_suborder ;
781 !exists $level_hash{$level}->{$order}
783 $stop_order * $nbSubOrderByOrder + $stop_suborder ;
792 print '-' x 79, "\n" ;
794 $f ^ ( $w = ( $z = $m . $e ) ^ substr $e, $q )
795 ^ ( $n = $b ^ $d | $a ^ $l )
796 ) & ( $w | $z ^ $f ^ $n ) & ( $l | $g )
803 $j = 0, $match_j = -1 ;
807 # changed from naive_string_matcher
808 $sub->[$j] eq $big->[ $i + $j ] ;
821 'code_skipping.code_skipping' => {
822 source => "code_skipping",
823 params => "code_skipping",
824 expect => <<'#15...........',
825 %Hdr = %U2E = %E2U = %Fallback = ();
826 $in_charmap = $nerror = $nwarning = 0;
828 #<<V code skipping: perltidy will pass this verbatim without error checking
841 expect => <<'#16...........',
842 my $meta = try { $package->meta }
843 or die "$package does not have a ->meta method\n";
845 my ($curr) = current();
853 expect => <<'#17...........',
857 some_other_arg3 => $bar->{'baz'},
862 my $species = new Bio::Species(
865 sapiens Homo Hominidae
866 Catarrhini Primates Eutheria
868 Chordata Metazoa Eukaryota
878 expect => <<'#18...........',
879 elf->call_method( method_name_foo => {
881 some_other_arg3 => $bar->{'baz'},
885 my $species = new Bio::Species( -classification => [ qw(
886 sapiens Homo Hominidae
887 Catarrhini Primates Eutheria
889 Chordata Metazoa Eukaryota
897 expect => <<'#19...........',
898 # both single and multiple line lists:
900 [ "fred", "barney", ],
901 [ "george", "jane", "elroy" ],
902 [ "homer", "marge", "bart", ],
906 ( $name, $body ) = ( $2, $3, );
908 # multiline, but not bare
909 $text = $main->Scrolled( TextUndo, $yyy, $zzz, $wwwww,
910 selectbackgroundxxxxx => 'yellow', );
912 # this will pass for 'h'
928 'rectangle', 40, 60, 80, 80,
936 $target_binary = $fs->Show( -popover => 'cursor', -create => 1, );
938 )->pack( -side => 'left', );
942 { ':key' => { name => \&string, list => { value => \&string }, }, }, };
948 my $ntests = 0 + keys %{$rtests};
949 plan tests => $ntests;
956 foreach my $key ( sort keys %{$rtests} ) {
958 my $sname = $rtests->{$key}->{source};
959 my $expect = $rtests->{$key}->{expect};
960 my $pname = $rtests->{$key}->{params};
961 my $source = $rsources->{$sname};
962 my $params = defined($pname) ? $rparams->{$pname} : "";
964 my $errorfile_string;
965 my $err = Perl::Tidy::perltidy(
967 destination => \$output,
968 perltidyrc => \$params,
969 argv => '', # for safety; hide any ARGV from perltidy
970 stderr => \$stderr_string,
971 errorfile => \$errorfile_string, # not used when -se flag is set
973 if ( $err || $stderr_string || $errorfile_string ) {
974 print STDERR "Error output received for test '$key'\n";
976 print STDERR "An error flag '$err' was returned\n";
979 if ($stderr_string) {
980 print STDERR "---------------------\n";
981 print STDERR "<<STDERR>>\n$stderr_string\n";
982 print STDERR "---------------------\n";
983 ok( !$stderr_string );
985 if ($errorfile_string) {
986 print STDERR "---------------------\n";
987 print STDERR "<<.ERR file>>\n$errorfile_string\n";
988 print STDERR "---------------------\n";
989 ok( !$errorfile_string );
993 if ( !is( $output, $expect, $key ) ) {
994 my $leno = length($output);
995 my $lene = length($expect);
996 if ( $leno == $lene ) {
998 "#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
1002 "#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";