t/snippets20.t

   1 # Created with: ./make_t.pl
   2
   3 # Contents:
   4 #1 space6.def
   5 #2 space6.space6
   6 #3 sub3.def
   7 #4 wc.def
   8 #5 wc.wc1
   9 #6 wc.wc2
  10 #7 ce2.ce
  11 #8 ce2.def
  12 #9 gnu6.def
  13 #10 gnu6.gnu
  14 #11 git25.def
  15 #12 git25.git25
  16 #13 outdent.outdent2
  17 #14 kpit.def
  18 #15 kpit.kpit
  19 #16 kpitl.def
  20 #17 kpitl.kpitl
  21 #18 hanging_side_comments3.def
  22 #19 lop.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         'ce'    => "-cuddled-blocks",
  41         'def'   => "",
  42         'git25' => "-l=0",
  43         'gnu'   => "-gnu",
  44         'kpit'  => "-pt=2 -kpit=0",
  45         'kpitl' => <<'----------',
  46 -kpit=0 -kpitl='return factorial' -pt=2
  47 ----------
  48         'outdent2' => <<'----------',
  49 # test -okw and -okwl
  50 -okw -okwl='next'
  51 ----------
  52         'space6' => <<'----------',
  53 -nwrs="+ - / *"
  54 -nwls="+ - / *"
  55 ----------
  56         'wc1' => "-wc=4",
  57         'wc2' => "-wc=4 -wn",
  58     };
  59
  60     ############################
  61     # BEGIN SECTION 2: Sources #
  62     ############################
  63     $rsources = {
  64
  65         'ce2' => <<'----------',
  66 # Previously, perltidy -ce would move a closing brace below a pod section to
  67 # form '} else {'. No longer doing this because if you change back to -nce, the
  68 # brace cannot go back to where it was.
  69 if ($notty) {
  70     $runnonstop = 1;
  71         share($runnonstop);
  72 }
  73
  74 =pod
  75
  76 If there is a TTY, we have to determine who it belongs to before we can
  77 ...
  78
  79 =cut
  80
  81 else {
  82
  83     # Is Perl being run from a slave editor or graphical debugger?
  84     ...
  85 }
  86 ----------
  87
  88         'git25' => <<'----------',
  89 # example for git #25; use -l=0; was losing alignment;  sub 'fix_ragged_lists' was added to fix this
  90 my $mapping = [
  91 # ...
  92     { 'is_col' => 'dsstdat',                      'cr_col' => 'enroll_isaric_date',         'trans' => 0, },
  93     { 'is_col' => 'corona_ieorres',               'cr_col' => '',                           'trans' => 0, },
  94     { 'is_col' => 'symptoms_fever',               'cr_col' => 'elig_fever',                 'trans' => 1, 'manually_reviewed' => '@TODO', 'map' => { '0' => '0', '1' => '1', '9' => '@TODO' }, },
  95     { 'is_col' => 'symptoms_cough',               'cr_col' => 'elig_cough',                 'trans' => 1, 'manually_reviewed' => '@TODO', 'map' => { '0' => '0', '1' => '1', '9' => '@TODO' }, },
  96     { 'is_col' => 'symptoms_dys_tachy_noea',      'cr_col' => 'elig_dyspnea',               'trans' => 1, 'manually_reviewed' => '@TODO', 'map' => { '0' => '0', '1' => '1', '9' => '@TODO' }, },
  97     { 'is_col' => 'symptoms_clinical_susp',       'cr_col' => 'elig_ari',                   'trans' => 0, },
  98     { 'is_col' => 'sex',                          'cr_col' => 'sex',                        'trans' => 1, 'manually_reviewed' => 1, 'map' => { '0' => '1', '1' => '2' }, },
  99     { 'is_col' => 'age',                          'cr_col' => '',                           'trans' => 0, },
 100     { 'is_col' => 'ageu',                         'cr_col' => '',                           'trans' => 0, },
 101 # ...
 102 ];
 103
 104 ----------
 105
 106         'gnu6' => <<'----------',
 107 # the closing braces should have the same position for these two hashes with -gnu
 108     $var1 = {
 109         'foo10' => undef,
 110         'foo72' => '
 111 ',
 112     };
 113     $var2 = {
 114         'foo72' => '
 115 ',
 116         'foo10' => undef,
 117     };
 118
 119 ----------
 120
 121         'hanging_side_comments3' => <<'----------',
 122     if ( $var eq 'wastebasket' ) {    # this sends a pure block
 123                                       # of hanging side comments
 124                                       #to the vertical aligner.
 125                                       #It caused a crash in
 126                                       #a test version of
 127                                       #sub 'delete_unmatched_tokens'
 128                                       #...
 129                                       #}
 130     }
 131     elsif ( $var eq 'spacecommand' ) {
 132         &die("No $val function") unless eval "defined &$val";
 133     }
 134 ----------
 135
 136         'kpit' => <<'----------',
 137 if ( seek(DATA, 0, 0) ) { ... }
 138
 139 # The foreach keyword may be separated from the next opening paren
 140 foreach $req(@bgQueue) {
 141    ...
 142 }
 143
 144 # This had trouble because a later padding operation removed the inside space
 145 while ($CmdJob eq "" && @CmdQueue > 0 && $RunNightlyWhenIdle != 1
 146         || @CmdQueue > 0 && $RunNightlyWhenIdle == 2 && $bpc->isAdminJob($CmdQueue[0]->{host})) {
 147   ...
 148 }
 149
 150 ----------
 151
 152         'kpitl' => <<'----------',
 153 return ( $r**$n ) * ( pi**( $n / 2 ) ) / ( sqrt(pi) * factorial( 2 * ( int( $n
 154 / 2 ) ) + 2 ) / factorial( int( $n / 2 ) + 1 ) / ( 4**( int( $n / 2 ) + 1 ) )
 155 );
 156 ----------
 157
 158         'lop' => <<'----------',
 159 # logical padding examples
 160 $same =
 161   (      ( $aP eq $bP )
 162       && ( $aS eq $bS )
 163       && ( $aT eq $bT )
 164       && ( $a->{'title'} eq $b->{'title'} )
 165       && ( $a->{'href'} eq $b->{'href'} ) );
 166
 167 $bits =
 168     $top > 0xffff ? 32
 169   : $top > 0xff   ? 16
 170   : $top > 1      ? 8
 171   :                 1;
 172
 173 lc( $self->mime_attr('content-type')
 174         || $self->{MIH_DefaultType}
 175         || 'text/plain' );
 176
 177 # Padding can also remove spaces; here the space after the '(' is lost:
 178 elsif ( $statement_type =~ /^sub\b/
 179     || $paren_type[$paren_depth] =~ /^sub\b/ )
 180 ----------
 181
 182         'outdent' => <<'----------',
 183         my $i;
 184       LOOP: while ( $i = <FOTOS> ) {
 185             chomp($i);
 186             next unless $i;
 187             fixit($i);
 188         }
 189
 190 ----------
 191
 192         'space6' => <<'----------',
 193 # test some spacing rules at possible filehandles
 194 my $z=$x/$y;     # ok to change spaces around both sides of the /
 195 print $x / $y;   # do not remove space before or after / here
 196 print $x/$y;     # do not add a space before the / here
 197 print $x+$y;     # do not add a space before the + here
 198 ----------
 199
 200         'sub3' => <<'----------',
 201 # keep these one-line blocks intact
 202
 203 my $aa = sub
 204 #line 245 "Parse.yp"
 205 { n_stmtexp $_[1] };
 206
 207 my $bb = sub    #
 208 { n_stmtexp $_[1] };
 209 ----------
 210
 211         'wc' => <<'----------',
 212 {
 213     my (@indices) =
 214       sort {
 215         $dir eq 'left' ? $cells[$a] <=> $cells[$b] : $cells[$b] <=> $cells[$a];
 216     } (0 .. $#cells);
 217
 218 {{{{
 219                     if ( !$array[0] ) {
 220                         $array[0] =
 221                           &$CantProcessPartFunc( $entity->{'fields'}{
 222                           'content-type'} );
 223                     }
 224
 225 }}}}}
 226
 227 ----------
 228     };
 229
 230     ####################################
 231     # BEGIN SECTION 3: Expected output #
 232     ####################################
 233     $rtests = {
 234
 235         'space6.def' => {
 236             source => "space6",
 237             params => "def",
 238             expect => <<'#1...........',
 239 # test some spacing rules at possible filehandles
 240 my $z = $x / $y;    # ok to change spaces around both sides of the /
 241 print $x / $y;      # do not remove space before or after / here
 242 print $x/ $y;       # do not add a space before the / here
 243 print $x+ $y;       # do not add a space before the + here
 244 #1...........
 245         },
 246
 247         'space6.space6' => {
 248             source => "space6",
 249             params => "space6",
 250             expect => <<'#2...........',
 251 # test some spacing rules at possible filehandles
 252 my $z = $x/$y;    # ok to change spaces around both sides of the /
 253 print $x / $y;    # do not remove space before or after / here
 254 print $x/$y;      # do not add a space before the / here
 255 print $x+$y;      # do not add a space before the + here
 256 #2...........
 257         },
 258
 259         'sub3.def' => {
 260             source => "sub3",
 261             params => "def",
 262             expect => <<'#3...........',
 263 # keep these one-line blocks intact
 264
 265 my $aa = sub
 266 #line 245 "Parse.yp"
 267 { n_stmtexp $_[1] };
 268
 269 my $bb = sub    #
 270 { n_stmtexp $_[1] };
 271 #3...........
 272         },
 273
 274         'wc.def' => {
 275             source => "wc",
 276             params => "def",
 277             expect => <<'#4...........',
 278 {
 279     my (@indices) =
 280       sort {
 281         $dir eq 'left' ? $cells[$a] <=> $cells[$b] : $cells[$b] <=> $cells[$a];
 282       } ( 0 .. $#cells );
 283
 284     {
 285         {
 286             {
 287                 {
 288                     if ( !$array[0] ) {
 289                         $array[0] =
 290                           &$CantProcessPartFunc(
 291                             $entity->{'fields'}{'content-type'} );
 292                     }
 293
 294                 }
 295             }
 296         }
 297     }
 298 }
 299
 300 #4...........
 301         },
 302
 303         'wc.wc1' => {
 304             source => "wc",
 305             params => "wc1",
 306             expect => <<'#5...........',
 307 {
 308     my (@indices) =
 309       sort {
 310         $dir eq 'left' ? $cells[$a] <=> $cells[$b] : $cells[$b] <=> $cells[$a];
 311       } ( 0 .. $#cells );
 312
 313     {
 314         {
 315             {
 316                 {
 317     if ( !$array[0] ) {
 318         $array[0] =
 319           &$CantProcessPartFunc( $entity->{'fields'}{'content-type'} );
 320     }
 321
 322                 }
 323             }
 324         }
 325     }
 326 }
 327
 328 #5...........
 329         },
 330
 331         'wc.wc2' => {
 332             source => "wc",
 333             params => "wc2",
 334             expect => <<'#6...........',
 335 {
 336     my (@indices) =
 337       sort {
 338         $dir eq 'left' ? $cells[$a] <=> $cells[$b] : $cells[$b] <=> $cells[$a];
 339       } ( 0 .. $#cells );
 340
 341     { { { {
 342         if ( !$array[0] ) {
 343             $array[0] =
 344               &$CantProcessPartFunc( $entity->{'fields'}{'content-type'} );
 345         }
 346
 347     } } } }
 348 }
 349
 350 #6...........
 351         },
 352
 353         'ce2.ce' => {
 354             source => "ce2",
 355             params => "ce",
 356             expect => <<'#7...........',
 357 # Previously, perltidy -ce would move a closing brace below a pod section to
 358 # form '} else {'. No longer doing this because if you change back to -nce, the
 359 # brace cannot go back to where it was.
 360 if ($notty) {
 361     $runnonstop = 1;
 362     share($runnonstop);
 363
 364 }
 365
 366 =pod
 367
 368 If there is a TTY, we have to determine who it belongs to before we can
 369 ...
 370
 371 =cut
 372
 373 else {
 374
 375     # Is Perl being run from a slave editor or graphical debugger?
 376     ...;
 377 }
 378 #7...........
 379         },
 380
 381         'ce2.def' => {
 382             source => "ce2",
 383             params => "def",
 384             expect => <<'#8...........',
 385 # Previously, perltidy -ce would move a closing brace below a pod section to
 386 # form '} else {'. No longer doing this because if you change back to -nce, the
 387 # brace cannot go back to where it was.
 388 if ($notty) {
 389     $runnonstop = 1;
 390     share($runnonstop);
 391 }
 392
 393 =pod
 394
 395 If there is a TTY, we have to determine who it belongs to before we can
 396 ...
 397
 398 =cut
 399
 400 else {
 401
 402     # Is Perl being run from a slave editor or graphical debugger?
 403     ...;
 404 }
 405 #8...........
 406         },
 407
 408         'gnu6.def' => {
 409             source => "gnu6",
 410             params => "def",
 411             expect => <<'#9...........',
 412 # the closing braces should have the same position for these two hashes with -gnu
 413     $var1 = {
 414         'foo10' => undef,
 415         'foo72' => '
 416 ',
 417     };
 418     $var2 = {
 419         'foo72' => '
 420 ',
 421         'foo10' => undef,
 422     };
 423
 424 #9...........
 425         },
 426
 427         'gnu6.gnu' => {
 428             source => "gnu6",
 429             params => "gnu",
 430             expect => <<'#10...........',
 431     # the closing braces should have the same position for these two hashes with -gnu
 432     $var1 = {
 433         'foo10' => undef,
 434         'foo72' => '
 435 ',
 436             };
 437     $var2 = {
 438         'foo72' => '
 439 ',
 440         'foo10' => undef,
 441             };
 442
 443 #10...........
 444         },
 445
 446         'git25.def' => {
 447             source => "git25",
 448             params => "def",
 449             expect => <<'#11...........',
 450 # example for git #25; use -l=0; was losing alignment;  sub 'fix_ragged_lists' was added to fix this
 451 my $mapping = [
 452
 453     # ...
 454     { 'is_col' => 'dsstdat', 'cr_col' => 'enroll_isaric_date', 'trans' => 0, },
 455     { 'is_col' => 'corona_ieorres', 'cr_col' => '',            'trans' => 0, },
 456     {
 457         'is_col'            => 'symptoms_fever',
 458         'cr_col'            => 'elig_fever',
 459         'trans'             => 1,
 460         'manually_reviewed' => '@TODO',
 461         'map'               => { '0' => '0', '1' => '1', '9' => '@TODO' },
 462     },
 463     {
 464         'is_col'            => 'symptoms_cough',
 465         'cr_col'            => 'elig_cough',
 466         'trans'             => 1,
 467         'manually_reviewed' => '@TODO',
 468         'map'               => { '0' => '0', '1' => '1', '9' => '@TODO' },
 469     },
 470     {
 471         'is_col'            => 'symptoms_dys_tachy_noea',
 472         'cr_col'            => 'elig_dyspnea',
 473         'trans'             => 1,
 474         'manually_reviewed' => '@TODO',
 475         'map'               => { '0' => '0', '1' => '1', '9' => '@TODO' },
 476     },
 477     {
 478         'is_col' => 'symptoms_clinical_susp',
 479         'cr_col' => 'elig_ari',
 480         'trans'  => 0,
 481     },
 482     {
 483         'is_col'            => 'sex',
 484         'cr_col'            => 'sex',
 485         'trans'             => 1,
 486         'manually_reviewed' => 1,
 487         'map'               => { '0' => '1', '1' => '2' },
 488     },
 489     { 'is_col' => 'age',  'cr_col' => '', 'trans' => 0, },
 490     { 'is_col' => 'ageu', 'cr_col' => '', 'trans' => 0, },
 491
 492     # ...
 493 ];
 494
 495 #11...........
 496         },
 497
 498         'git25.git25' => {
 499             source => "git25",
 500             params => "git25",
 501             expect => <<'#12...........',
 502 # example for git #25; use -l=0; was losing alignment;  sub 'fix_ragged_lists' was added to fix this
 503 my $mapping = [
 504
 505     # ...
 506     { 'is_col' => 'dsstdat',                 'cr_col' => 'enroll_isaric_date', 'trans' => 0, },
 507     { 'is_col' => 'corona_ieorres',          'cr_col' => '',                   'trans' => 0, },
 508     { 'is_col' => 'symptoms_fever',          'cr_col' => 'elig_fever',         'trans' => 1, 'manually_reviewed' => '@TODO', 'map' => { '0' => '0', '1' => '1', '9' => '@TODO' }, },
 509     { 'is_col' => 'symptoms_cough',          'cr_col' => 'elig_cough',         'trans' => 1, 'manually_reviewed' => '@TODO', 'map' => { '0' => '0', '1' => '1', '9' => '@TODO' }, },
 510     { 'is_col' => 'symptoms_dys_tachy_noea', 'cr_col' => 'elig_dyspnea',       'trans' => 1, 'manually_reviewed' => '@TODO', 'map' => { '0' => '0', '1' => '1', '9' => '@TODO' }, },
 511     { 'is_col' => 'symptoms_clinical_susp',  'cr_col' => 'elig_ari',           'trans' => 0, },
 512     { 'is_col' => 'sex',                     'cr_col' => 'sex',                'trans' => 1, 'manually_reviewed' => 1, 'map' => { '0' => '1', '1' => '2' }, },
 513     { 'is_col' => 'age',                     'cr_col' => '',                   'trans' => 0, },
 514     { 'is_col' => 'ageu',                    'cr_col' => '',                   'trans' => 0, },
 515
 516     # ...
 517 ];
 518
 519 #12...........
 520         },
 521
 522         'outdent.outdent2' => {
 523             source => "outdent",
 524             params => "outdent2",
 525             expect => <<'#13...........',
 526         my $i;
 527       LOOP: while ( $i = <FOTOS> ) {
 528             chomp($i);
 529           next unless $i;
 530             fixit($i);
 531         }
 532
 533 #13...........
 534         },
 535
 536         'kpit.def' => {
 537             source => "kpit",
 538             params => "def",
 539             expect => <<'#14...........',
 540 if ( seek( DATA, 0, 0 ) ) { ... }
 541
 542 # The foreach keyword may be separated from the next opening paren
 543 foreach $req (@bgQueue) {
 544     ...;
 545 }
 546
 547 # This had trouble because a later padding operation removed the inside space
 548 while ($CmdJob eq "" && @CmdQueue > 0 && $RunNightlyWhenIdle != 1
 549     || @CmdQueue > 0
 550     && $RunNightlyWhenIdle == 2
 551     && $bpc->isAdminJob( $CmdQueue[0]->{host} ) )
 552 {
 553     ...;
 554 }
 555
 556 #14...........
 557         },
 558
 559         'kpit.kpit' => {
 560             source => "kpit",
 561             params => "kpit",
 562             expect => <<'#15...........',
 563 if ( seek(DATA, 0, 0) ) { ... }
 564
 565 # The foreach keyword may be separated from the next opening paren
 566 foreach $req ( @bgQueue ) {
 567     ...;
 568 }
 569
 570 # This had trouble because a later padding operation removed the inside space
 571 while ( $CmdJob eq "" && @CmdQueue > 0 && $RunNightlyWhenIdle != 1
 572     || @CmdQueue > 0
 573     && $RunNightlyWhenIdle == 2
 574     && $bpc->isAdminJob($CmdQueue[0]->{host}) )
 575 {
 576     ...;
 577 }
 578
 579 #15...........
 580         },
 581
 582         'kpitl.def' => {
 583             source => "kpitl",
 584             params => "def",
 585             expect => <<'#16...........',
 586 return ( $r**$n ) *
 587   ( pi**( $n / 2 ) ) /
 588   (
 589     sqrt(pi) *
 590       factorial( 2 * ( int( $n / 2 ) ) + 2 ) /
 591       factorial( int( $n / 2 ) + 1 ) /
 592       ( 4**( int( $n / 2 ) + 1 ) ) );
 593 #16...........
 594         },
 595
 596         'kpitl.kpitl' => {
 597             source => "kpitl",
 598             params => "kpitl",
 599             expect => <<'#17...........',
 600 return ( $r**$n ) *
 601   (pi**($n / 2)) /
 602   (
 603     sqrt(pi) *
 604       factorial( 2 * (int($n / 2)) + 2 ) /
 605       factorial( int($n / 2) + 1 ) /
 606       (4**(int($n / 2) + 1)));
 607 #17...........
 608         },
 609
 610         'hanging_side_comments3.def' => {
 611             source => "hanging_side_comments3",
 612             params => "def",
 613             expect => <<'#18...........',
 614     if ( $var eq 'wastebasket' ) {    # this sends a pure block
 615                                       # of hanging side comments
 616                                       #to the vertical aligner.
 617                                       #It caused a crash in
 618                                       #a test version of
 619                                       #sub 'delete_unmatched_tokens'
 620                                       #...
 621                                       #}
 622     }
 623     elsif ( $var eq 'spacecommand' ) {
 624         &die("No $val function") unless eval "defined &$val";
 625     }
 626 #18...........
 627         },
 628
 629         'lop.def' => {
 630             source => "lop",
 631             params => "def",
 632             expect => <<'#19...........',
 633 # logical padding examples
 634 $same =
 635   (      ( $aP eq $bP )
 636       && ( $aS eq $bS )
 637       && ( $aT eq $bT )
 638       && ( $a->{'title'} eq $b->{'title'} )
 639       && ( $a->{'href'} eq $b->{'href'} ) );
 640
 641 $bits =
 642     $top > 0xffff ? 32
 643   : $top > 0xff   ? 16
 644   : $top > 1      ? 8
 645   :                 1;
 646
 647 lc(      $self->mime_attr('content-type')
 648       || $self->{MIH_DefaultType}
 649       || 'text/plain' );
 650
 651 # Padding can also remove spaces; here the space after the '(' is lost:
 652 elsif ($statement_type =~ /^sub\b/
 653     || $paren_type[$paren_depth] =~ /^sub\b/ )
 654 #19...........
 655         },
 656     };
 657
 658     my $ntests = 0 + keys %{$rtests};
 659     plan tests => $ntests;
 660 }
 661
 662 ###############
 663 # EXECUTE TESTS
 664 ###############
 665
 666 foreach my $key ( sort keys %{$rtests} ) {
 667     my $output;
 668     my $sname  = $rtests->{$key}->{source};
 669     my $expect = $rtests->{$key}->{expect};
 670     my $pname  = $rtests->{$key}->{params};
 671     my $source = $rsources->{$sname};
 672     my $params = defined($pname) ? $rparams->{$pname} : "";
 673     my $stderr_string;
 674     my $errorfile_string;
 675     my $err = Perl::Tidy::perltidy(
 676         source      => \$source,
 677         destination => \$output,
 678         perltidyrc  => \$params,
 679         argv        => '',             # for safety; hide any ARGV from perltidy
 680         stderr      => \$stderr_string,
 681         errorfile   => \$errorfile_string,    # not used when -se flag is set
 682     );
 683     if ( $err || $stderr_string || $errorfile_string ) {
 684         print STDERR "Error output received for test '$key'\n";
 685         if ($err) {
 686             print STDERR "An error flag '$err' was returned\n";
 687             ok( !$err );
 688         }
 689         if ($stderr_string) {
 690             print STDERR "---------------------\n";
 691             print STDERR "<<STDERR>>\n$stderr_string\n";
 692             print STDERR "---------------------\n";
 693             ok( !$stderr_string );
 694         }
 695         if ($errorfile_string) {
 696             print STDERR "---------------------\n";
 697             print STDERR "<<.ERR file>>\n$errorfile_string\n";
 698             print STDERR "---------------------\n";
 699             ok( !$errorfile_string );
 700         }
 701     }
 702     else {
 703         if ( !is( $output, $expect, $key ) ) {
 704             my $leno = length($output);
 705             my $lene = length($expect);
 706             if ( $leno == $lene ) {
 707                 print STDERR
 708 "#> Test '$key' gave unexpected output.  Strings differ but both have length $leno\n";
 709             }
 710             else {
 711                 print STDERR
 712 "#> Test '$key' gave unexpected output.  String lengths differ: output=$leno, expected=$lene\n";
 713             }
 714         }
 715     }
 716 }