"Fossies" - the Fresh Open Source Software Archive

Member "Perl-Tidy-20210717/t/snippets18.t" (11 Jul 2021, 21808 Bytes) of package /linux/misc/Perl-Tidy-20210717.tar.gz:


As a special service "Fossies" has tried to format the requested text file into HTML format (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "snippets18.t": 20210402_vs_20210717.

    1 # Created with: ./make_t.pl
    2 
    3 # Contents:
    4 #1 wn7.wn
    5 #2 wn8.def
    6 #3 wn8.wn
    7 #4 comments.comments5
    8 #5 braces.braces1
    9 #6 braces.braces2
   10 #7 braces.braces3
   11 #8 braces.def
   12 #9 csc.csc1
   13 #10 csc.csc2
   14 #11 csc.def
   15 #12 iob.def
   16 #13 iob.iob
   17 #14 kis.def
   18 #15 kis.kis
   19 #16 maths.def
   20 #17 maths.maths1
   21 #18 maths.maths2
   22 #19 misc_tests.def
   23 
   24 # To locate test #13 you can search for its name or the string '#13'
   25 
   26 use strict;
   27 use Test::More;
   28 use Carp;
   29 use Perl::Tidy;
   30 my $rparams;
   31 my $rsources;
   32 my $rtests;
   33 
   34 BEGIN {
   35 
   36     ###########################################
   37     # BEGIN SECTION 1: Parameter combinations #
   38     ###########################################
   39     $rparams = {
   40         'braces1'   => "-bl -asbl",
   41         'braces2'   => "-sbl",
   42         'braces3'   => "-bli -bbvt=1",
   43         'comments5' => <<'----------',
   44 # testing --delete-side-comments and --nostatic-block-comments
   45 -dsc -nsbc
   46 ----------
   47         'csc1'   => "-csc -csci=2 -ncscb",
   48         'csc2'   => "-dcsc",
   49         'def'    => "",
   50         'iob'    => "-iob",
   51         'kis'    => "-kis",
   52         'maths1' => <<'----------',
   53 # testing -break-before-all-operators and no spaces around math operators
   54 -bbao -nwls="= + - / *"  -nwrs="= + - / *"
   55 ----------
   56         'maths2' => <<'----------',
   57 # testing -break-after-all-operators and no spaces around math operators
   58 -baao -nwls="= + - / *"  -nwrs="= + - / *"
   59 ----------
   60         'wn' => "-wn",
   61     };
   62 
   63     ############################
   64     # BEGIN SECTION 2: Sources #
   65     ############################
   66     $rsources = {
   67 
   68         'braces' => <<'----------',
   69 sub message {
   70     if ( !defined( $_[0] ) ) {
   71         print("Hello, World\n");
   72     }
   73     else {
   74         print( $_[0], "\n" );
   75     }
   76 }
   77 
   78 $myfun = sub {
   79     print("Hello, World\n");
   80 };
   81 
   82 eval {
   83     my $app = App::perlbrew->new( "install-patchperl", "-q" );
   84     $app->run();
   85 } or do {
   86     $error          = $@;
   87     $produced_error = 1;
   88 };
   89 
   90 Mojo::IOLoop->next_tick(
   91     sub {
   92         $ua->get(
   93             '/' => sub {
   94                 push @kept_alive, pop->kept_alive;
   95                 Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
   96             }
   97         );
   98     }
   99 );
  100 
  101 $r = do {
  102     sswitch( $words[ rand @words ] ) {
  103         case $words[0]:
  104         case $words[1]:
  105         case $words[2]:
  106         case $words[3]: { 'ok' }
  107       default: { 'wtf' }
  108     }
  109 };
  110 
  111 try {
  112     die;
  113 }
  114 catch {
  115     die;
  116 };
  117 ----------
  118 
  119         'comments' => <<'----------',
  120 #!/usr/bin/perl -w
  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 ] ];
  124 #>>>
  125 sub length { return length($_[0]) }    # side comment
  126                              # hanging side comment
  127                              # very longgggggggggggggggggggggggggggggggggggggggggggggggggggg hanging side comment
  128 
  129 # a blank will be inserted to prevent forming a hanging side comment
  130 sub macro_get_names { #
  131 # 
  132 # %name = macro_get_names();  (key=macrohandle, value=macroname)
  133 #
  134 ##local(%name);  # a static block comment without indentation
  135    local(%name)=();  ## a static side comment to test -ssc
  136 
  137  # a spaced block comment to test -isbc
  138    for (0..$#mac_ver) {
  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
  142 
  143    }
  144    %name;
  145 } 
  146 
  147 
  148 
  149     @month_of_year = ( 
  150         'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
  151     ##  'Dec', 'Nov'   [a static block comment with indentation]
  152         'Nov', 'Dec');
  153 
  154 
  155 {    # this side comment will not align
  156     my $IGNORE = 0;    # This is a side comment
  157                        # This is a hanging side comment
  158                        # And so is this
  159 
  160     # A blank line interrupts the hsc's; this is a block comment
  161 
  162 }
  163 
  164 # side comments at different indentation levels should not normally be aligned
  165 { { { { { ${msg} = "Hello World!"; print "My message: ${msg}\n"; } } #end level 4
  166         } # end level 3
  167     } # end level 2
  168 } # end level 1
  169 
  170 
  171 #<<<  do not let perltidy touch this unless -nfs is set
  172     my @list = (1,
  173                 1, 1,
  174                 1, 2, 1,
  175                 1, 3, 3, 1,
  176                 1, 4, 6, 4, 1,);
  177 #>>>
  178 
  179 #<<  test alternate format skipping string
  180     my @list = (1,
  181                 1, 1,
  182                 1, 2, 1,
  183                 1, 3, 3, 1,
  184                 1, 4, 6, 4, 1,);
  185 #>>
  186 
  187 
  188 
  189 # some blank lines follow
  190 
  191 
  192 
  193 =pod
  194 Some pod before __END__ to delete with -dp
  195 =cut
  196 
  197 
  198 __END__
  199 
  200 
  201 # text following __END__, not a comment
  202 
  203 
  204 =pod
  205 Some pod after __END__ to delete with -dp and trim with -trp     
  206 =cut
  207 
  208 
  209 ----------
  210 
  211         'csc' => <<'----------',
  212         sub message {
  213             if ( !defined( $_[0] ) ) {
  214                 print("Hello, World\n");
  215             }
  216             else {
  217                 print( $_[0], "\n" );
  218             }
  219         } ## end sub message
  220 ----------
  221 
  222         'iob' => <<'----------',
  223 return "this is a descriptive error message"
  224   if $res->is_error
  225   or not length $data;
  226 ----------
  227 
  228         'kis' => <<'----------',
  229     dbmclose(%verb_delim); undef %verb_delim;
  230     dbmclose(%expanded); undef %expanded;
  231 ----------
  232 
  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;
  237 
  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 ) )
  240 );
  241 
  242 $root=-$b+sqrt($b*$b-4.*$a*$c)/(2.*$a);
  243 ----------
  244 
  245         'misc_tests' => <<'----------',
  246 for ( @a = @$ap, $u = shift @a; @a; $u = $v ) { ... } # test -sfs 
  247 $i = 1 ;     #  test -sts
  248 $i = 0;    ##  =1;  test -ssc
  249 ;;;; # test -ndsm
  250 my ( $a, $b, $c ) = @_;    # test -nsak="my for"
  251 ----------
  252 
  253         'wn7' => <<'----------',
  254                     # do not weld paren to opening one-line non-paren container
  255                     $Self->_Add($SortOrderDisplay{$Field->GenerateFieldForSelectSQL()});
  256 
  257                     # this will not get welded with -wn
  258                     f(
  259                       do { 1; !!(my $x = bless []); }
  260                     );
  261 ----------
  262 
  263         'wn8' => <<'----------',
  264 	    # Former -wn blinkers, which oscillated between two states
  265 
  266 	    # fixed RULE 1 only applies to '('
  267             my $res = eval { { $die_on_fetch, 0 } };
  268 
  269             my $res = eval {
  270                 { $die_on_fetch, 0 }
  271             };
  272 
  273 	    # fixed RULE 2 applies to any inner opening token; this is a stable
  274 	    # state with -wn
  275             $app->FORM->{'appbar1'}->set_status(
  276                 _("Cannot delete zone $name: sub-zones or appellations exist.")
  277             );
  278 
  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."));
  283 ----------
  284     };
  285 
  286     ####################################
  287     # BEGIN SECTION 3: Expected output #
  288     ####################################
  289     $rtests = {
  290 
  291         'wn7.wn' => {
  292             source => "wn7",
  293             params => "wn",
  294             expect => <<'#1...........',
  295                     # do not weld paren to opening one-line non-paren container
  296                     $Self->_Add(
  297                         $SortOrderDisplay{
  298                             $Field->GenerateFieldForSelectSQL()
  299                         }
  300                     );
  301 
  302                     # this will not get welded with -wn
  303                     f(
  304                         do { 1; !!( my $x = bless [] ); }
  305                     );
  306 #1...........
  307         },
  308 
  309         'wn8.def' => {
  310             source => "wn8",
  311             params => "def",
  312             expect => <<'#2...........',
  313             # Former -wn blinkers, which oscillated between two states
  314 
  315             # fixed RULE 1 only applies to '('
  316             my $res = eval {
  317                 { $die_on_fetch, 0 }
  318             };
  319 
  320             my $res = eval {
  321                 { $die_on_fetch, 0 }
  322             };
  323 
  324             # fixed RULE 2 applies to any inner opening token; this is a stable
  325             # state with -wn
  326             $app->FORM->{'appbar1'}->set_status(
  327                 _("Cannot delete zone $name: sub-zones or appellations exist.")
  328             );
  329 
  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.")
  334             );
  335 #2...........
  336         },
  337 
  338         'wn8.wn' => {
  339             source => "wn8",
  340             params => "wn",
  341             expect => <<'#3...........',
  342             # Former -wn blinkers, which oscillated between two states
  343 
  344             # fixed RULE 1 only applies to '('
  345             my $res = eval { { $die_on_fetch, 0 } };
  346 
  347             my $res = eval {
  348                 { $die_on_fetch, 0 }
  349             };
  350 
  351             # fixed RULE 2 applies to any inner opening token; this is a stable
  352             # state with -wn
  353             $app->FORM->{'appbar1'}->set_status(
  354                 _("Cannot delete zone $name: sub-zones or appellations exist.")
  355             );
  356 
  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.")
  361             );
  362 #3...........
  363         },
  364 
  365         'comments.comments5' => {
  366             source => "comments",
  367             params => "comments5",
  368             expect => <<'#4...........',
  369 #!/usr/bin/perl -w
  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 ] ];
  373 #>>>
  374 sub length { return length( $_[0] ) }
  375 
  376 # a blank will be inserted to prevent forming a hanging side comment
  377 sub macro_get_names {
  378     #
  379     # %name = macro_get_names();  (key=macrohandle, value=macroname)
  380     #
  381     ##local(%name);  # a static block comment without indentation
  382     local (%name) = ();
  383 
  384     # a spaced block comment to test -isbc
  385     for ( 0 .. $#mac_ver ) {
  386 
  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\-]*$//;
  390 
  391     }
  392     %name;
  393 }
  394 
  395 @month_of_year = (
  396     'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
  397 
  398     ##  'Dec', 'Nov'   [a static block comment with indentation]
  399     'Nov', 'Dec'
  400 );
  401 
  402 {
  403     my $IGNORE = 0;
  404 
  405     # A blank line interrupts the hsc's; this is a block comment
  406 
  407 }
  408 
  409 # side comments at different indentation levels should not normally be aligned
  410 {
  411     {
  412         {
  413             {
  414                 { ${msg} = "Hello World!"; print "My message: ${msg}\n"; }
  415             }
  416         }
  417     }
  418 }
  419 
  420 #<<<  do not let perltidy touch this unless -nfs is set
  421     my @list = (1,
  422                 1, 1,
  423                 1, 2, 1,
  424                 1, 3, 3, 1,
  425                 1, 4, 6, 4, 1,);
  426 #>>>
  427 
  428 #<<  test alternate format skipping string
  429 my @list = ( 1, 1, 1, 1, 2, 1, 1, 3, 3, 1, 1, 4, 6, 4, 1, );
  430 
  431 #>>
  432 
  433 # some blank lines follow
  434 
  435 =pod
  436 Some pod before __END__ to delete with -dp
  437 =cut
  438 
  439 __END__
  440 
  441 
  442 # text following __END__, not a comment
  443 
  444 
  445 =pod
  446 Some pod after __END__ to delete with -dp and trim with -trp     
  447 =cut
  448 
  449 
  450 #4...........
  451         },
  452 
  453         'braces.braces1' => {
  454             source => "braces",
  455             params => "braces1",
  456             expect => <<'#5...........',
  457 sub message
  458 {
  459     if ( !defined( $_[0] ) )
  460     {
  461         print("Hello, World\n");
  462     }
  463     else
  464     {
  465         print( $_[0], "\n" );
  466     }
  467 }
  468 
  469 $myfun = sub
  470 {
  471     print("Hello, World\n");
  472 };
  473 
  474 eval {
  475     my $app = App::perlbrew->new( "install-patchperl", "-q" );
  476     $app->run();
  477 } or do
  478 {
  479     $error          = $@;
  480     $produced_error = 1;
  481 };
  482 
  483 Mojo::IOLoop->next_tick(
  484     sub
  485     {
  486         $ua->get(
  487             '/' => sub
  488             {
  489                 push @kept_alive, pop->kept_alive;
  490                 Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
  491             }
  492         );
  493     }
  494 );
  495 
  496 $r = do
  497 {
  498     sswitch( $words[ rand @words ] )
  499     {
  500         case $words[0]:
  501         case $words[1]:
  502         case $words[2]:
  503         case $words[3]: { 'ok' }
  504       default: { 'wtf' }
  505     }
  506 };
  507 
  508 try
  509 {
  510     die;
  511 }
  512 catch
  513 {
  514     die;
  515 };
  516 #5...........
  517         },
  518 
  519         'braces.braces2' => {
  520             source => "braces",
  521             params => "braces2",
  522             expect => <<'#6...........',
  523 sub message
  524 {
  525     if ( !defined( $_[0] ) ) {
  526         print("Hello, World\n");
  527     }
  528     else {
  529         print( $_[0], "\n" );
  530     }
  531 }
  532 
  533 $myfun = sub {
  534     print("Hello, World\n");
  535 };
  536 
  537 eval {
  538     my $app = App::perlbrew->new( "install-patchperl", "-q" );
  539     $app->run();
  540 } or do {
  541     $error          = $@;
  542     $produced_error = 1;
  543 };
  544 
  545 Mojo::IOLoop->next_tick(
  546     sub {
  547         $ua->get(
  548             '/' => sub {
  549                 push @kept_alive, pop->kept_alive;
  550                 Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
  551             }
  552         );
  553     }
  554 );
  555 
  556 $r = do {
  557     sswitch( $words[ rand @words ] ) {
  558         case $words[0]:
  559         case $words[1]:
  560         case $words[2]:
  561         case $words[3]: { 'ok' }
  562       default: { 'wtf' }
  563     }
  564 };
  565 
  566 try {
  567     die;
  568 }
  569 catch {
  570     die;
  571 };
  572 #6...........
  573         },
  574 
  575         'braces.braces3' => {
  576             source => "braces",
  577             params => "braces3",
  578             expect => <<'#7...........',
  579 sub message
  580   { if ( !defined( $_[0] ) )
  581       { print("Hello, World\n");
  582       }
  583     else
  584       { print( $_[0], "\n" );
  585       }
  586   }
  587 
  588 $myfun = sub {
  589     print("Hello, World\n");
  590 };
  591 
  592 eval {
  593     my $app = App::perlbrew->new( "install-patchperl", "-q" );
  594     $app->run();
  595 } or do
  596   { $error          = $@;
  597     $produced_error = 1;
  598   };
  599 
  600 Mojo::IOLoop->next_tick(
  601     sub {
  602         $ua->get(
  603             '/' => sub {
  604                 push @kept_alive, pop->kept_alive;
  605                 Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
  606             }
  607         );
  608     }
  609 );
  610 
  611 $r = do
  612   { sswitch( $words[ rand @words ] )
  613     {
  614         case $words[0]:
  615         case $words[1]:
  616         case $words[2]:
  617         case $words[3]: { 'ok' }
  618       default: { 'wtf' }
  619     }
  620   };
  621 
  622 try
  623 {
  624     die;
  625 }
  626 catch
  627 {
  628     die;
  629 };
  630 #7...........
  631         },
  632 
  633         'braces.def' => {
  634             source => "braces",
  635             params => "def",
  636             expect => <<'#8...........',
  637 sub message {
  638     if ( !defined( $_[0] ) ) {
  639         print("Hello, World\n");
  640     }
  641     else {
  642         print( $_[0], "\n" );
  643     }
  644 }
  645 
  646 $myfun = sub {
  647     print("Hello, World\n");
  648 };
  649 
  650 eval {
  651     my $app = App::perlbrew->new( "install-patchperl", "-q" );
  652     $app->run();
  653 } or do {
  654     $error          = $@;
  655     $produced_error = 1;
  656 };
  657 
  658 Mojo::IOLoop->next_tick(
  659     sub {
  660         $ua->get(
  661             '/' => sub {
  662                 push @kept_alive, pop->kept_alive;
  663                 Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
  664             }
  665         );
  666     }
  667 );
  668 
  669 $r = do {
  670     sswitch( $words[ rand @words ] ) {
  671         case $words[0]:
  672         case $words[1]:
  673         case $words[2]:
  674         case $words[3]: { 'ok' }
  675       default: { 'wtf' }
  676     }
  677 };
  678 
  679 try {
  680     die;
  681 }
  682 catch {
  683     die;
  684 };
  685 #8...........
  686         },
  687 
  688         'csc.csc1' => {
  689             source => "csc",
  690             params => "csc1",
  691             expect => <<'#9...........',
  692         sub message {
  693             if ( !defined( $_[0] ) ) {
  694                 print("Hello, World\n");
  695             } ## end if ( !defined( $_[0] ))
  696             else {
  697                 print( $_[0], "\n" );
  698             } ## end else [ if ( !defined( $_[0] ))
  699         } ## end sub message
  700 #9...........
  701         },
  702 
  703         'csc.csc2' => {
  704             source => "csc",
  705             params => "csc2",
  706             expect => <<'#10...........',
  707         sub message {
  708             if ( !defined( $_[0] ) ) {
  709                 print("Hello, World\n");
  710             }
  711             else {
  712                 print( $_[0], "\n" );
  713             }
  714         }
  715 #10...........
  716         },
  717 
  718         'csc.def' => {
  719             source => "csc",
  720             params => "def",
  721             expect => <<'#11...........',
  722         sub message {
  723             if ( !defined( $_[0] ) ) {
  724                 print("Hello, World\n");
  725             }
  726             else {
  727                 print( $_[0], "\n" );
  728             }
  729         } ## end sub message
  730 #11...........
  731         },
  732 
  733         'iob.def' => {
  734             source => "iob",
  735             params => "def",
  736             expect => <<'#12...........',
  737 return "this is a descriptive error message"
  738   if $res->is_error
  739   or not length $data;
  740 #12...........
  741         },
  742 
  743         'iob.iob' => {
  744             source => "iob",
  745             params => "iob",
  746             expect => <<'#13...........',
  747 return "this is a descriptive error message"
  748   if $res->is_error or not length $data;
  749 #13...........
  750         },
  751 
  752         'kis.def' => {
  753             source => "kis",
  754             params => "def",
  755             expect => <<'#14...........',
  756     dbmclose(%verb_delim);
  757     undef %verb_delim;
  758     dbmclose(%expanded);
  759     undef %expanded;
  760 #14...........
  761         },
  762 
  763         'kis.kis' => {
  764             source => "kis",
  765             params => "kis",
  766             expect => <<'#15...........',
  767     dbmclose(%verb_delim); undef %verb_delim;
  768     dbmclose(%expanded);   undef %expanded;
  769 #15...........
  770         },
  771 
  772         'maths.def' => {
  773             source => "maths",
  774             params => "def",
  775             expect => <<'#16...........',
  776 $tmp =
  777   $day - 32075 +
  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;
  781 
  782 return ( $r**$n ) *
  783   ( pi**( $n / 2 ) ) /
  784   (
  785     sqrt(pi) *
  786       factorial( 2 * ( int( $n / 2 ) ) + 2 ) /
  787       factorial( int( $n / 2 ) + 1 ) /
  788       ( 4**( int( $n / 2 ) + 1 ) ) );
  789 
  790 $root = -$b + sqrt( $b * $b - 4. * $a * $c ) / ( 2. * $a );
  791 #16...........
  792         },
  793 
  794         'maths.maths1' => {
  795             source => "maths",
  796             params => "maths1",
  797             expect => <<'#17...........',
  798 $tmp
  799   =$day-32075
  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;
  803 
  804 return ( $r**$n )
  805   *( pi**( $n/2 ) )
  806   /(
  807     sqrt(pi)
  808       *factorial( 2*( int( $n/2 ) )+2 )
  809       /factorial( int( $n/2 )+1 )
  810       /( 4**( int( $n/2 )+1 ) ) );
  811 
  812 $root=-$b+sqrt( $b*$b-4.*$a*$c )/( 2.*$a );
  813 #17...........
  814         },
  815 
  816         'maths.maths2' => {
  817             source => "maths",
  818             params => "maths2",
  819             expect => <<'#18...........',
  820 $tmp=
  821   $day-32075+
  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;
  825 
  826 return ( $r**$n )*
  827   ( pi**( $n/2 ) )/
  828   (
  829     sqrt(pi)*
  830       factorial( 2*( int( $n/2 ) )+2 )/
  831       factorial( int( $n/2 )+1 )/
  832       ( 4**( int( $n/2 )+1 ) ) );
  833 
  834 $root=-$b+sqrt( $b*$b-4.*$a*$c )/( 2.*$a );
  835 #18...........
  836         },
  837 
  838         'misc_tests.def' => {
  839             source => "misc_tests",
  840             params => "def",
  841             expect => <<'#19...........',
  842 for ( @a = @$ap, $u = shift @a ; @a ; $u = $v ) { ... }    # test -sfs
  843 $i = 1;                                                    #  test -sts
  844 $i = 0;                                                    ##  =1;  test -ssc
  845 ;                                                          # test -ndsm
  846 my ( $a, $b, $c ) = @_;                                    # test -nsak="my for"
  847 #19...........
  848         },
  849     };
  850 
  851     my $ntests = 0 + keys %{$rtests};
  852     plan tests => $ntests;
  853 }
  854 
  855 ###############
  856 # EXECUTE TESTS
  857 ###############
  858 
  859 foreach my $key ( sort keys %{$rtests} ) {
  860     my $output;
  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} : "";
  866     my $stderr_string;
  867     my $errorfile_string;
  868     my $err = Perl::Tidy::perltidy(
  869         source      => \$source,
  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
  875     );
  876     if ( $err || $stderr_string || $errorfile_string ) {
  877         print STDERR "Error output received for test '$key'\n";
  878         if ($err) {
  879             print STDERR "An error flag '$err' was returned\n";
  880             ok( !$err );
  881         }
  882         if ($stderr_string) {
  883             print STDERR "---------------------\n";
  884             print STDERR "<<STDERR>>\n$stderr_string\n";
  885             print STDERR "---------------------\n";
  886             ok( !$stderr_string );
  887         }
  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 );
  893         }
  894     }
  895     else {
  896         if ( !is( $output, $expect, $key ) ) {
  897             my $leno = length($output);
  898             my $lene = length($expect);
  899             if ( $leno == $lene ) {
  900                 print STDERR
  901 "#> Test '$key' gave unexpected output.  Strings differ but both have length $leno\n";
  902             }
  903             else {
  904                 print STDERR
  905 "#> Test '$key' gave unexpected output.  String lengths differ: output=$leno, expected=$lene\n";
  906             }
  907         }
  908     }
  909 }