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 ###########################################
44 'style1' => <<'----------',
61 -wbb="% + - * / x != == >= <= =~ < > | & **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x="
64 'style2' => <<'----------',
76 'style3' => <<'----------',
91 'style4' => <<'----------',
98 'style5' => <<'----------',
119 -wrs="= .= =~ !~ ? :"
128 -wba="% + - * / x != == >= <= =~ !~ < > | & >= < = **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x= . << >> -> && ||"
135 ############################
136 # BEGIN SECTION 2: Sources #
137 ############################
140 'scl' => <<'----------',
141 # try -scl=12 to see '$returns' joined with the previous line
142 $format = "format STDOUT =\n" . &format_line('Function: @') . '$name' . "\n" . &format_line('Arguments: @') . '$args' . "\n" . &format_line('Returns: @') . '$returns' . "\n" . &format_line(' ~~ ^') . '$desc' . "\n.\n";
145 'semicolon2' => <<'----------',
146 # will not add semicolon for this block type
147 $highest = List::Util::reduce { Sort::Versions::versioncmp( $a, $b ) > 0 ? $a : $b }
150 'side_comments1' => <<'----------',
151 # side comments at different indentation levels should not be aligned
152 { { { { { ${msg} = "Hello World!"; print "My message: ${msg}\n"; } } #end level 4
158 'sil1' => <<'----------',
159 #############################################################
160 # This will walk to the left because of bad -sil guess
162 #############################################################
165 # This will walk to the right if it is the first line of a file.
167 ov_method mycan( $package, '(""' ), $package
168 or ov_method mycan( $package, '(0+' ), $package
169 or ov_method mycan( $package, '(bool' ), $package
170 or ov_method mycan( $package, '(nomethod' ), $package;
174 'slashslash' => <<'----------',
175 $home = $ENV{HOME} // $ENV{LOGDIR} // ( getpwuid($<) )[7]
176 // die "You're homeless!\n";
178 $version = 'v' . join '.', map ord, split //, $version->PV;
179 foreach ( split( //, $lets ) ) { }
180 foreach ( split( //, $input ) ) { }
184 'smart' => <<'----------',
204 a_const ~~ "a constant";
205 "a constant" ~~ a_const;
214 {1 => 2} ~~ {1 => 2};
215 {1 => 2} ~~ {1 => 2};
216 {1 => 2} ~~ {1 => 3};
217 {1 => 3} ~~ {1 => 2};
218 {1 => 2} ~~ {2 => 3};
219 {2 => 3} ~~ {1 => 2};
220 \%main:: ~~ {map {$_ => 'x'} keys %main::};
221 {map {$_ => 'x'} keys %main::} ~~ \%main::;
222 \%hash ~~ \%tied_hash;
223 \%tied_hash ~~ \%hash;
224 \%tied_hash ~~ \%tied_hash;
225 \%tied_hash ~~ \%tied_hash;
226 \%:: ~~ [keys %main::];
227 [keys %main::] ~~ \%::;
230 {"" => 1} ~~ [undef];
231 [undef] ~~ {"" => 1};
232 {foo => 1} ~~ qr/^(fo[ox])$/;
233 qr/^(fo[ox])$/ ~~ {foo => 1};
234 +{0..100} ~~ qr/[13579]$/;
235 qr/[13579]$/ ~~ +{0..100};
236 +{foo => 1, bar => 2} ~~ "foo";
237 "foo" ~~ +{foo => 1, bar => 2};
238 +{foo => 1, bar => 2} ~~ "baz";
239 "baz" ~~ +{foo => 1, bar => 2};
244 [["foo"], ["bar"]] ~~ [qr/o/, qr/a/];
245 [qr/o/, qr/a/] ~~ [["foo"], ["bar"]];
246 ["foo", "bar"] ~~ [qr/o/, qr/a/];
247 [qr/o/, qr/a/] ~~ ["foo", "bar"];
252 \@nums ~~ \@tied_nums;
253 \@tied_nums ~~ \@nums;
254 [qw(foo bar baz quux)] ~~ qr/x/;
255 qr/x/ ~~ [qw(foo bar baz quux)];
256 [qw(foo bar baz quux)] ~~ qr/y/;
257 qr/y/ ~~ [qw(foo bar baz quux)];
258 [qw(1foo 2bar)] ~~ 2;
259 2 ~~ [qw(1foo 2bar)];
260 [qw(1foo 2bar)] ~~ "2";
261 "2" ~~ [qw(1foo 2bar)];
296 'space1' => <<'----------',
297 # We usually want a space at '} (', for example:
298 map { 1 * $_; } ( $y, $M, $w, $d, $h, $m, $s );
301 &{ $_->[1] }( delete $_[$#_]{ $_->[0] } );
303 # remove unwanted spaces after $ and -> here
304 &{ $ _ -> [1] }( delete $ _ [$#_ ]{ $_ -> [0] } );
306 # this has both tabs and spaces to remove
307 $ setup = $ labels -> labelsetup( Output_Width => 2.625) ;
310 'space2' => <<'----------',
311 # space before this opening paren
314 # retain any space between '-' and bare word
315 $myhash{USER-NAME}='steve';
318 'space3' => <<'----------',
319 # Treat newline as a whitespace. Otherwise, we might combine
320 # 'Send' and '-recipients' here
321 my $msg = new Fax::Send
326 'space4' => <<'----------',
327 # first prototype line will cause space between 'redirect' and '(' to close
328 sub html::redirect($); #<-- temporary prototype;
330 print html::redirect ('http://www.glob.com.au/');
333 'space5' => <<'----------',
334 # first prototype line commented out; space after 'redirect' remains
335 #sub html::redirect($); #<-- temporary prototype;
337 print html::redirect ('http://www.glob.com.au/');
341 'structure1' => <<'----------',
342 push@contents,$c->table({-width=>'100%'},$c->Tr($c->td({-align=>'left'},"The emboldened field names are mandatory, ","the remainder are optional",),$c->td({-align=>'right'},$c->a({-href=>'help.cgi',-target=>'_blank'},"What are the various fields?"))));
345 'style' => <<'----------',
346 # This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence
347 sub arrange_topframe {
348 my(@order) = ($hslabel_frame, $km_frame, $speed_frame[0],
349 $power_frame[0], $wind_frame, $percent_frame, $temp_frame,
350 @speed_frame[1..$#speed_frame],
351 @power_frame[1..$#power_frame],
353 my(@col) = (0, 1, 3, 4+$#speed_frame, 5+$#speed_frame+$#power_frame,
354 2, 6+$#speed_frame+$#power_frame,
356 5+$#speed_frame..4+$#speed_frame+$#power_frame);
359 my(%gridslaves) = map {($_, 1)} $top_frame->gridSlaves;
360 for(my $i = 0; $i <= $#order; $i++) {
362 next unless Tk::Exists($w);
363 my $col = $col[$i] || 0;
364 $width += $w->reqwidth;
365 if ($gridslaves{$w}) {
368 if ($width <= $top->width) {
371 -sticky => 'nsew'); # XXX
379 ####################################
380 # BEGIN SECTION 3: Expected output #
381 ####################################
387 expect => <<'#1...........',
388 # try -scl=12 to see '$returns' joined with the previous line
391 . &format_line('Function: @') . '$name' . "\n"
392 . &format_line('Arguments: @') . '$args' . "\n"
393 . &format_line('Returns: @')
395 . &format_line(' ~~ ^') . '$desc' . "\n.\n";
402 expect => <<'#2...........',
403 # try -scl=12 to see '$returns' joined with the previous line
406 . &format_line('Function: @') . '$name' . "\n"
407 . &format_line('Arguments: @') . '$args' . "\n"
408 . &format_line('Returns: @') . '$returns' . "\n"
409 . &format_line(' ~~ ^') . '$desc' . "\n.\n";
413 'semicolon2.def' => {
414 source => "semicolon2",
416 expect => <<'#3...........',
417 # will not add semicolon for this block type
418 $highest = List::Util::reduce {
419 Sort::Versions::versioncmp( $a, $b ) > 0 ? $a : $b
424 'side_comments1.def' => {
425 source => "side_comments1",
427 expect => <<'#4...........',
428 # side comments at different indentation levels should not be aligned
433 { ${msg} = "Hello World!"; print "My message: ${msg}\n"; }
444 expect => <<'#5...........',
445 #############################################################
446 # This will walk to the left because of bad -sil guess
448 #############################################################
451 # This will walk to the right if it is the first line of a file.
453 ov_method mycan( $package, '(""' ), $package
454 or ov_method mycan( $package, '(0+' ), $package
455 or ov_method mycan( $package, '(bool' ), $package
456 or ov_method mycan( $package, '(nomethod' ), $package;
464 expect => <<'#6...........',
465 #############################################################
466 # This will walk to the left because of bad -sil guess
468 #############################################################
471 # This will walk to the right if it is the first line of a file.
473 ov_method mycan( $package, '(""' ), $package
474 or ov_method mycan( $package, '(0+' ), $package
475 or ov_method mycan( $package, '(bool' ), $package
476 or ov_method mycan( $package, '(nomethod' ), $package;
481 'slashslash.def' => {
482 source => "slashslash",
484 expect => <<'#7...........',
485 $home = $ENV{HOME} // $ENV{LOGDIR} // ( getpwuid($<) )[7]
486 // die "You're homeless!\n";
488 $version = 'v' . join '.', map ord, split //, $version->PV;
489 foreach ( split( //, $lets ) ) { }
490 foreach ( split( //, $input ) ) { }
498 expect => <<'#8...........',
510 1 ~~ sub { scalar @_ };
511 sub { scalar @_ } ~~ 1;
518 a_const ~~ "a constant";
519 "a constant" ~~ a_const;
528 { 1 => 2 } ~~ { 1 => 2 };
529 { 1 => 2 } ~~ { 1 => 2 };
530 { 1 => 2 } ~~ { 1 => 3 };
531 { 1 => 3 } ~~ { 1 => 2 };
532 { 1 => 2 } ~~ { 2 => 3 };
533 { 2 => 3 } ~~ { 1 => 2 };
534 \%main:: ~~ { map { $_ => 'x' } keys %main:: };
536 map { $_ => 'x' } keys %main::
539 \%hash ~~ \%tied_hash;
540 \%tied_hash ~~ \%hash;
541 \%tied_hash ~~ \%tied_hash;
542 \%tied_hash ~~ \%tied_hash;
543 \%:: ~~ [ keys %main:: ];
544 [ keys %main:: ] ~~ \%::;
547 { "" => 1 } ~~ [undef];
548 [undef] ~~ { "" => 1 };
549 { foo => 1 } ~~ qr/^(fo[ox])$/;
550 qr/^(fo[ox])$/ ~~ { foo => 1 };
551 +{ 0 .. 100 } ~~ qr/[13579]$/;
552 qr/[13579]$/ ~~ +{ 0 .. 100 };
553 +{ foo => 1, bar => 2 } ~~ "foo";
554 "foo" ~~ +{ foo => 1, bar => 2 };
555 +{ foo => 1, bar => 2 } ~~ "baz";
556 "baz" ~~ +{ foo => 1, bar => 2 };
561 [ ["foo"], ["bar"] ] ~~ [ qr/o/, qr/a/ ];
562 [ qr/o/, qr/a/ ] ~~ [ ["foo"], ["bar"] ];
563 [ "foo", "bar" ] ~~ [ qr/o/, qr/a/ ];
564 [ qr/o/, qr/a/ ] ~~ [ "foo", "bar" ];
569 \@nums ~~ \@tied_nums;
570 \@tied_nums ~~ \@nums;
571 [qw(foo bar baz quux)] ~~ qr/x/;
572 qr/x/ ~~ [qw(foo bar baz quux)];
573 [qw(foo bar baz quux)] ~~ qr/y/;
574 qr/y/ ~~ [qw(foo bar baz quux)];
575 [qw(1foo 2bar)] ~~ 2;
576 2 ~~ [qw(1foo 2bar)];
577 [qw(1foo 2bar)] ~~ "2";
578 "2" ~~ [qw(1foo 2bar)];
603 @nums ~~ [ 1 .. 10 ];
604 [ 1 .. 10 ] ~~ @nums;
617 expect => <<'#9...........',
618 # We usually want a space at '} (', for example:
619 map { 1 * $_; } ( $y, $M, $w, $d, $h, $m, $s );
622 &{ $_->[1] }( delete $_[$#_]{ $_->[0] } );
624 # remove unwanted spaces after $ and -> here
625 &{ $_->[1] }( delete $_[$#_]{ $_->[0] } );
627 # this has both tabs and spaces to remove
628 $setup = $labels->labelsetup( Output_Width => 2.625 );
635 expect => <<'#10...........',
636 # space before this opening paren
637 for $i ( 0 .. 20 ) { }
639 # retain any space between '-' and bare word
640 $myhash{ USER-NAME } = 'steve';
647 expect => <<'#11...........',
648 # Treat newline as a whitespace. Otherwise, we might combine
649 # 'Send' and '-recipients' here
650 my $msg = new Fax::Send
659 expect => <<'#12...........',
660 # first prototype line will cause space between 'redirect' and '(' to close
661 sub html::redirect($); #<-- temporary prototype;
663 print html::redirect('http://www.glob.com.au/');
670 expect => <<'#13...........',
671 # first prototype line commented out; space after 'redirect' remains
672 #sub html::redirect($); #<-- temporary prototype;
674 print html::redirect ('http://www.glob.com.au/');
679 'structure1.def' => {
680 source => "structure1",
682 expect => <<'#14...........',
685 { -width => '100%' },
688 { -align => 'left' },
689 "The emboldened field names are mandatory, ",
690 "the remainder are optional",
693 { -align => 'right' },
695 { -href => 'help.cgi', -target => '_blank' },
696 "What are the various fields?"
707 expect => <<'#15...........',
708 # This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence
709 sub arrange_topframe {
718 @speed_frame[ 1 .. $#speed_frame ],
719 @power_frame[ 1 .. $#power_frame ],
726 5 + $#speed_frame + $#power_frame,
728 6 + $#speed_frame + $#power_frame,
729 4 .. 3 + $#speed_frame,
730 5 + $#speed_frame .. 4 + $#speed_frame + $#power_frame
734 my (%gridslaves) = map { ( $_, 1 ) } $top_frame->gridSlaves;
735 for ( my $i = 0 ; $i <= $#order ; $i++ ) {
737 next unless Tk::Exists($w);
738 my $col = $col[$i] || 0;
739 $width += $w->reqwidth;
740 if ( $gridslaves{$w} ) {
743 if ( $width <= $top->width ) {
759 expect => <<'#16...........',
760 # This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence
761 sub arrange_topframe {
763 $hslabel_frame, $km_frame, $speed_frame[0],
764 $power_frame[0], $wind_frame, $percent_frame, $temp_frame,
765 @speed_frame[1 .. $#speed_frame],
766 @power_frame[1 .. $#power_frame],
771 5 + $#speed_frame + $#power_frame,
773 6 + $#speed_frame + $#power_frame,
774 4 .. 3 + $#speed_frame,
775 5 + $#speed_frame .. 4 + $#speed_frame + $#power_frame
779 my (%gridslaves) = map { ($_, 1) } $top_frame->gridSlaves;
780 for (my $i = 0; $i <= $#order; $i++) {
782 next unless Tk::Exists($w);
783 my $col = $col[$i] || 0;
784 $width += $w->reqwidth;
785 if ($gridslaves{$w}) {
788 if ($width <= $top->width) {
804 expect => <<'#17...........',
805 # This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence
806 sub arrange_topframe {
808 $hslabel_frame, $km_frame,
809 $speed_frame[0], $power_frame[0],
810 $wind_frame, $percent_frame,
811 $temp_frame, @speed_frame[1..$#speed_frame],
812 @power_frame[1..$#power_frame],
819 5 + $#speed_frame + $#power_frame,
821 6 + $#speed_frame + $#power_frame,
822 4..3 + $#speed_frame,
823 5 + $#speed_frame..4 + $#speed_frame + $#power_frame
827 my (%gridslaves) = map { ($_, 1) } $top_frame->gridSlaves;
828 for (my $i = 0; $i <= $#order; $i++) {
830 next unless Tk::Exists($w);
831 my $col = $col[$i] || 0;
832 $width += $w->reqwidth;
833 if ($gridslaves{$w}) {
836 if ($width <= $top->width) {
852 expect => <<'#18...........',
853 # This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence
854 sub arrange_topframe {
856 $hslabel_frame, $km_frame, $speed_frame[0], $power_frame[0], $wind_frame, $percent_frame, $temp_frame,
857 @speed_frame[ 1 .. $#speed_frame ],
858 @power_frame[ 1 .. $#power_frame ],
863 5 + $#speed_frame + $#power_frame,
865 6 + $#speed_frame + $#power_frame,
866 4 .. 3 + $#speed_frame,
867 5 + $#speed_frame .. 4 + $#speed_frame + $#power_frame
871 my (%gridslaves) = map { ( $_, 1 ) } $top_frame->gridSlaves;
872 for ( my $i = 0 ; $i <= $#order ; $i++ ) {
874 next unless Tk::Exists($w);
875 my $col = $col[$i] || 0;
876 $width += $w->reqwidth;
877 if ( $gridslaves{$w} ) {
880 if ( $width <= $top->width ) {
888 } ## end sub arrange_topframe
896 expect => <<'#19...........',
897 # This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence
898 sub arrange_topframe {
900 $hslabel_frame, $km_frame,
901 $speed_frame[0], $power_frame[0],
902 $wind_frame, $percent_frame,
903 $temp_frame, @speed_frame[1 .. $#speed_frame],
904 @power_frame[1 .. $#power_frame],
911 5 + $#speed_frame + $#power_frame,
913 6 + $#speed_frame + $#power_frame,
914 4 .. 3 + $#speed_frame,
915 5 + $#speed_frame .. 4 + $#speed_frame + $#power_frame
919 my (%gridslaves) = map { ($_, 1) } $top_frame->gridSlaves;
920 for (my $i = 0 ; $i <= $#order ; $i++) {
922 next unless Tk::Exists($w);
923 my $col = $col[$i] || 0;
924 $width += $w->reqwidth;
925 if ($gridslaves{$w}) {
928 if ($width <= $top->width) {
944 expect => <<'#20...........',
945 # This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence
949 $hslabel_frame, $km_frame,
950 $speed_frame[0], $power_frame[0],
951 $wind_frame, $percent_frame,
952 $temp_frame, @speed_frame[1 .. $#speed_frame],
953 @power_frame[1 .. $#power_frame],
960 5 + $#speed_frame + $#power_frame,
962 6 + $#speed_frame + $#power_frame,
963 4 .. 3 + $#speed_frame,
964 5 + $#speed_frame .. 4 + $#speed_frame + $#power_frame
968 my (%gridslaves) = map { ($_, 1) } $top_frame->gridSlaves;
969 for (my $i = 0; $i <= $#order; $i++)
972 next unless Tk::Exists($w);
973 my $col = $col[$i] || 0;
974 $width += $w->reqwidth;
979 if ($width <= $top->width)
994 my $ntests = 0 + keys %{$rtests};
995 plan tests => $ntests;
1002 foreach my $key ( sort keys %{$rtests} ) {
1004 my $sname = $rtests->{$key}->{source};
1005 my $expect = $rtests->{$key}->{expect};
1006 my $pname = $rtests->{$key}->{params};
1007 my $source = $rsources->{$sname};
1008 my $params = defined($pname) ? $rparams->{$pname} : "";
1010 my $errorfile_string;
1011 my $err = Perl::Tidy::perltidy(
1013 destination => \$output,
1014 perltidyrc => \$params,
1015 argv => '', # for safety; hide any ARGV from perltidy
1016 stderr => \$stderr_string,
1017 errorfile => \$errorfile_string, # not used when -se flag is set
1019 if ( $err || $stderr_string || $errorfile_string ) {
1020 print STDERR "Error output received for test '$key'\n";
1022 print STDERR "An error flag '$err' was returned\n";
1025 if ($stderr_string) {
1026 print STDERR "---------------------\n";
1027 print STDERR "<<STDERR>>\n$stderr_string\n";
1028 print STDERR "---------------------\n";
1029 ok( !$stderr_string );
1031 if ($errorfile_string) {
1032 print STDERR "---------------------\n";
1033 print STDERR "<<.ERR file>>\n$errorfile_string\n";
1034 print STDERR "---------------------\n";
1035 ok( !$errorfile_string );
1039 if ( !is( $output, $expect, $key ) ) {
1040 my $leno = length($output);
1041 my $lene = length($expect);
1042 if ( $leno == $lene ) {
1044 "#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
1048 "#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";