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     {
 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 }