"Fossies" - the Fresh Open Source Software Archive

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


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) C and C++ source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    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 }