t/snippets27.t

   1 # Created with: ./make_t.pl
   2
   3 # Contents:
   4 #1 wtc.wtc1
   5 #2 wtc.wtc2
   6 #3 wtc.wtc3
   7 #4 wtc.wtc4
   8 #5 wtc.wtc5
   9 #6 wtc.wtc6
  10 #7 dwic.def
  11 #8 dwic.dwic
  12 #9 wtc.wtc7
  13 #10 rt144979.def
  14 #11 rt144979.rt144979
  15
  16 # To locate test #13 you can search for its name or the string '#13'
  17
  18 use strict;
  19 use Test::More;
  20 use Carp;
  21 use Perl::Tidy;
  22 my $rparams;
  23 my $rsources;
  24 my $rtests;
  25
  26 BEGIN {
  27
  28     ###########################################
  29     # BEGIN SECTION 1: Parameter combinations #
  30     ###########################################
  31     $rparams = {
  32         'def'      => "",
  33         'dwic'     => "-wn -dwic",
  34         'rt144979' => "-xci -ce -lp",
  35         'wtc1'     => "-wtc=0 -dtc",
  36         'wtc2'     => "-wtc=1 -atc",
  37         'wtc3'     => "-wtc=m -atc",
  38         'wtc4'     => "-wtc=m -atc -dtc",
  39         'wtc5'     => "-wtc=b -atc -dtc -vtc=2",
  40         'wtc6'     => "-wtc=i -atc -dtc -vtc=2",
  41         'wtc7'     => "-wtc=h -atc -dtc -vtc=2",
  42     };
  43
  44     ############################
  45     # BEGIN SECTION 2: Sources #
  46     ############################
  47     $rsources = {
  48
  49         'dwic' => <<'----------',
  50     skip_symbols(
  51         [ qw(
  52             Perl_dump_fds
  53             Perl_ErrorNo
  54             Perl_GetVars
  55             PL_sys_intern
  56         ) ],
  57     );
  58 ----------
  59
  60         'rt144979' => <<'----------',
  61 # part 1
  62 GetOptions(
  63       "format|f=s" => sub {
  64           my ( $n, $v ) = @_;
  65           if ( ( my $k = $formats{$v} ) ) {
  66               $format = $k;
  67       } else {
  68               die("--format must be 'system' or 'user'\n");
  69           }
  70           return;
  71       },
  72 );
  73
  74 # part 2
  75 {{{
  76             my $desc =
  77               $access
  78               ? "for -$op under use filetest 'access' $desc_tail"
  79               : "for -$op $desc_tail";
  80             {
  81                 local $SIG{__WARN__} = sub {
  82                     my $w = shift;
  83                     if ($w =~ /^File::stat ignores VMS ACLs/)
  84                     {
  85                         ++$vwarn;
  86                       } elsif (
  87                               $w =~ /^File::stat ignores use filetest 'access'/)
  88                     {
  89                         ++$awarn;
  90                     } else
  91                     {
  92                         $warnings .= $w;
  93                     }
  94                 };
  95                 $rv = eval "$access; -$op \$stat";
  96             }
  97 }}}
  98
  99 ----------
 100
 101         'wtc' => <<'----------',
 102 # both single and multiple line lists:
 103 @LoL = (
 104     [ "fred",   "barney", ],
 105     [ "george", "jane",  "elroy" ],
 106     [ "homer",  "marge", "bart", ],
 107 );
 108
 109 # single line
 110 ( $name, $body ) = ( $2, $3, );
 111
 112 # multiline, but not bare
 113 $text = $main->Scrolled( TextUndo, $yyy, $zzz, $wwwww,
 114     selectbackgroundxxxxx => 'yellow', );
 115
 116 # this will pass for 'h'
 117 my $new = {
 118       %$item,
 119       text => $leaf,
 120       color => 'green',
 121 };
 122
 123 # matches 'i'
 124 my @list = (
 125
 126     $xx,
 127     $yy
 128 );
 129
 130 # does not match 'h'
 131 $c1->create(
 132     'rectangle', 40, 60, 80, 80,
 133     -fill => 'red',
 134     -tags => 'rectangle'
 135 );
 136
 137 $dasm_frame->Button(
 138     -text    => 'Locate',
 139     -command => sub {
 140         $target_binary = $fs->Show( -popover => 'cursor', -create  => 1, );
 141     },
 142 )->pack( -side => 'left', );
 143
 144 my $no_index_1_1 =
 145   { 'map' =>
 146       { ':key' => { name => \&string, list => { value => \&string }, }, }, };
 147
 148
 149 ----------
 150     };
 151
 152     ####################################
 153     # BEGIN SECTION 3: Expected output #
 154     ####################################
 155     $rtests = {
 156
 157         'wtc.wtc1' => {
 158             source => "wtc",
 159             params => "wtc1",
 160             expect => <<'#1...........',
 161 # both single and multiple line lists:
 162 @LoL = (
 163     [ "fred",   "barney" ],
 164     [ "george", "jane",  "elroy" ],
 165     [ "homer",  "marge", "bart" ]
 166 );
 167
 168 # single line
 169 ( $name, $body ) = ( $2, $3 );
 170
 171 # multiline, but not bare
 172 $text = $main->Scrolled( TextUndo, $yyy, $zzz, $wwwww,
 173     selectbackgroundxxxxx => 'yellow' );
 174
 175 # this will pass for 'h'
 176 my $new = {
 177     %$item,
 178     text  => $leaf,
 179     color => 'green'
 180 };
 181
 182 # matches 'i'
 183 my @list = (
 184
 185     $xx,
 186     $yy
 187 );
 188
 189 # does not match 'h'
 190 $c1->create(
 191     'rectangle', 40, 60, 80, 80,
 192     -fill => 'red',
 193     -tags => 'rectangle'
 194 );
 195
 196 $dasm_frame->Button(
 197     -text    => 'Locate',
 198     -command => sub {
 199         $target_binary = $fs->Show( -popover => 'cursor', -create => 1 );
 200     }
 201 )->pack( -side => 'left' );
 202
 203 my $no_index_1_1 =
 204   { 'map' => { ':key' => { name => \&string, list => { value => \&string } } }
 205   };
 206
 207 #1...........
 208         },
 209
 210         'wtc.wtc2' => {
 211             source => "wtc",
 212             params => "wtc2",
 213             expect => <<'#2...........',
 214 # both single and multiple line lists:
 215 @LoL = (
 216     [ "fred",   "barney", ],
 217     [ "george", "jane",  "elroy", ],
 218     [ "homer",  "marge", "bart", ],
 219 );
 220
 221 # single line
 222 ( $name, $body, ) = ( $2, $3, );
 223
 224 # multiline, but not bare
 225 $text = $main->Scrolled( TextUndo, $yyy, $zzz, $wwwww,
 226     selectbackgroundxxxxx => 'yellow', );
 227
 228 # this will pass for 'h'
 229 my $new = {
 230     %$item,
 231     text  => $leaf,
 232     color => 'green',
 233 };
 234
 235 # matches 'i'
 236 my @list = (
 237
 238     $xx,
 239     $yy,
 240 );
 241
 242 # does not match 'h'
 243 $c1->create(
 244     'rectangle', 40, 60, 80, 80,
 245     -fill => 'red',
 246     -tags => 'rectangle',
 247 );
 248
 249 $dasm_frame->Button(
 250     -text    => 'Locate',
 251     -command => sub {
 252         $target_binary = $fs->Show( -popover => 'cursor', -create => 1, );
 253     },
 254 )->pack( -side => 'left', );
 255
 256 my $no_index_1_1 =
 257   { 'map' =>
 258       { ':key' => { name => \&string, list => { value => \&string }, }, }, };
 259
 260 #2...........
 261         },
 262
 263         'wtc.wtc3' => {
 264             source => "wtc",
 265             params => "wtc3",
 266             expect => <<'#3...........',
 267 # both single and multiple line lists:
 268 @LoL = (
 269     [ "fred",   "barney", ],
 270     [ "george", "jane",  "elroy" ],
 271     [ "homer",  "marge", "bart", ],
 272 );
 273
 274 # single line
 275 ( $name, $body ) = ( $2, $3, );
 276
 277 # multiline, but not bare
 278 $text = $main->Scrolled( TextUndo, $yyy, $zzz, $wwwww,
 279     selectbackgroundxxxxx => 'yellow', );
 280
 281 # this will pass for 'h'
 282 my $new = {
 283     %$item,
 284     text  => $leaf,
 285     color => 'green',
 286 };
 287
 288 # matches 'i'
 289 my @list = (
 290
 291     $xx,
 292     $yy,
 293 );
 294
 295 # does not match 'h'
 296 $c1->create(
 297     'rectangle', 40, 60, 80, 80,
 298     -fill => 'red',
 299     -tags => 'rectangle',
 300 );
 301
 302 $dasm_frame->Button(
 303     -text    => 'Locate',
 304     -command => sub {
 305         $target_binary = $fs->Show( -popover => 'cursor', -create => 1, );
 306     },
 307 )->pack( -side => 'left', );
 308
 309 my $no_index_1_1 =
 310   { 'map' =>
 311       { ':key' => { name => \&string, list => { value => \&string }, }, }, };
 312
 313 #3...........
 314         },
 315
 316         'wtc.wtc4' => {
 317             source => "wtc",
 318             params => "wtc4",
 319             expect => <<'#4...........',
 320 # both single and multiple line lists:
 321 @LoL = (
 322     [ "fred",   "barney" ],
 323     [ "george", "jane",  "elroy" ],
 324     [ "homer",  "marge", "bart" ],
 325 );
 326
 327 # single line
 328 ( $name, $body ) = ( $2, $3 );
 329
 330 # multiline, but not bare
 331 $text = $main->Scrolled( TextUndo, $yyy, $zzz, $wwwww,
 332     selectbackgroundxxxxx => 'yellow', );
 333
 334 # this will pass for 'h'
 335 my $new = {
 336     %$item,
 337     text  => $leaf,
 338     color => 'green',
 339 };
 340
 341 # matches 'i'
 342 my @list = (
 343
 344     $xx,
 345     $yy,
 346 );
 347
 348 # does not match 'h'
 349 $c1->create(
 350     'rectangle', 40, 60, 80, 80,
 351     -fill => 'red',
 352     -tags => 'rectangle',
 353 );
 354
 355 $dasm_frame->Button(
 356     -text    => 'Locate',
 357     -command => sub {
 358         $target_binary = $fs->Show( -popover => 'cursor', -create => 1 );
 359     },
 360 )->pack( -side => 'left' );
 361
 362 my $no_index_1_1 =
 363   { 'map' => { ':key' => { name => \&string, list => { value => \&string } } },
 364   };
 365
 366 #4...........
 367         },
 368
 369         'wtc.wtc5' => {
 370             source => "wtc",
 371             params => "wtc5",
 372             expect => <<'#5...........',
 373 # both single and multiple line lists:
 374 @LoL = (
 375     [ "fred",   "barney" ],
 376     [ "george", "jane",  "elroy" ],
 377     [ "homer",  "marge", "bart" ],
 378 );
 379
 380 # single line
 381 ( $name, $body ) = ( $2, $3 );
 382
 383 # multiline, but not bare
 384 $text = $main->Scrolled( TextUndo, $yyy, $zzz, $wwwww,
 385     selectbackgroundxxxxx => 'yellow' );
 386
 387 # this will pass for 'h'
 388 my $new = {
 389     %$item,
 390     text  => $leaf,
 391     color => 'green',
 392 };
 393
 394 # matches 'i'
 395 my @list = (
 396
 397     $xx,
 398     $yy,
 399 );
 400
 401 # does not match 'h'
 402 $c1->create(
 403     'rectangle', 40, 60, 80, 80,
 404     -fill => 'red',
 405     -tags => 'rectangle',
 406 );
 407
 408 $dasm_frame->Button(
 409     -text    => 'Locate',
 410     -command => sub {
 411         $target_binary = $fs->Show( -popover => 'cursor', -create => 1 );
 412     },
 413 )->pack( -side => 'left' );
 414
 415 my $no_index_1_1 =
 416   { 'map' => { ':key' => { name => \&string, list => { value => \&string } } }
 417   };
 418
 419 #5...........
 420         },
 421
 422         'wtc.wtc6' => {
 423             source => "wtc",
 424             params => "wtc6",
 425             expect => <<'#6...........',
 426 # both single and multiple line lists:
 427 @LoL = (
 428     [ "fred",   "barney" ],
 429     [ "george", "jane",  "elroy" ],
 430     [ "homer",  "marge", "bart" ] );
 431
 432 # single line
 433 ( $name, $body ) = ( $2, $3 );
 434
 435 # multiline, but not bare
 436 $text = $main->Scrolled( TextUndo, $yyy, $zzz, $wwwww,
 437     selectbackgroundxxxxx => 'yellow' );
 438
 439 # this will pass for 'h'
 440 my $new = {
 441     %$item,
 442     text  => $leaf,
 443     color => 'green',
 444 };
 445
 446 # matches 'i'
 447 my @list = (
 448
 449     $xx,
 450     $yy,
 451 );
 452
 453 # does not match 'h'
 454 $c1->create(
 455     'rectangle', 40, 60, 80, 80,
 456     -fill => 'red',
 457     -tags => 'rectangle' );
 458
 459 $dasm_frame->Button(
 460     -text    => 'Locate',
 461     -command => sub {
 462         $target_binary = $fs->Show( -popover => 'cursor', -create => 1 );
 463     },
 464 )->pack( -side => 'left' );
 465
 466 my $no_index_1_1 =
 467   { 'map' => { ':key' => { name => \&string, list => { value => \&string } } }
 468   };
 469
 470 #6...........
 471         },
 472
 473         'dwic.def' => {
 474             source => "dwic",
 475             params => "def",
 476             expect => <<'#7...........',
 477     skip_symbols(
 478         [
 479             qw(
 480               Perl_dump_fds
 481               Perl_ErrorNo
 482               Perl_GetVars
 483               PL_sys_intern
 484             )
 485         ],
 486     );
 487 #7...........
 488         },
 489
 490         'dwic.dwic' => {
 491             source => "dwic",
 492             params => "dwic",
 493             expect => <<'#8...........',
 494     skip_symbols( [ qw(
 495         Perl_dump_fds
 496         Perl_ErrorNo
 497         Perl_GetVars
 498         PL_sys_intern
 499     ) ] );
 500 #8...........
 501         },
 502
 503         'wtc.wtc7' => {
 504             source => "wtc",
 505             params => "wtc7",
 506             expect => <<'#9...........',
 507 # both single and multiple line lists:
 508 @LoL = (
 509     [ "fred",   "barney" ],
 510     [ "george", "jane",  "elroy" ],
 511     [ "homer",  "marge", "bart" ] );
 512
 513 # single line
 514 ( $name, $body ) = ( $2, $3 );
 515
 516 # multiline, but not bare
 517 $text = $main->Scrolled( TextUndo, $yyy, $zzz, $wwwww,
 518     selectbackgroundxxxxx => 'yellow' );
 519
 520 # this will pass for 'h'
 521 my $new = {
 522     %$item,
 523     text  => $leaf,
 524     color => 'green',
 525 };
 526
 527 # matches 'i'
 528 my @list = (
 529
 530     $xx,
 531     $yy );
 532
 533 # does not match 'h'
 534 $c1->create(
 535     'rectangle', 40, 60, 80, 80,
 536     -fill => 'red',
 537     -tags => 'rectangle' );
 538
 539 $dasm_frame->Button(
 540     -text    => 'Locate',
 541     -command => sub {
 542         $target_binary = $fs->Show( -popover => 'cursor', -create => 1 );
 543     },
 544 )->pack( -side => 'left' );
 545
 546 my $no_index_1_1 =
 547   { 'map' => { ':key' => { name => \&string, list => { value => \&string } } }
 548   };
 549
 550 #9...........
 551         },
 552
 553         'rt144979.def' => {
 554             source => "rt144979",
 555             params => "def",
 556             expect => <<'#10...........',
 557 # part 1
 558 GetOptions(
 559     "format|f=s" => sub {
 560         my ( $n, $v ) = @_;
 561         if ( ( my $k = $formats{$v} ) ) {
 562             $format = $k;
 563         }
 564         else {
 565             die("--format must be 'system' or 'user'\n");
 566         }
 567         return;
 568     },
 569 );
 570
 571 # part 2
 572 {
 573     {
 574         {
 575             my $desc =
 576               $access
 577               ? "for -$op under use filetest 'access' $desc_tail"
 578               : "for -$op $desc_tail";
 579             {
 580                 local $SIG{__WARN__} = sub {
 581                     my $w = shift;
 582                     if ( $w =~ /^File::stat ignores VMS ACLs/ ) {
 583                         ++$vwarn;
 584                     }
 585                     elsif ( $w =~ /^File::stat ignores use filetest 'access'/ )
 586                     {
 587                         ++$awarn;
 588                     }
 589                     else {
 590                         $warnings .= $w;
 591                     }
 592                 };
 593                 $rv = eval "$access; -$op \$stat";
 594             }
 595         }
 596     }
 597 }
 598
 599 #10...........
 600         },
 601
 602         'rt144979.rt144979' => {
 603             source => "rt144979",
 604             params => "rt144979",
 605             expect => <<'#11...........',
 606 # part 1
 607 GetOptions(
 608       "format|f=s" => sub {
 609           my ( $n, $v ) = @_;
 610           if ( ( my $k = $formats{$v} ) ) {
 611               $format = $k;
 612           } else {
 613               die("--format must be 'system' or 'user'\n");
 614           }
 615           return;
 616       },
 617 );
 618
 619 # part 2
 620 {
 621     {
 622         {
 623             my $desc =
 624               $access
 625               ? "for -$op under use filetest 'access' $desc_tail"
 626               : "for -$op $desc_tail";
 627             {
 628                 local $SIG{__WARN__} = sub {
 629                     my $w = shift;
 630                     if ( $w =~ /^File::stat ignores VMS ACLs/ ) {
 631                         ++$vwarn;
 632                     } elsif (
 633                              $w =~ /^File::stat ignores use filetest 'access'/ )
 634                     {
 635                         ++$awarn;
 636                     } else {
 637                         $warnings .= $w;
 638                     }
 639                 };
 640                 $rv = eval "$access; -$op \$stat";
 641             }
 642         }
 643     }
 644 }
 645
 646 #11...........
 647         },
 648     };
 649
 650     my $ntests = 0 + keys %{$rtests};
 651     plan tests => $ntests;
 652 }
 653
 654 ###############
 655 # EXECUTE TESTS
 656 ###############
 657
 658 foreach my $key ( sort keys %{$rtests} ) {
 659     my $output;
 660     my $sname  = $rtests->{$key}->{source};
 661     my $expect = $rtests->{$key}->{expect};
 662     my $pname  = $rtests->{$key}->{params};
 663     my $source = $rsources->{$sname};
 664     my $params = defined($pname) ? $rparams->{$pname} : "";
 665     my $stderr_string;
 666     my $errorfile_string;
 667     my $err = Perl::Tidy::perltidy(
 668         source      => \$source,
 669         destination => \$output,
 670         perltidyrc  => \$params,
 671         argv        => '',             # for safety; hide any ARGV from perltidy
 672         stderr      => \$stderr_string,
 673         errorfile   => \$errorfile_string,    # not used when -se flag is set
 674     );
 675     if ( $err || $stderr_string || $errorfile_string ) {
 676         print STDERR "Error output received for test '$key'\n";
 677         if ($err) {
 678             print STDERR "An error flag '$err' was returned\n";
 679             ok( !$err );
 680         }
 681         if ($stderr_string) {
 682             print STDERR "---------------------\n";
 683             print STDERR "<<STDERR>>\n$stderr_string\n";
 684             print STDERR "---------------------\n";
 685             ok( !$stderr_string );
 686         }
 687         if ($errorfile_string) {
 688             print STDERR "---------------------\n";
 689             print STDERR "<<.ERR file>>\n$errorfile_string\n";
 690             print STDERR "---------------------\n";
 691             ok( !$errorfile_string );
 692         }
 693     }
 694     else {
 695         if ( !is( $output, $expect, $key ) ) {
 696             my $leno = length($output);
 697             my $lene = length($expect);
 698             if ( $leno == $lene ) {
 699                 print STDERR
 700 "#> Test '$key' gave unexpected output.  Strings differ but both have length $leno\n";
 701             }
 702             else {
 703                 print STDERR
 704 "#> Test '$key' gave unexpected output.  String lengths differ: output=$leno, expected=$lene\n";
 705             }
 706         }
 707     }
 708 }