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