1 # Created with: ./make_t.pl
24 # To locate test #13 you can search for its name or the string '#13'
36 ###########################################
37 # BEGIN SECTION 1: Parameter combinations #
38 ###########################################
40 'braces1' => "-bl -asbl",
42 'braces3' => "-bli -bbvt=1",
43 'comments5' => <<'----------',
44 # testing --delete-side-comments and --nostatic-block-comments
47 'csc1' => "-csc -csci=2 -ncscb",
52 'maths1' => <<'----------',
53 # testing -break-before-all-operators and no spaces around math operators
54 -bbao -nwls="= + - / *" -nwrs="= + - / *"
56 'maths2' => <<'----------',
57 # testing -break-after-all-operators and no spaces around math operators
58 -baao -nwls="= + - / *" -nwrs="= + - / *"
63 ############################
64 # BEGIN SECTION 2: Sources #
65 ############################
68 'braces' => <<'----------',
70 if ( !defined( $_[0] ) ) {
71 print("Hello, World\n");
79 print("Hello, World\n");
83 my $app = App::perlbrew->new( "install-patchperl", "-q" );
90 Mojo::IOLoop->next_tick(
94 push @kept_alive, pop->kept_alive;
95 Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
102 sswitch( $words[ rand @words ] ) {
106 case $words[3]: { 'ok' }
119 'comments' => <<'----------',
121 # an initial hash bang line cannot be deleted with -dp
122 #<<< format skipping of first code can cause an error message in perltidy v20210625
123 my $rvar = [ [ 1, 2, 3 ], [ 4, 5, 6 ] ];
125 sub length { return length($_[0]) } # side comment
126 # hanging side comment
127 # very longgggggggggggggggggggggggggggggggggggggggggggggggggggg hanging side comment
129 # a blank will be inserted to prevent forming a hanging side comment
130 sub macro_get_names { #
132 # %name = macro_get_names(); (key=macrohandle, value=macroname)
134 ##local(%name); # a static block comment without indentation
135 local(%name)=(); ## a static side comment to test -ssc
137 # a spaced block comment to test -isbc
139 # a very long comment for testing the parameter --nooutdent-long-comments (or -nolc)
140 $name{$_} = $mac_ext[$idx{$mac_exti[$_]}];
141 $vmsfile =~ s/;[\d\-]*$//; # very long side comment; Clip off version number; we can use a newer version as well
150 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
151 ## 'Dec', 'Nov' [a static block comment with indentation]
155 { # this side comment will not align
156 my $IGNORE = 0; # This is a side comment
157 # This is a hanging side comment
160 # A blank line interrupts the hsc's; this is a block comment
164 # side comments at different indentation levels should not normally be aligned
165 { { { { { ${msg} = "Hello World!"; print "My message: ${msg}\n"; } } #end level 4
171 #<<< do not let perltidy touch this unless -nfs is set
179 #<< test alternate format skipping string
189 # some blank lines follow
194 Some pod before __END__ to delete with -dp
201 # text following __END__, not a comment
205 Some pod after __END__ to delete with -dp and trim with -trp
211 'csc' => <<'----------',
213 if ( !defined( $_[0] ) ) {
214 print("Hello, World\n");
217 print( $_[0], "\n" );
222 'iob' => <<'----------',
223 return "this is a descriptive error message"
228 'kis' => <<'----------',
229 dbmclose(%verb_delim); undef %verb_delim;
230 dbmclose(%expanded); undef %expanded;
233 'maths' => <<'----------',
234 $tmp = $day - 32075 + 1461 * ( $year + 4800 - ( 14 - $month ) / 12 ) / 4 + 367
235 * ( $month - 2 + ( ( 14 - $month ) / 12 ) * 12 ) / 12 - 3 * ( ( $year + 4900 -
236 ( 14 - $month ) / 12 ) / 100 ) / 4;
238 return ( $r**$n ) * ( pi**( $n / 2 ) ) / ( sqrt(pi) * factorial( 2 * ( int( $n
239 / 2 ) ) + 2 ) / factorial( int( $n / 2 ) + 1 ) / ( 4**( int( $n / 2 ) + 1 ) )
242 $root=-$b+sqrt($b*$b-4.*$a*$c)/(2.*$a);
245 'misc_tests' => <<'----------',
246 for ( @a = @$ap, $u = shift @a; @a; $u = $v ) { ... } # test -sfs
248 $i = 0; ## =1; test -ssc
250 my ( $a, $b, $c ) = @_; # test -nsak="my for"
253 'wn7' => <<'----------',
254 # do not weld paren to opening one-line non-paren container
255 $Self->_Add($SortOrderDisplay{$Field->GenerateFieldForSelectSQL()});
257 # this will not get welded with -wn
259 do { 1; !!(my $x = bless []); }
263 'wn8' => <<'----------',
264 # Former -wn blinkers, which oscillated between two states
266 # fixed RULE 1 only applies to '('
267 my $res = eval { { $die_on_fetch, 0 } };
273 # fixed RULE 2 applies to any inner opening token; this is a stable
275 $app->FORM->{'appbar1'}->set_status(
276 _("Cannot delete zone $name: sub-zones or appellations exist.")
279 # OLD: fixed RULE 1: this is now a stable state with -wn
280 # NEW (30 jan 2021): do not weld if one interior token
281 $app->FORM->{'appbar1'}->set_status(_(
282 "Cannot delete zone $name: sub-zones or appellations exist."));
286 ####################################
287 # BEGIN SECTION 3: Expected output #
288 ####################################
294 expect => <<'#1...........',
295 # do not weld paren to opening one-line non-paren container
298 $Field->GenerateFieldForSelectSQL()
302 # this will not get welded with -wn
304 do { 1; !!( my $x = bless [] ); }
312 expect => <<'#2...........',
313 # Former -wn blinkers, which oscillated between two states
315 # fixed RULE 1 only applies to '('
324 # fixed RULE 2 applies to any inner opening token; this is a stable
326 $app->FORM->{'appbar1'}->set_status(
327 _("Cannot delete zone $name: sub-zones or appellations exist.")
330 # OLD: fixed RULE 1: this is now a stable state with -wn
331 # NEW (30 jan 2021): do not weld if one interior token
332 $app->FORM->{'appbar1'}->set_status(
333 _("Cannot delete zone $name: sub-zones or appellations exist.")
341 expect => <<'#3...........',
342 # Former -wn blinkers, which oscillated between two states
344 # fixed RULE 1 only applies to '('
345 my $res = eval { { $die_on_fetch, 0 } };
351 # fixed RULE 2 applies to any inner opening token; this is a stable
353 $app->FORM->{'appbar1'}->set_status(
354 _("Cannot delete zone $name: sub-zones or appellations exist.")
357 # OLD: fixed RULE 1: this is now a stable state with -wn
358 # NEW (30 jan 2021): do not weld if one interior token
359 $app->FORM->{'appbar1'}->set_status(
360 _("Cannot delete zone $name: sub-zones or appellations exist.")
365 'comments.comments5' => {
366 source => "comments",
367 params => "comments5",
368 expect => <<'#4...........',
370 # an initial hash bang line cannot be deleted with -dp
371 #<<< format skipping of first code can cause an error message in perltidy v20210625
372 my $rvar = [ [ 1, 2, 3 ], [ 4, 5, 6 ] ];
374 sub length { return length( $_[0] ) }
376 # a blank will be inserted to prevent forming a hanging side comment
377 sub macro_get_names {
379 # %name = macro_get_names(); (key=macrohandle, value=macroname)
381 ##local(%name); # a static block comment without indentation
384 # a spaced block comment to test -isbc
385 for ( 0 .. $#mac_ver ) {
387 # a very long comment for testing the parameter --nooutdent-long-comments (or -nolc)
388 $name{$_} = $mac_ext[ $idx{ $mac_exti[$_] } ];
389 $vmsfile =~ s/;[\d\-]*$//;
396 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
398 ## 'Dec', 'Nov' [a static block comment with indentation]
405 # A blank line interrupts the hsc's; this is a block comment
409 # side comments at different indentation levels should not normally be aligned
414 { ${msg} = "Hello World!"; print "My message: ${msg}\n"; }
420 #<<< do not let perltidy touch this unless -nfs is set
428 #<< test alternate format skipping string
429 my @list = ( 1, 1, 1, 1, 2, 1, 1, 3, 3, 1, 1, 4, 6, 4, 1, );
433 # some blank lines follow
436 Some pod before __END__ to delete with -dp
442 # text following __END__, not a comment
446 Some pod after __END__ to delete with -dp and trim with -trp
453 'braces.braces1' => {
456 expect => <<'#5...........',
459 if ( !defined( $_[0] ) )
461 print("Hello, World\n");
465 print( $_[0], "\n" );
471 print("Hello, World\n");
475 my $app = App::perlbrew->new( "install-patchperl", "-q" );
483 Mojo::IOLoop->next_tick(
489 push @kept_alive, pop->kept_alive;
490 Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
498 sswitch( $words[ rand @words ] )
503 case $words[3]: { 'ok' }
519 'braces.braces2' => {
522 expect => <<'#6...........',
525 if ( !defined( $_[0] ) ) {
526 print("Hello, World\n");
529 print( $_[0], "\n" );
534 print("Hello, World\n");
538 my $app = App::perlbrew->new( "install-patchperl", "-q" );
545 Mojo::IOLoop->next_tick(
549 push @kept_alive, pop->kept_alive;
550 Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
557 sswitch( $words[ rand @words ] ) {
561 case $words[3]: { 'ok' }
575 'braces.braces3' => {
578 expect => <<'#7...........',
580 { if ( !defined( $_[0] ) )
581 { print("Hello, World\n");
584 { print( $_[0], "\n" );
589 print("Hello, World\n");
593 my $app = App::perlbrew->new( "install-patchperl", "-q" );
600 Mojo::IOLoop->next_tick(
604 push @kept_alive, pop->kept_alive;
605 Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
612 { sswitch( $words[ rand @words ] )
617 case $words[3]: { 'ok' }
636 expect => <<'#8...........',
638 if ( !defined( $_[0] ) ) {
639 print("Hello, World\n");
642 print( $_[0], "\n" );
647 print("Hello, World\n");
651 my $app = App::perlbrew->new( "install-patchperl", "-q" );
658 Mojo::IOLoop->next_tick(
662 push @kept_alive, pop->kept_alive;
663 Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
670 sswitch( $words[ rand @words ] ) {
674 case $words[3]: { 'ok' }
691 expect => <<'#9...........',
693 if ( !defined( $_[0] ) ) {
694 print("Hello, World\n");
695 } ## end if ( !defined( $_[0] ))
697 print( $_[0], "\n" );
698 } ## end else [ if ( !defined( $_[0] ))
706 expect => <<'#10...........',
708 if ( !defined( $_[0] ) ) {
709 print("Hello, World\n");
712 print( $_[0], "\n" );
721 expect => <<'#11...........',
723 if ( !defined( $_[0] ) ) {
724 print("Hello, World\n");
727 print( $_[0], "\n" );
736 expect => <<'#12...........',
737 return "this is a descriptive error message"
746 expect => <<'#13...........',
747 return "this is a descriptive error message"
748 if $res->is_error or not length $data;
755 expect => <<'#14...........',
756 dbmclose(%verb_delim);
766 expect => <<'#15...........',
767 dbmclose(%verb_delim); undef %verb_delim;
768 dbmclose(%expanded); undef %expanded;
775 expect => <<'#16...........',
778 1461 * ( $year + 4800 - ( 14 - $month ) / 12 ) / 4 +
779 367 * ( $month - 2 + ( ( 14 - $month ) / 12 ) * 12 ) / 12 -
780 3 * ( ( $year + 4900 - ( 14 - $month ) / 12 ) / 100 ) / 4;
786 factorial( 2 * ( int( $n / 2 ) ) + 2 ) /
787 factorial( int( $n / 2 ) + 1 ) /
788 ( 4**( int( $n / 2 ) + 1 ) ) );
790 $root = -$b + sqrt( $b * $b - 4. * $a * $c ) / ( 2. * $a );
797 expect => <<'#17...........',
800 +1461*( $year+4800-( 14-$month )/12 )/4
801 +367*( $month-2+( ( 14-$month )/12 )*12 )/12
802 -3*( ( $year+4900-( 14-$month )/12 )/100 )/4;
808 *factorial( 2*( int( $n/2 ) )+2 )
809 /factorial( int( $n/2 )+1 )
810 /( 4**( int( $n/2 )+1 ) ) );
812 $root=-$b+sqrt( $b*$b-4.*$a*$c )/( 2.*$a );
819 expect => <<'#18...........',
822 1461*( $year+4800-( 14-$month )/12 )/4+
823 367*( $month-2+( ( 14-$month )/12 )*12 )/12-
824 3*( ( $year+4900-( 14-$month )/12 )/100 )/4;
830 factorial( 2*( int( $n/2 ) )+2 )/
831 factorial( int( $n/2 )+1 )/
832 ( 4**( int( $n/2 )+1 ) ) );
834 $root=-$b+sqrt( $b*$b-4.*$a*$c )/( 2.*$a );
838 'misc_tests.def' => {
839 source => "misc_tests",
841 expect => <<'#19...........',
842 for ( @a = @$ap, $u = shift @a ; @a ; $u = $v ) { ... } # test -sfs
844 $i = 0; ## =1; test -ssc
846 my ( $a, $b, $c ) = @_; # test -nsak="my for"
851 my $ntests = 0 + keys %{$rtests};
852 plan tests => $ntests;
859 foreach my $key ( sort keys %{$rtests} ) {
861 my $sname = $rtests->{$key}->{source};
862 my $expect = $rtests->{$key}->{expect};
863 my $pname = $rtests->{$key}->{params};
864 my $source = $rsources->{$sname};
865 my $params = defined($pname) ? $rparams->{$pname} : "";
867 my $errorfile_string;
868 my $err = Perl::Tidy::perltidy(
870 destination => \$output,
871 perltidyrc => \$params,
872 argv => '', # for safety; hide any ARGV from perltidy
873 stderr => \$stderr_string,
874 errorfile => \$errorfile_string, # not used when -se flag is set
876 if ( $err || $stderr_string || $errorfile_string ) {
877 print STDERR "Error output received for test '$key'\n";
879 print STDERR "An error flag '$err' was returned\n";
882 if ($stderr_string) {
883 print STDERR "---------------------\n";
884 print STDERR "<<STDERR>>\n$stderr_string\n";
885 print STDERR "---------------------\n";
886 ok( !$stderr_string );
888 if ($errorfile_string) {
889 print STDERR "---------------------\n";
890 print STDERR "<<.ERR file>>\n$errorfile_string\n";
891 print STDERR "---------------------\n";
892 ok( !$errorfile_string );
896 if ( !is( $output, $expect, $key ) ) {
897 my $leno = length($output);
898 my $lene = length($expect);
899 if ( $leno == $lene ) {
901 "#> Test '$key' gave unexpected output. Strings differ but both have length $leno\n";
905 "#> Test '$key' gave unexpected output. String lengths differ: output=$leno, expected=$lene\n";