t/snippets18.t

   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         case $words[0]:
 614         case $words[1]:
 615         case $words[2]:
 616         case $words[3]: { 'ok' }
 617       default: { 'wtf' }
 618     }
 619   };
 620
 621 try {
 622     die;
 623 }
 624 catch {
 625     die;
 626 };
 627 #7...........
 628         },
 629
 630         'braces.def' => {
 631             source => "braces",
 632             params => "def",
 633             expect => <<'#8...........',
 634 sub message {
 635     if ( !defined( $_[0] ) ) {
 636         print("Hello, World\n");
 637     }
 638     else {
 639         print( $_[0], "\n" );
 640     }
 641 }
 642
 643 $myfun = sub {
 644     print("Hello, World\n");
 645 };
 646
 647 eval {
 648     my $app = App::perlbrew->new( "install-patchperl", "-q" );
 649     $app->run();
 650 } or do {
 651     $error          = $@;
 652     $produced_error = 1;
 653 };
 654
 655 Mojo::IOLoop->next_tick(
 656     sub {
 657         $ua->get(
 658             '/' => sub {
 659                 push @kept_alive, pop->kept_alive;
 660                 Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
 661             }
 662         );
 663     }
 664 );
 665
 666 $r = do {
 667     sswitch( $words[ rand @words ] ) {
 668         case $words[0]:
 669         case $words[1]:
 670         case $words[2]:
 671         case $words[3]: { 'ok' }
 672       default: { 'wtf' }
 673     }
 674 };
 675
 676 try {
 677     die;
 678 }
 679 catch {
 680     die;
 681 };
 682 #8...........
 683         },
 684
 685         'csc.csc1' => {
 686             source => "csc",
 687             params => "csc1",
 688             expect => <<'#9...........',
 689         sub message {
 690             if ( !defined( $_[0] ) ) {
 691                 print("Hello, World\n");
 692             } ## end if ( !defined( $_[0] ))
 693             else {
 694                 print( $_[0], "\n" );
 695             } ## end else [ if ( !defined( $_[0] ))
 696         } ## end sub message
 697 #9...........
 698         },
 699
 700         'csc.csc2' => {
 701             source => "csc",
 702             params => "csc2",
 703             expect => <<'#10...........',
 704         sub message {
 705             if ( !defined( $_[0] ) ) {
 706                 print("Hello, World\n");
 707             }
 708             else {
 709                 print( $_[0], "\n" );
 710             }
 711         }
 712 #10...........
 713         },
 714
 715         'csc.def' => {
 716             source => "csc",
 717             params => "def",
 718             expect => <<'#11...........',
 719         sub message {
 720             if ( !defined( $_[0] ) ) {
 721                 print("Hello, World\n");
 722             }
 723             else {
 724                 print( $_[0], "\n" );
 725             }
 726         } ## end sub message
 727 #11...........
 728         },
 729
 730         'iob.def' => {
 731             source => "iob",
 732             params => "def",
 733             expect => <<'#12...........',
 734 return "this is a descriptive error message"
 735   if $res->is_error
 736   or not length $data;
 737 #12...........
 738         },
 739
 740         'iob.iob' => {
 741             source => "iob",
 742             params => "iob",
 743             expect => <<'#13...........',
 744 return "this is a descriptive error message"
 745   if $res->is_error or not length $data;
 746 #13...........
 747         },
 748
 749         'kis.def' => {
 750             source => "kis",
 751             params => "def",
 752             expect => <<'#14...........',
 753     dbmclose(%verb_delim);
 754     undef %verb_delim;
 755     dbmclose(%expanded);
 756     undef %expanded;
 757 #14...........
 758         },
 759
 760         'kis.kis' => {
 761             source => "kis",
 762             params => "kis",
 763             expect => <<'#15...........',
 764     dbmclose(%verb_delim); undef %verb_delim;
 765     dbmclose(%expanded);   undef %expanded;
 766 #15...........
 767         },
 768
 769         'maths.def' => {
 770             source => "maths",
 771             params => "def",
 772             expect => <<'#16...........',
 773 $tmp =
 774   $day - 32075 +
 775   1461 * ( $year + 4800 - ( 14 - $month ) / 12 ) / 4 +
 776   367 * ( $month - 2 + ( ( 14 - $month ) / 12 ) * 12 ) / 12 -
 777   3 * ( ( $year + 4900 - ( 14 - $month ) / 12 ) / 100 ) / 4;
 778
 779 return ( $r**$n ) *
 780   ( pi**( $n / 2 ) ) /
 781   (
 782     sqrt(pi) *
 783       factorial( 2 * ( int( $n / 2 ) ) + 2 ) /
 784       factorial( int( $n / 2 ) + 1 ) /
 785       ( 4**( int( $n / 2 ) + 1 ) ) );
 786
 787 $root = -$b + sqrt( $b * $b - 4. * $a * $c ) / ( 2. * $a );
 788 #16...........
 789         },
 790
 791         'maths.maths1' => {
 792             source => "maths",
 793             params => "maths1",
 794             expect => <<'#17...........',
 795 $tmp
 796   =$day-32075
 797   +1461*( $year+4800-( 14-$month )/12 )/4
 798   +367*( $month-2+( ( 14-$month )/12 )*12 )/12
 799   -3*( ( $year+4900-( 14-$month )/12 )/100 )/4;
 800
 801 return ( $r**$n )
 802   *( pi**( $n/2 ) )
 803   /(
 804     sqrt(pi)
 805       *factorial( 2*( int( $n/2 ) )+2 )
 806       /factorial( int( $n/2 )+1 )
 807       /( 4**( int( $n/2 )+1 ) ) );
 808
 809 $root=-$b+sqrt( $b*$b-4.*$a*$c )/( 2.*$a );
 810 #17...........
 811         },
 812
 813         'maths.maths2' => {
 814             source => "maths",
 815             params => "maths2",
 816             expect => <<'#18...........',
 817 $tmp=
 818   $day-32075+
 819   1461*( $year+4800-( 14-$month )/12 )/4+
 820   367*( $month-2+( ( 14-$month )/12 )*12 )/12-
 821   3*( ( $year+4900-( 14-$month )/12 )/100 )/4;
 822
 823 return ( $r**$n )*
 824   ( pi**( $n/2 ) )/
 825   (
 826     sqrt(pi)*
 827       factorial( 2*( int( $n/2 ) )+2 )/
 828       factorial( int( $n/2 )+1 )/
 829       ( 4**( int( $n/2 )+1 ) ) );
 830
 831 $root=-$b+sqrt( $b*$b-4.*$a*$c )/( 2.*$a );
 832 #18...........
 833         },
 834
 835         'misc_tests.def' => {
 836             source => "misc_tests",
 837             params => "def",
 838             expect => <<'#19...........',
 839 for ( @a = @$ap, $u = shift @a ; @a ; $u = $v ) { ... }    # test -sfs
 840 $i = 1;                                                    #  test -sts
 841 $i = 0;                                                    ##  =1;  test -ssc
 842 ;                                                          # test -ndsm
 843 my ( $a, $b, $c ) = @_;                                    # test -nsak="my for"
 844 #19...........
 845         },
 846     };
 847
 848     my $ntests = 0 + keys %{$rtests};
 849     plan tests => $ntests;
 850 }
 851
 852 ###############
 853 # EXECUTE TESTS
 854 ###############
 855
 856 foreach my $key ( sort keys %{$rtests} ) {
 857     my $output;
 858     my $sname  = $rtests->{$key}->{source};
 859     my $expect = $rtests->{$key}->{expect};
 860     my $pname  = $rtests->{$key}->{params};
 861     my $source = $rsources->{$sname};
 862     my $params = defined($pname) ? $rparams->{$pname} : "";
 863     my $stderr_string;
 864     my $errorfile_string;
 865     my $err = Perl::Tidy::perltidy(
 866         source      => \$source,
 867         destination => \$output,
 868         perltidyrc  => \$params,
 869         argv        => '',             # for safety; hide any ARGV from perltidy
 870         stderr      => \$stderr_string,
 871         errorfile   => \$errorfile_string,    # not used when -se flag is set
 872     );
 873     if ( $err || $stderr_string || $errorfile_string ) {
 874         print STDERR "Error output received for test '$key'\n";
 875         if ($err) {
 876             print STDERR "An error flag '$err' was returned\n";
 877             ok( !$err );
 878         }
 879         if ($stderr_string) {
 880             print STDERR "---------------------\n";
 881             print STDERR "<<STDERR>>\n$stderr_string\n";
 882             print STDERR "---------------------\n";
 883             ok( !$stderr_string );
 884         }
 885         if ($errorfile_string) {
 886             print STDERR "---------------------\n";
 887             print STDERR "<<.ERR file>>\n$errorfile_string\n";
 888             print STDERR "---------------------\n";
 889             ok( !$errorfile_string );
 890         }
 891     }
 892     else {
 893         if ( !is( $output, $expect, $key ) ) {
 894             my $leno = length($output);
 895             my $lene = length($expect);
 896             if ( $leno == $lene ) {
 897                 print STDERR
 898 "#> Test '$key' gave unexpected output.  Strings differ but both have length $leno\n";
 899             }
 900             else {
 901                 print STDERR
 902 "#> Test '$key' gave unexpected output.  String lengths differ: output=$leno, expected=$lene\n";
 903             }
 904         }
 905     }
 906 }