t/snippets17.t

   1 # Created with: ./make_t.pl
   2
   3 # Contents:
   4 #1 align32.def
   5 #2 bos.bos
   6 #3 bos.def
   7 #4 comments.comments1
   8 #5 comments.comments2
   9 #6 comments.comments3
  10 #7 comments.comments4
  11 #8 comments.def
  12 #9 long_line.def
  13 #10 long_line.long_line
  14 #11 pbp6.def
  15 #12 pbp6.pbp
  16 #13 rperl.def
  17 #14 rperl.rperl
  18 #15 rt132059.def
  19 #16 rt132059.rt132059
  20 #17 signature.def
  21 #18 ternary4.def
  22 #19 wn7.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         'bos'       => "-bos",
  41         'comments1' => <<'----------',
  42 # testing --fixed-position-side-comment=40,
  43 # --ignore-side-comment-lengths,
  44 # --noindent-block-comments,
  45 # --nohanging-side-comments
  46 # --static-side-comments
  47 # --trim-pod
  48 -fpsc=40 -iscl -nibc -nhsc -ssc -trp
  49 ----------
  50         'comments2' => <<'----------',
  51 # testing --minimum-space-to-comment=10, --delete-block-comments, --delete-pod
  52 -msc=10 -dbc -dp
  53 ----------
  54         'comments3' => <<'----------',
  55 # testing --maximum-consecutive-blank-lines=2 and --indent-spaced-block-comments --no-format-skipping
  56 -mbl=2 -isbc -nfs
  57 ----------
  58         'comments4' => <<'----------',
  59 # testing --keep-old-blank-lines=2 [=all] and
  60 # --nooutdent-long-comments and
  61 # --outdent-static-block-comments
  62 # --format-skipping-begin and --format-skipping-end
  63 -kbl=2 -nolc -osbc -fsb='#<{2,}' -fse='#>{2,}'
  64 ----------
  65         'def'       => "",
  66         'long_line' => "-l=0",
  67         'pbp'       => "-pbp -nst -nse",
  68         'rperl'     =>
  69           "-pbp  -nst --ignore-side-comment-lengths  --converge  -l=0  -q",
  70         'rt132059' => "-dac",
  71     };
  72
  73     ############################
  74     # BEGIN SECTION 2: Sources #
  75     ############################
  76     $rsources = {
  77
  78         'align32' => <<'----------',
  79 # should not get alignment here:
  80 my $c_sub_khwnd = WindowFromId $k_hwnd, 0x8008;    # FID_CLIENT
  81 ok $c_sub_khwnd, 'have kids client window';
  82 ok IsWindow($c_sub_khwnd), 'IsWindow works on the client';
  83 ----------
  84
  85         'bos' => <<'----------',
  86         $top_label->set_text( gettext("check permissions.") )
  87           ;
  88 ----------
  89
  90         'comments' => <<'----------',
  91 #!/usr/bin/perl -w
  92 # an initial hash bang line cannot be deleted with -dp
  93 #<<< format skipping of first code can cause an error message in perltidy v20210625
  94 my $rvar = [ [ 1, 2, 3 ], [ 4, 5, 6 ] ];
  95 #>>>
  96 sub length { return length($_[0]) }    # side comment
  97                              # hanging side comment
  98                              # very longgggggggggggggggggggggggggggggggggggggggggggggggggggg hanging side comment
  99
 100 # a blank will be inserted to prevent forming a hanging side comment
 101 sub macro_get_names { #
 102 #
 103 # %name = macro_get_names();  (key=macrohandle, value=macroname)
 104 #
 105 ##local(%name);  # a static block comment without indentation
 106    local(%name)=();  ## a static side comment to test -ssc
 107
 108  # a spaced block comment to test -isbc
 109    for (0..$#mac_ver) {
 110       # a very long comment for testing the parameter --nooutdent-long-comments (or -nolc)
 111       $name{$_} = $mac_ext[$idx{$mac_exti[$_]}];
 112       $vmsfile =~ s/;[\d\-]*$//; # very long side comment; Clip off version number; we can use a newer version as well
 113
 114    }
 115    %name;
 116 }
 117
 118
 119
 120     @month_of_year = (
 121         'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
 122     ##  'Dec', 'Nov'   [a static block comment with indentation]
 123         'Nov', 'Dec');
 124
 125
 126 {    # this side comment will not align
 127     my $IGNORE = 0;    # This is a side comment
 128                        # This is a hanging side comment
 129                        # And so is this
 130
 131     # A blank line interrupts the hsc's; this is a block comment
 132
 133 }
 134
 135 # side comments at different indentation levels should not normally be aligned
 136 { { { { { ${msg} = "Hello World!"; print "My message: ${msg}\n"; } } #end level 4
 137         } # end level 3
 138     } # end level 2
 139 } # end level 1
 140
 141
 142 #<<<  do not let perltidy touch this unless -nfs is set
 143     my @list = (1,
 144                 1, 1,
 145                 1, 2, 1,
 146                 1, 3, 3, 1,
 147                 1, 4, 6, 4, 1,);
 148 #>>>
 149
 150 #<<  test alternate format skipping string
 151     my @list = (1,
 152                 1, 1,
 153                 1, 2, 1,
 154                 1, 3, 3, 1,
 155                 1, 4, 6, 4, 1,);
 156 #>>
 157
 158
 159
 160 # some blank lines follow
 161
 162
 163
 164 =pod
 165 Some pod before __END__ to delete with -dp
 166 =cut
 167
 168
 169 __END__
 170
 171
 172 # text following __END__, not a comment
 173
 174
 175 =pod
 176 Some pod after __END__ to delete with -dp and trim with -trp
 177 =cut
 178
 179
 180 ----------
 181
 182         'long_line' => <<'----------',
 183 # This single line should break into multiple lines, even with -l=0
 184 # sub 'tight_paren_follows' should break the do block
 185 $body = SOAP::Data->name('~V:Fault')->attr( { 'xmlns' => $SOAP::Constants::NS_ENV } )->value( \SOAP::Data->set_value( SOAP::Data->name( faultcode => qualify( $self->namespace => shift(@parameters) ) ), SOAP::Data->name( faultstring => shift(@parameters) ), @parameters ? SOAP::Data->name( detail => do { my $detail = shift(@parameters); ref $detail ? \$detail : $detail } ) : (), @parameters ? SOAP::Data->name( faultactor => shift(@parameters) ) : (), ) );
 186 ----------
 187
 188         'pbp6' => <<'----------',
 189         # These formerly blinked with -pbp
 190         return $width1*$common_length*(
 191           $W*atan2(1,$W)
 192         + $H*atan2(1,$H)
 193         - $RTHSQPWSQ*atan2(1,$RTHSQPWSQ)
 194         + 0.25*log(
 195          ($WSQP1*$HSQP1)/(1+$WSQ+$HSQ)
 196          *($WSQ*(1+$WSQ+$HSQ)/($WSQP1*$HSQPWSQ))**$WSQ
 197          *($HSQ*(1+$WSQ+$HSQ)/($HSQP1*$HSQPWSQ))**$HSQ
 198          )
 199          )/($W*$pi);
 200
 201         my $oldSec = ( 60 * $session->{originalStartHour} + $session->{originalStartMin} ) * 60;
 202
 203 ----------
 204
 205         'rperl' => <<'----------',
 206 # Some test cases for RPerl, https://github.com/wbraswell/rperl/
 207 # These must not remain as single lines with default formatting and long lines
 208 sub multiply_return_F { { my number $RETURN_TYPE }; ( my integer $multiplicand, my number $multiplier ) = @ARG; return $multiplicand * $multiplier; }
 209
 210 sub empty_method { { my void::method $RETURN_TYPE }; return 2; }
 211
 212 sub foo_subroutine_in_main { { my void $RETURN_TYPE }; print 'Howdy from foo_subroutine_in_main()...', "\n"; return; }
 213 ----------
 214
 215         'rt132059' => <<'----------',
 216 # Test deleting comments and pod
 217 $1=2;
 218 sub f { # a side comment
 219  # a hanging side comment
 220
 221 # a block comment
 222 }
 223
 224 =pod
 225 bonjour!
 226 =cut
 227
 228 $i++;
 229 ----------
 230
 231         'signature' => <<'----------',
 232 # git22: Preserve function signature on a single line
 233 # This behavior is controlled by 'sub weld_signature_parens'
 234
 235 sub foo($x, $y="abcd") {
 236   $x.$y;
 237 }
 238
 239 # do not break after closing do brace
 240 sub foo($x, $y=do{{}}, $z=42, $w=do{"abcd"}) {
 241   $x.$y.$z;
 242 }
 243
 244 # This signature should get put back on one line
 245 sub t022 (
 246     $p = do { $z += 10; 222 }, $a = do { $z++; 333 }
 247 ) { "$p/$a" }
 248
 249 # anonymous sub with signature
 250 my $subref = sub ( $cat, $id = do { state $auto_id = 0; $auto_id++ } ) {
 251     ...;
 252 };
 253
 254 # signature and prototype and attribute
 255 sub foo1 ( $x, $y ) : prototype ( $$ ) : shared { }
 256
 257 sub foo11 ( $thing, % ) { print $thing }
 258
 259 sub animal4 ( $cat, $ = ) {   } # second argument is optional
 260
 261 *share = sub
 262 ( \[$@%] ) { };
 263
 264 # extruded test
 265 sub foo2
 266   (
 267   $
 268   first
 269   ,
 270   $
 271   ,
 272   $
 273   third
 274   )
 275   {
 276   return
 277   "first=$first, third=$third"
 278   ;
 279   }
 280
 281 # valid attributes
 282 sub fnord (&\%) : switch(10,foo(7,3)) : expensive;
 283 sub plugh () : Ugly('\(") : Bad;
 284 ----------
 285
 286         'ternary4' => <<'----------',
 287 # some side comments
 288 *{"${callpkg}::$sym"} =
 289       $type eq '&' ? \&{"${pkg}::$sym"}    #
 290     : $type eq '$' ? \${"${pkg}::$sym"}    #
 291     : $type eq '@' ? \@{"${pkg}::$sym"}
 292     : $type eq '%' ? \%{"${pkg}::$sym"}    # side comment
 293     : $type eq '*' ? *{"${pkg}::$sym"}     #
 294     :   do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
 295 ----------
 296
 297         'wn7' => <<'----------',
 298                     # do not weld paren to opening one-line non-paren container
 299                     $Self->_Add($SortOrderDisplay{$Field->GenerateFieldForSelectSQL()});
 300
 301                     # this will not get welded with -wn
 302                     f(
 303                       do { 1; !!(my $x = bless []); }
 304                     );
 305 ----------
 306     };
 307
 308     ####################################
 309     # BEGIN SECTION 3: Expected output #
 310     ####################################
 311     $rtests = {
 312
 313         'align32.def' => {
 314             source => "align32",
 315             params => "def",
 316             expect => <<'#1...........',
 317 # should not get alignment here:
 318 my $c_sub_khwnd = WindowFromId $k_hwnd, 0x8008;    # FID_CLIENT
 319 ok $c_sub_khwnd, 'have kids client window';
 320 ok IsWindow($c_sub_khwnd), 'IsWindow works on the client';
 321 #1...........
 322         },
 323
 324         'bos.bos' => {
 325             source => "bos",
 326             params => "bos",
 327             expect => <<'#2...........',
 328         $top_label->set_text( gettext("check permissions.") )
 329           ;
 330 #2...........
 331         },
 332
 333         'bos.def' => {
 334             source => "bos",
 335             params => "def",
 336             expect => <<'#3...........',
 337         $top_label->set_text( gettext("check permissions.") );
 338 #3...........
 339         },
 340
 341         'comments.comments1' => {
 342             source => "comments",
 343             params => "comments1",
 344             expect => <<'#4...........',
 345 #!/usr/bin/perl -w
 346 # an initial hash bang line cannot be deleted with -dp
 347 #<<< format skipping of first code can cause an error message in perltidy v20210625
 348 my $rvar = [ [ 1, 2, 3 ], [ 4, 5, 6 ] ];
 349 #>>>
 350 sub length { return length( $_[0] ) }  # side comment
 351
 352 # hanging side comment
 353 # very longgggggggggggggggggggggggggggggggggggggggggggggggggggg hanging side comment
 354
 355 # a blank will be inserted to prevent forming a hanging side comment
 356 sub macro_get_names {                  #
 357
 358 #
 359 # %name = macro_get_names();  (key=macrohandle, value=macroname)
 360 #
 361 ##local(%name);  # a static block comment without indentation
 362     local (%name) = (); ## a static side comment to test -ssc
 363
 364 # a spaced block comment to test -isbc
 365     for ( 0 .. $#mac_ver ) {
 366
 367 # a very long comment for testing the parameter --nooutdent-long-comments (or -nolc)
 368         $name{$_} = $mac_ext[ $idx{ $mac_exti[$_] } ];
 369         $vmsfile =~ s/;[\d\-]*$//;     # very long side comment; Clip off version number; we can use a newer version as well
 370
 371     }
 372     %name;
 373 }
 374
 375 @month_of_year = (
 376     'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
 377 ##  'Dec', 'Nov'   [a static block comment with indentation]
 378     'Nov', 'Dec'
 379 );
 380
 381 {                                      # this side comment will not align
 382     my $IGNORE = 0;                    # This is a side comment
 383
 384 # This is a hanging side comment
 385 # And so is this
 386
 387 # A blank line interrupts the hsc's; this is a block comment
 388
 389 }
 390
 391 # side comments at different indentation levels should not normally be aligned
 392 {
 393     {
 394         {
 395             {
 396                 { ${msg} = "Hello World!"; print "My message: ${msg}\n"; }
 397             }                          #end level 4
 398         }                              # end level 3
 399     }                                  # end level 2
 400 }                                      # end level 1
 401
 402 #<<<  do not let perltidy touch this unless -nfs is set
 403     my @list = (1,
 404                 1, 1,
 405                 1, 2, 1,
 406                 1, 3, 3, 1,
 407                 1, 4, 6, 4, 1,);
 408 #>>>
 409
 410 #<<  test alternate format skipping string
 411 my @list = ( 1, 1, 1, 1, 2, 1, 1, 3, 3, 1, 1, 4, 6, 4, 1, );
 412
 413 #>>
 414
 415 # some blank lines follow
 416
 417 =pod
 418 Some pod before __END__ to delete with -dp
 419 =cut
 420
 421 __END__
 422
 423
 424 # text following __END__, not a comment
 425
 426
 427 =pod
 428 Some pod after __END__ to delete with -dp and trim with -trp
 429 =cut
 430
 431
 432 #4...........
 433         },
 434
 435         'comments.comments2' => {
 436             source => "comments",
 437             params => "comments2",
 438             expect => <<'#5...........',
 439 #!/usr/bin/perl -w
 440 #<<< format skipping of first code can cause an error message in perltidy v20210625
 441 my $rvar = [ [ 1, 2, 3 ], [ 4, 5, 6 ] ];
 442 #>>>
 443 sub length { return length( $_[0] ) }          # side comment
 444                                                # hanging side comment
 445  # very longgggggggggggggggggggggggggggggggggggggggggggggggggggg hanging side comment
 446
 447 sub macro_get_names {          #
 448     local (%name) = ();          ## a static side comment to test -ssc
 449
 450     for ( 0 .. $#mac_ver ) {
 451         $name{$_} = $mac_ext[ $idx{ $mac_exti[$_] } ];
 452         $vmsfile =~ s/;[\d\-]*$//
 453           ; # very long side comment; Clip off version number; we can use a newer version as well
 454
 455     }
 456     %name;
 457 }
 458
 459 @month_of_year = (
 460     'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
 461     'Nov', 'Dec'
 462 );
 463
 464 {          # this side comment will not align
 465     my $IGNORE = 0;          # This is a side comment
 466                              # This is a hanging side comment
 467                              # And so is this
 468
 469 }
 470
 471 {
 472     {
 473         {
 474             {
 475                 { ${msg} = "Hello World!"; print "My message: ${msg}\n"; }
 476             }          #end level 4
 477         }          # end level 3
 478     }          # end level 2
 479 }          # end level 1
 480
 481 #<<<  do not let perltidy touch this unless -nfs is set
 482     my @list = (1,
 483                 1, 1,
 484                 1, 2, 1,
 485                 1, 3, 3, 1,
 486                 1, 4, 6, 4, 1,);
 487 #>>>
 488
 489 my @list = ( 1, 1, 1, 1, 2, 1, 1, 3, 3, 1, 1, 4, 6, 4, 1, );
 490
 491
 492 __END__
 493
 494
 495 # text following __END__, not a comment
 496
 497
 498
 499
 500 #5...........
 501         },
 502
 503         'comments.comments3' => {
 504             source => "comments",
 505             params => "comments3",
 506             expect => <<'#6...........',
 507 #!/usr/bin/perl -w
 508 # an initial hash bang line cannot be deleted with -dp
 509 #<<< format skipping of first code can cause an error message in perltidy v20210625
 510 my $rvar = [ [ 1, 2, 3 ], [ 4, 5, 6 ] ];
 511
 512 #>>>
 513 sub length { return length( $_[0] ) }    # side comment
 514                                          # hanging side comment
 515  # very longgggggggggggggggggggggggggggggggggggggggggggggggggggg hanging side comment
 516
 517 # a blank will be inserted to prevent forming a hanging side comment
 518 sub macro_get_names {    #
 519
 520 #
 521 # %name = macro_get_names();  (key=macrohandle, value=macroname)
 522 #
 523 ##local(%name);  # a static block comment without indentation
 524     local (%name) = ();    ## a static side comment to test -ssc
 525
 526     # a spaced block comment to test -isbc
 527     for ( 0 .. $#mac_ver ) {
 528
 529 # a very long comment for testing the parameter --nooutdent-long-comments (or -nolc)
 530         $name{$_} = $mac_ext[ $idx{ $mac_exti[$_] } ];
 531         $vmsfile =~ s/;[\d\-]*$//
 532           ; # very long side comment; Clip off version number; we can use a newer version as well
 533
 534     }
 535     %name;
 536 }
 537
 538
 539 @month_of_year = (
 540     'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
 541     ##  'Dec', 'Nov'   [a static block comment with indentation]
 542     'Nov', 'Dec'
 543 );
 544
 545
 546 {    # this side comment will not align
 547     my $IGNORE = 0;    # This is a side comment
 548                        # This is a hanging side comment
 549                        # And so is this
 550
 551     # A blank line interrupts the hsc's; this is a block comment
 552
 553 }
 554
 555 # side comments at different indentation levels should not normally be aligned
 556 {
 557     {
 558         {
 559             {
 560                 { ${msg} = "Hello World!"; print "My message: ${msg}\n"; }
 561             }    #end level 4
 562         }    # end level 3
 563     }    # end level 2
 564 }    # end level 1
 565
 566
 567 #<<<  do not let perltidy touch this unless -nfs is set
 568 my @list = ( 1, 1, 1, 1, 2, 1, 1, 3, 3, 1, 1, 4, 6, 4, 1, );
 569
 570 #>>>
 571
 572 #<<  test alternate format skipping string
 573 my @list = ( 1, 1, 1, 1, 2, 1, 1, 3, 3, 1, 1, 4, 6, 4, 1, );
 574
 575 #>>
 576
 577
 578 # some blank lines follow
 579
 580
 581 =pod
 582 Some pod before __END__ to delete with -dp
 583 =cut
 584
 585
 586 __END__
 587
 588
 589 # text following __END__, not a comment
 590
 591
 592 =pod
 593 Some pod after __END__ to delete with -dp and trim with -trp
 594 =cut
 595
 596
 597 #6...........
 598         },
 599
 600         'comments.comments4' => {
 601             source => "comments",
 602             params => "comments4",
 603             expect => <<'#7...........',
 604 #!/usr/bin/perl -w
 605 # an initial hash bang line cannot be deleted with -dp
 606 #<<< format skipping of first code can cause an error message in perltidy v20210625
 607 my $rvar = [ [ 1, 2, 3 ], [ 4, 5, 6 ] ];
 608 #>>>
 609 sub length { return length( $_[0] ) }    # side comment
 610                                          # hanging side comment
 611  # very longgggggggggggggggggggggggggggggggggggggggggggggggggggg hanging side comment
 612
 613 # a blank will be inserted to prevent forming a hanging side comment
 614 sub macro_get_names {    #
 615
 616     #
 617     # %name = macro_get_names();  (key=macrohandle, value=macroname)
 618     #
 619 ##local(%name);  # a static block comment without indentation
 620     local (%name) = ();    ## a static side comment to test -ssc
 621
 622     # a spaced block comment to test -isbc
 623     for ( 0 .. $#mac_ver ) {
 624
 625         # a very long comment for testing the parameter --nooutdent-long-comments (or -nolc)
 626         $name{$_} = $mac_ext[ $idx{ $mac_exti[$_] } ];
 627         $vmsfile =~ s/;[\d\-]*$//
 628           ; # very long side comment; Clip off version number; we can use a newer version as well
 629
 630     }
 631     %name;
 632 }
 633
 634
 635
 636 @month_of_year = (
 637     'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
 638   ##  'Dec', 'Nov'   [a static block comment with indentation]
 639     'Nov', 'Dec'
 640 );
 641
 642
 643 {    # this side comment will not align
 644     my $IGNORE = 0;    # This is a side comment
 645                        # This is a hanging side comment
 646                        # And so is this
 647
 648     # A blank line interrupts the hsc's; this is a block comment
 649
 650 }
 651
 652 # side comments at different indentation levels should not normally be aligned
 653 {
 654     {
 655         {
 656             {
 657                 { ${msg} = "Hello World!"; print "My message: ${msg}\n"; }
 658             }    #end level 4
 659         }    # end level 3
 660     }    # end level 2
 661 }    # end level 1
 662
 663
 664 #<<<  do not let perltidy touch this unless -nfs is set
 665     my @list = (1,
 666                 1, 1,
 667                 1, 2, 1,
 668                 1, 3, 3, 1,
 669                 1, 4, 6, 4, 1,);
 670 #>>>
 671
 672 #<<  test alternate format skipping string
 673     my @list = (1,
 674                 1, 1,
 675                 1, 2, 1,
 676                 1, 3, 3, 1,
 677                 1, 4, 6, 4, 1,);
 678 #>>
 679
 680
 681
 682 # some blank lines follow
 683
 684
 685
 686 =pod
 687 Some pod before __END__ to delete with -dp
 688 =cut
 689
 690
 691 __END__
 692
 693
 694 # text following __END__, not a comment
 695
 696
 697 =pod
 698 Some pod after __END__ to delete with -dp and trim with -trp
 699 =cut
 700
 701
 702 #7...........
 703         },
 704
 705         'comments.def' => {
 706             source => "comments",
 707             params => "def",
 708             expect => <<'#8...........',
 709 #!/usr/bin/perl -w
 710 # an initial hash bang line cannot be deleted with -dp
 711 #<<< format skipping of first code can cause an error message in perltidy v20210625
 712 my $rvar = [ [ 1, 2, 3 ], [ 4, 5, 6 ] ];
 713 #>>>
 714 sub length { return length( $_[0] ) }    # side comment
 715                                          # hanging side comment
 716  # very longgggggggggggggggggggggggggggggggggggggggggggggggggggg hanging side comment
 717
 718 # a blank will be inserted to prevent forming a hanging side comment
 719 sub macro_get_names {    #
 720
 721     #
 722     # %name = macro_get_names();  (key=macrohandle, value=macroname)
 723     #
 724 ##local(%name);  # a static block comment without indentation
 725     local (%name) = ();    ## a static side comment to test -ssc
 726
 727     # a spaced block comment to test -isbc
 728     for ( 0 .. $#mac_ver ) {
 729
 730 # a very long comment for testing the parameter --nooutdent-long-comments (or -nolc)
 731         $name{$_} = $mac_ext[ $idx{ $mac_exti[$_] } ];
 732         $vmsfile =~ s/;[\d\-]*$//
 733           ; # very long side comment; Clip off version number; we can use a newer version as well
 734
 735     }
 736     %name;
 737 }
 738
 739 @month_of_year = (
 740     'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
 741     ##  'Dec', 'Nov'   [a static block comment with indentation]
 742     'Nov', 'Dec'
 743 );
 744
 745 {    # this side comment will not align
 746     my $IGNORE = 0;    # This is a side comment
 747                        # This is a hanging side comment
 748                        # And so is this
 749
 750     # A blank line interrupts the hsc's; this is a block comment
 751
 752 }
 753
 754 # side comments at different indentation levels should not normally be aligned
 755 {
 756     {
 757         {
 758             {
 759                 { ${msg} = "Hello World!"; print "My message: ${msg}\n"; }
 760             }    #end level 4
 761         }    # end level 3
 762     }    # end level 2
 763 }    # end level 1
 764
 765 #<<<  do not let perltidy touch this unless -nfs is set
 766     my @list = (1,
 767                 1, 1,
 768                 1, 2, 1,
 769                 1, 3, 3, 1,
 770                 1, 4, 6, 4, 1,);
 771 #>>>
 772
 773 #<<  test alternate format skipping string
 774 my @list = ( 1, 1, 1, 1, 2, 1, 1, 3, 3, 1, 1, 4, 6, 4, 1, );
 775
 776 #>>
 777
 778 # some blank lines follow
 779
 780 =pod
 781 Some pod before __END__ to delete with -dp
 782 =cut
 783
 784 __END__
 785
 786
 787 # text following __END__, not a comment
 788
 789
 790 =pod
 791 Some pod after __END__ to delete with -dp and trim with -trp
 792 =cut
 793
 794
 795 #8...........
 796         },
 797
 798         'long_line.def' => {
 799             source => "long_line",
 800             params => "def",
 801             expect => <<'#9...........',
 802 # This single line should break into multiple lines, even with -l=0
 803 # sub 'tight_paren_follows' should break the do block
 804 $body =
 805   SOAP::Data->name('~V:Fault')->attr( { 'xmlns' => $SOAP::Constants::NS_ENV } )
 806   ->value(
 807     \SOAP::Data->set_value(
 808         SOAP::Data->name(
 809             faultcode => qualify( $self->namespace => shift(@parameters) )
 810         ),
 811         SOAP::Data->name( faultstring => shift(@parameters) ),
 812         @parameters
 813         ? SOAP::Data->name(
 814             detail => do {
 815                 my $detail = shift(@parameters);
 816                 ref $detail ? \$detail : $detail;
 817             }
 818           )
 819         : (),
 820         @parameters ? SOAP::Data->name( faultactor => shift(@parameters) ) : (),
 821     )
 822   );
 823 #9...........
 824         },
 825
 826         'long_line.long_line' => {
 827             source => "long_line",
 828             params => "long_line",
 829             expect => <<'#10...........',
 830 # This single line should break into multiple lines, even with -l=0
 831 # sub 'tight_paren_follows' should break the do block
 832 $body = SOAP::Data->name('~V:Fault')->attr( { 'xmlns' => $SOAP::Constants::NS_ENV } )->value(
 833     \SOAP::Data->set_value(
 834         SOAP::Data->name( faultcode   => qualify( $self->namespace => shift(@parameters) ) ),
 835         SOAP::Data->name( faultstring => shift(@parameters) ),
 836         @parameters
 837         ? SOAP::Data->name(
 838             detail => do { my $detail = shift(@parameters); ref $detail ? \$detail : $detail }
 839           )
 840         : (),
 841         @parameters ? SOAP::Data->name( faultactor => shift(@parameters) ) : (),
 842     )
 843 );
 844 #10...........
 845         },
 846
 847         'pbp6.def' => {
 848             source => "pbp6",
 849             params => "def",
 850             expect => <<'#11...........',
 851         # These formerly blinked with -pbp
 852         return $width1 *
 853           $common_length *
 854           (
 855             $W * atan2( 1, $W ) +
 856               $H * atan2( 1, $H ) -
 857               $RTHSQPWSQ * atan2( 1, $RTHSQPWSQ ) +
 858               0.25 * log(
 859                 ( $WSQP1 * $HSQP1 ) /
 860                   ( 1 + $WSQ + $HSQ ) *
 861                   ( $WSQ * ( 1 + $WSQ + $HSQ ) / ( $WSQP1 * $HSQPWSQ ) )
 862                   **$WSQ *
 863                   ( $HSQ * ( 1 + $WSQ + $HSQ ) / ( $HSQP1 * $HSQPWSQ ) )**$HSQ
 864               )
 865           ) /
 866           ( $W * $pi );
 867
 868         my $oldSec =
 869           ( 60 * $session->{originalStartHour} + $session->{originalStartMin} )
 870           * 60;
 871
 872 #11...........
 873         },
 874
 875         'pbp6.pbp' => {
 876             source => "pbp6",
 877             params => "pbp",
 878             expect => <<'#12...........',
 879         # These formerly blinked with -pbp
 880         return
 881             $width1 * $common_length
 882             * (
 883                   $W * atan2( 1, $W )
 884                 + $H * atan2( 1, $H )
 885                 - $RTHSQPWSQ * atan2( 1, $RTHSQPWSQ )
 886                 + 0.25 * log(
 887                   ( $WSQP1 * $HSQP1 )
 888                 / ( 1 + $WSQ + $HSQ )
 889                     * ( $WSQ * ( 1 + $WSQ + $HSQ ) / ( $WSQP1 * $HSQPWSQ ) )
 890                     **$WSQ
 891                     * ( $HSQ * ( 1 + $WSQ + $HSQ ) / ( $HSQP1 * $HSQPWSQ ) )
 892                     **$HSQ
 893                 )
 894             )
 895             / ( $W * $pi );
 896
 897         my $oldSec
 898             = ( 60 * $session->{originalStartHour}
 899                 + $session->{originalStartMin} )
 900             * 60;
 901
 902 #12...........
 903         },
 904
 905         'rperl.def' => {
 906             source => "rperl",
 907             params => "def",
 908             expect => <<'#13...........',
 909 # Some test cases for RPerl, https://github.com/wbraswell/rperl/
 910 # These must not remain as single lines with default formatting and long lines
 911 sub multiply_return_F {
 912     { my number $RETURN_TYPE };
 913     ( my integer $multiplicand, my number $multiplier ) = @ARG;
 914     return $multiplicand * $multiplier;
 915 }
 916
 917 sub empty_method {
 918     { my void::method $RETURN_TYPE };
 919     return 2;
 920 }
 921
 922 sub foo_subroutine_in_main {
 923     { my void $RETURN_TYPE };
 924     print 'Howdy from foo_subroutine_in_main()...', "\n";
 925     return;
 926 }
 927 #13...........
 928         },
 929
 930         'rperl.rperl' => {
 931             source => "rperl",
 932             params => "rperl",
 933             expect => <<'#14...........',
 934 # Some test cases for RPerl, https://github.com/wbraswell/rperl/
 935 # These must not remain as single lines with default formatting and long lines
 936 sub multiply_return_F {
 937     { my number $RETURN_TYPE };
 938     ( my integer $multiplicand, my number $multiplier ) = @ARG;
 939     return $multiplicand * $multiplier;
 940 }
 941
 942 sub empty_method {
 943     { my void::method $RETURN_TYPE };
 944     return 2;
 945 }
 946
 947 sub foo_subroutine_in_main {
 948     { my void $RETURN_TYPE };
 949     print 'Howdy from foo_subroutine_in_main()...', "\n";
 950     return;
 951 }
 952 #14...........
 953         },
 954
 955         'rt132059.def' => {
 956             source => "rt132059",
 957             params => "def",
 958             expect => <<'#15...........',
 959 # Test deleting comments and pod
 960 $1 = 2;
 961
 962 sub f {    # a side comment
 963            # a hanging side comment
 964
 965     # a block comment
 966 }
 967
 968 =pod
 969 bonjour!
 970 =cut
 971
 972 $i++;
 973 #15...........
 974         },
 975
 976         'rt132059.rt132059' => {
 977             source => "rt132059",
 978             params => "rt132059",
 979             expect => <<'#16...........',
 980 $1 = 2;
 981
 982 sub f {
 983
 984 }
 985
 986
 987 $i++;
 988 #16...........
 989         },
 990
 991         'signature.def' => {
 992             source => "signature",
 993             params => "def",
 994             expect => <<'#17...........',
 995 # git22: Preserve function signature on a single line
 996 # This behavior is controlled by 'sub weld_signature_parens'
 997
 998 sub foo ( $x, $y = "abcd" ) {
 999     $x . $y;
1000 }
1001
1002 # do not break after closing do brace
1003 sub foo ( $x, $y = do { {} }, $z = 42, $w = do { "abcd" } ) {
1004     $x . $y . $z;
1005 }
1006
1007 # This signature should get put back on one line
1008 sub t022 ( $p = do { $z += 10; 222 }, $a = do { $z++; 333 } ) { "$p/$a" }
1009
1010 # anonymous sub with signature
1011 my $subref = sub ( $cat, $id = do { state $auto_id = 0; $auto_id++ } ) {
1012     ...;
1013 };
1014
1015 # signature and prototype and attribute
1016 sub foo1 ( $x, $y ) : prototype ( $$ ) : shared { }
1017
1018 sub foo11 ( $thing, % ) { print $thing }
1019
1020 sub animal4 ( $cat, $ = ) { }    # second argument is optional
1021
1022 *share = sub ( \[$@%] ) { };
1023
1024 # extruded test
1025 sub foo2 ( $first, $, $third ) {
1026     return "first=$first, third=$third";
1027 }
1028
1029 # valid attributes
1030 sub fnord (&\%) : switch(10,foo(7,3)) : expensive;
1031 sub plugh () : Ugly('\(") : Bad;
1032 #17...........
1033         },
1034
1035         'ternary4.def' => {
1036             source => "ternary4",
1037             params => "def",
1038             expect => <<'#18...........',
1039 # some side comments
1040 *{"${callpkg}::$sym"} = $type eq '&' ? \&{"${pkg}::$sym"}    #
1041   : $type eq '$' ? \${"${pkg}::$sym"}                        #
1042   : $type eq '@' ? \@{"${pkg}::$sym"}
1043   : $type eq '%' ? \%{"${pkg}::$sym"}                        # side comment
1044   : $type eq '*' ? *{"${pkg}::$sym"}                         #
1045   :   do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
1046 #18...........
1047         },
1048
1049         'wn7.def' => {
1050             source => "wn7",
1051             params => "def",
1052             expect => <<'#19...........',
1053                     # do not weld paren to opening one-line non-paren container
1054                     $Self->_Add(
1055                         $SortOrderDisplay{
1056                             $Field->GenerateFieldForSelectSQL()
1057                         }
1058                     );
1059
1060                     # this will not get welded with -wn
1061                     f(
1062                         do { 1; !!( my $x = bless [] ); }
1063                     );
1064 #19...........
1065         },
1066     };
1067
1068     my $ntests = 0 + keys %{$rtests};
1069     plan tests => $ntests;
1070 }
1071
1072 ###############
1073 # EXECUTE TESTS
1074 ###############
1075
1076 foreach my $key ( sort keys %{$rtests} ) {
1077     my $output;
1078     my $sname  = $rtests->{$key}->{source};
1079     my $expect = $rtests->{$key}->{expect};
1080     my $pname  = $rtests->{$key}->{params};
1081     my $source = $rsources->{$sname};
1082     my $params = defined($pname) ? $rparams->{$pname} : "";
1083     my $stderr_string;
1084     my $errorfile_string;
1085     my $err = Perl::Tidy::perltidy(
1086         source      => \$source,
1087         destination => \$output,
1088         perltidyrc  => \$params,
1089         argv        => '',             # for safety; hide any ARGV from perltidy
1090         stderr      => \$stderr_string,
1091         errorfile   => \$errorfile_string,    # not used when -se flag is set
1092     );
1093     if ( $err || $stderr_string || $errorfile_string ) {
1094         print STDERR "Error output received for test '$key'\n";
1095         if ($err) {
1096             print STDERR "An error flag '$err' was returned\n";
1097             ok( !$err );
1098         }
1099         if ($stderr_string) {
1100             print STDERR "---------------------\n";
1101             print STDERR "<<STDERR>>\n$stderr_string\n";
1102             print STDERR "---------------------\n";
1103             ok( !$stderr_string );
1104         }
1105         if ($errorfile_string) {
1106             print STDERR "---------------------\n";
1107             print STDERR "<<.ERR file>>\n$errorfile_string\n";
1108             print STDERR "---------------------\n";
1109             ok( !$errorfile_string );
1110         }
1111     }
1112     else {
1113         if ( !is( $output, $expect, $key ) ) {
1114             my $leno = length($output);
1115             my $lene = length($expect);
1116             if ( $leno == $lene ) {
1117                 print STDERR
1118 "#> Test '$key' gave unexpected output.  Strings differ but both have length $leno\n";
1119             }
1120             else {
1121                 print STDERR
1122 "#> Test '$key' gave unexpected output.  String lengths differ: output=$leno, expected=$lene\n";
1123             }
1124         }
1125     }
1126 }