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 #12 bfvt.bfvt0
  16 #13 bfvt.bfvt2
  17 #14 bfvt.def
  18 #15 cpb.cpb
  19 #16 cpb.def
  20 #17 rt145706.def
  21 #18 olbxl.def
  22 #19 olbxl.olbxl1
  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         'bfvt0'    => "-bfvt=0",
  41         'bfvt2'    => "-bfvt=2",
  42         'cpb'      => "-cpb",
  43         'def'      => "",
  44         'dwic'     => "-wn -dwic",
  45         'olbxl1'   => "-olbxl=eval",
  46         'rt144979' => "-xci -ce -lp",
  47         'wtc1'     => "-wtc=0 -dtc",
  48         'wtc2'     => "-wtc=1 -atc",
  49         'wtc3'     => "-wtc=m -atc",
  50         'wtc4'     => "-wtc=m -atc -dtc",
  51         'wtc5'     => "-wtc=b -atc -dtc -vtc=2",
  52         'wtc6'     => "-wtc=i -atc -dtc -vtc=2",
  53         'wtc7'     => "-wtc=h -atc -dtc -vtc=2",
  54     };
  55
  56     ############################
  57     # BEGIN SECTION 2: Sources #
  58     ############################
  59     $rsources = {
  60
  61         'bfvt' => <<'----------',
  62 # combines with -bfvt>0
  63 eval {
  64     require XSLoader;
  65     XSLoader::load( 'Sys::Syslog', $VERSION );
  66     1;
  67 }
  68   or do {
  69     require DynaLoader;
  70     push @ISA, 'DynaLoader';
  71     bootstrap Sys::Syslog $VERSION;
  72   };
  73
  74 # combines with -bfvt=2
  75 eval {
  76     ( $line, $cond ) = $self->_normalize_if_elif($line);
  77     1;
  78 }
  79   or die sprintf "Error at line %d\nLine %d: %s\n%s",
  80   ( $line_info->start_line_num() ) x 2, $line, $@;
  81
  82 # stable for bfvt<2; combines for bfvt=2; has ci
  83 my $domain = shift
  84   || eval {
  85     require Net::Domain;
  86     Net::Domain::hostfqdn();
  87 }
  88   || "";
  89
  90 # stays combined for all bfvt; has ci
  91 my $domain = shift
  92   || eval {
  93     require Net::Domain;
  94     Net::Domain::hostfqdn();
  95 } || "";
  96 ----------
  97
  98         'cpb' => <<'----------',
  99 foreach my $dir (
 100     '05_lexer', '07_token', '08_regression', '11_util',
 101     '13_data',  '15_transform'
 102   )
 103 {
 104     my @perl = find_files( catdir( 't', 'data', $dir ) );
 105     push @files, @perl;
 106 }
 107
 108 ----------
 109
 110         'dwic' => <<'----------',
 111     skip_symbols(
 112         [ qw(
 113             Perl_dump_fds
 114             Perl_ErrorNo
 115             Perl_GetVars
 116             PL_sys_intern
 117         ) ],
 118     );
 119 ----------
 120
 121         'olbxl' => <<'----------',
 122             eval {
 123                require Ace };
 124
 125             @list = map {
 126                 $frm{ ( /@(.*?)>/ ? $1 : $_ ) }++ ? () : ($_);
 127             } @list;
 128
 129             $color = join(
 130                 '/',
 131                 sort {
 132                     $color_value{$::a} <=> $color_value{$::b};
 133                 } keys %colors
 134             );
 135
 136             @sorted = sort {
 137                 $SortDir * $PageTotal{$a} <=> $SortDir * $PageTotal{$b}
 138                 };
 139 ----------
 140
 141         'rt144979' => <<'----------',
 142 # part 1
 143 GetOptions(
 144       "format|f=s" => sub {
 145           my ( $n, $v ) = @_;
 146           if ( ( my $k = $formats{$v} ) ) {
 147               $format = $k;
 148       } else {
 149               die("--format must be 'system' or 'user'\n");
 150           }
 151           return;
 152       },
 153 );
 154
 155 # part 2
 156 {{{
 157             my $desc =
 158               $access
 159               ? "for -$op under use filetest 'access' $desc_tail"
 160               : "for -$op $desc_tail";
 161             {
 162                 local $SIG{__WARN__} = sub {
 163                     my $w = shift;
 164                     if ($w =~ /^File::stat ignores VMS ACLs/)
 165                     {
 166                         ++$vwarn;
 167                       } elsif (
 168                               $w =~ /^File::stat ignores use filetest 'access'/)
 169                     {
 170                         ++$awarn;
 171                     } else
 172                     {
 173                         $warnings .= $w;
 174                     }
 175                 };
 176                 $rv = eval "$access; -$op \$stat";
 177             }
 178 }}}
 179
 180 ----------
 181
 182         'rt145706' => <<'----------',
 183 # some tests for default setting --use-feature=class, rt145706
 184 class Example::Subclass1 : isa(Example::Base) { ... }
 185 class Example::Subclass2 : isa(Example::Base 2.345) { ... }
 186 class Example::Subclass3 : isa(Example::Base) 1.345 { ... }
 187 field $y : param(the_y_value);
 188 class Pointer 2.0 {
 189     field $x : param;
 190     field $y : param;
 191
 192     method to_string() {
 193         return "($x, $y)";
 194     }
 195 }
 196
 197 ADJUST {
 198     $x = 0;
 199 }
 200
 201 # these should not produce errors
 202 method paint => sub {
 203     ...;
 204 };
 205 method painter
 206
 207   => sub {
 208     ...;
 209   };
 210 is( ( method Pack "a", "b", "c" ), "method,a,b,c" );
 211 class ExtendsBasicAttributes is BasicAttributes{
 212  ...
 213 }
 214 class BrokenExtendsBasicAttributes
 215 is BasicAttributes{
 216  ...
 217 }
 218 class +Night with +Bad {
 219     public nine { return 'crazy' }
 220 };
 221 my $x = field(50);
 222 ----------
 223
 224         'wtc' => <<'----------',
 225 # both single and multiple line lists:
 226 @LoL = (
 227     [ "fred",   "barney", ],
 228     [ "george", "jane",  "elroy" ],
 229     [ "homer",  "marge", "bart", ],
 230 );
 231
 232 # single line
 233 ( $name, $body ) = ( $2, $3, );
 234
 235 # multiline, but not bare
 236 $text = $main->Scrolled( TextUndo, $yyy, $zzz, $wwwww,
 237     selectbackgroundxxxxx => 'yellow', );
 238
 239 # this will pass for 'h'
 240 my $new = {
 241       %$item,
 242       text => $leaf,
 243       color => 'green',
 244 };
 245
 246 # matches 'i'
 247 my @list = (
 248
 249     $xx,
 250     $yy
 251 );
 252
 253 # does not match 'h'
 254 $c1->create(
 255     'rectangle', 40, 60, 80, 80,
 256     -fill => 'red',
 257     -tags => 'rectangle'
 258 );
 259
 260 $dasm_frame->Button(
 261     -text    => 'Locate',
 262     -command => sub {
 263         $target_binary = $fs->Show( -popover => 'cursor', -create  => 1, );
 264     },
 265 )->pack( -side => 'left', );
 266
 267 my $no_index_1_1 =
 268   { 'map' =>
 269       { ':key' => { name => \&string, list => { value => \&string }, }, }, };
 270
 271
 272 ----------
 273     };
 274
 275     ####################################
 276     # BEGIN SECTION 3: Expected output #
 277     ####################################
 278     $rtests = {
 279
 280         'wtc.wtc1' => {
 281             source => "wtc",
 282             params => "wtc1",
 283             expect => <<'#1...........',
 284 # both single and multiple line lists:
 285 @LoL = (
 286     [ "fred",   "barney" ],
 287     [ "george", "jane",  "elroy" ],
 288     [ "homer",  "marge", "bart" ]
 289 );
 290
 291 # single line
 292 ( $name, $body ) = ( $2, $3 );
 293
 294 # multiline, but not bare
 295 $text = $main->Scrolled( TextUndo, $yyy, $zzz, $wwwww,
 296     selectbackgroundxxxxx => 'yellow' );
 297
 298 # this will pass for 'h'
 299 my $new = {
 300     %$item,
 301     text  => $leaf,
 302     color => 'green'
 303 };
 304
 305 # matches 'i'
 306 my @list = (
 307
 308     $xx,
 309     $yy
 310 );
 311
 312 # does not match 'h'
 313 $c1->create(
 314     'rectangle', 40, 60, 80, 80,
 315     -fill => 'red',
 316     -tags => 'rectangle'
 317 );
 318
 319 $dasm_frame->Button(
 320     -text    => 'Locate',
 321     -command => sub {
 322         $target_binary = $fs->Show( -popover => 'cursor', -create => 1 );
 323     }
 324 )->pack( -side => 'left' );
 325
 326 my $no_index_1_1 =
 327   { 'map' => { ':key' => { name => \&string, list => { value => \&string } } }
 328   };
 329
 330 #1...........
 331         },
 332
 333         'wtc.wtc2' => {
 334             source => "wtc",
 335             params => "wtc2",
 336             expect => <<'#2...........',
 337 # both single and multiple line lists:
 338 @LoL = (
 339     [ "fred",   "barney", ],
 340     [ "george", "jane",  "elroy", ],
 341     [ "homer",  "marge", "bart", ],
 342 );
 343
 344 # single line
 345 ( $name, $body, ) = ( $2, $3, );
 346
 347 # multiline, but not bare
 348 $text = $main->Scrolled( TextUndo, $yyy, $zzz, $wwwww,
 349     selectbackgroundxxxxx => 'yellow', );
 350
 351 # this will pass for 'h'
 352 my $new = {
 353     %$item,
 354     text  => $leaf,
 355     color => 'green',
 356 };
 357
 358 # matches 'i'
 359 my @list = (
 360
 361     $xx,
 362     $yy,
 363 );
 364
 365 # does not match 'h'
 366 $c1->create(
 367     'rectangle', 40, 60, 80, 80,
 368     -fill => 'red',
 369     -tags => 'rectangle',
 370 );
 371
 372 $dasm_frame->Button(
 373     -text    => 'Locate',
 374     -command => sub {
 375         $target_binary = $fs->Show( -popover => 'cursor', -create => 1, );
 376     },
 377 )->pack( -side => 'left', );
 378
 379 my $no_index_1_1 =
 380   { 'map' =>
 381       { ':key' => { name => \&string, list => { value => \&string }, }, }, };
 382
 383 #2...........
 384         },
 385
 386         'wtc.wtc3' => {
 387             source => "wtc",
 388             params => "wtc3",
 389             expect => <<'#3...........',
 390 # both single and multiple line lists:
 391 @LoL = (
 392     [ "fred",   "barney", ],
 393     [ "george", "jane",  "elroy" ],
 394     [ "homer",  "marge", "bart", ],
 395 );
 396
 397 # single line
 398 ( $name, $body ) = ( $2, $3, );
 399
 400 # multiline, but not bare
 401 $text = $main->Scrolled( TextUndo, $yyy, $zzz, $wwwww,
 402     selectbackgroundxxxxx => 'yellow', );
 403
 404 # this will pass for 'h'
 405 my $new = {
 406     %$item,
 407     text  => $leaf,
 408     color => 'green',
 409 };
 410
 411 # matches 'i'
 412 my @list = (
 413
 414     $xx,
 415     $yy,
 416 );
 417
 418 # does not match 'h'
 419 $c1->create(
 420     'rectangle', 40, 60, 80, 80,
 421     -fill => 'red',
 422     -tags => 'rectangle',
 423 );
 424
 425 $dasm_frame->Button(
 426     -text    => 'Locate',
 427     -command => sub {
 428         $target_binary = $fs->Show( -popover => 'cursor', -create => 1, );
 429     },
 430 )->pack( -side => 'left', );
 431
 432 my $no_index_1_1 =
 433   { 'map' =>
 434       { ':key' => { name => \&string, list => { value => \&string }, }, }, };
 435
 436 #3...........
 437         },
 438
 439         'wtc.wtc4' => {
 440             source => "wtc",
 441             params => "wtc4",
 442             expect => <<'#4...........',
 443 # both single and multiple line lists:
 444 @LoL = (
 445     [ "fred",   "barney" ],
 446     [ "george", "jane",  "elroy" ],
 447     [ "homer",  "marge", "bart" ],
 448 );
 449
 450 # single line
 451 ( $name, $body ) = ( $2, $3 );
 452
 453 # multiline, but not bare
 454 $text = $main->Scrolled( TextUndo, $yyy, $zzz, $wwwww,
 455     selectbackgroundxxxxx => 'yellow', );
 456
 457 # this will pass for 'h'
 458 my $new = {
 459     %$item,
 460     text  => $leaf,
 461     color => 'green',
 462 };
 463
 464 # matches 'i'
 465 my @list = (
 466
 467     $xx,
 468     $yy,
 469 );
 470
 471 # does not match 'h'
 472 $c1->create(
 473     'rectangle', 40, 60, 80, 80,
 474     -fill => 'red',
 475     -tags => 'rectangle',
 476 );
 477
 478 $dasm_frame->Button(
 479     -text    => 'Locate',
 480     -command => sub {
 481         $target_binary = $fs->Show( -popover => 'cursor', -create => 1 );
 482     },
 483 )->pack( -side => 'left' );
 484
 485 my $no_index_1_1 =
 486   { 'map' => { ':key' => { name => \&string, list => { value => \&string } } },
 487   };
 488
 489 #4...........
 490         },
 491
 492         'wtc.wtc5' => {
 493             source => "wtc",
 494             params => "wtc5",
 495             expect => <<'#5...........',
 496 # both single and multiple line lists:
 497 @LoL = (
 498     [ "fred",   "barney" ],
 499     [ "george", "jane",  "elroy" ],
 500     [ "homer",  "marge", "bart" ],
 501 );
 502
 503 # single line
 504 ( $name, $body ) = ( $2, $3 );
 505
 506 # multiline, but not bare
 507 $text = $main->Scrolled( TextUndo, $yyy, $zzz, $wwwww,
 508     selectbackgroundxxxxx => 'yellow' );
 509
 510 # this will pass for 'h'
 511 my $new = {
 512     %$item,
 513     text  => $leaf,
 514     color => 'green',
 515 };
 516
 517 # matches 'i'
 518 my @list = (
 519
 520     $xx,
 521     $yy,
 522 );
 523
 524 # does not match 'h'
 525 $c1->create(
 526     'rectangle', 40, 60, 80, 80,
 527     -fill => 'red',
 528     -tags => 'rectangle',
 529 );
 530
 531 $dasm_frame->Button(
 532     -text    => 'Locate',
 533     -command => sub {
 534         $target_binary = $fs->Show( -popover => 'cursor', -create => 1 );
 535     },
 536 )->pack( -side => 'left' );
 537
 538 my $no_index_1_1 =
 539   { 'map' => { ':key' => { name => \&string, list => { value => \&string } } }
 540   };
 541
 542 #5...........
 543         },
 544
 545         'wtc.wtc6' => {
 546             source => "wtc",
 547             params => "wtc6",
 548             expect => <<'#6...........',
 549 # both single and multiple line lists:
 550 @LoL = (
 551     [ "fred",   "barney" ],
 552     [ "george", "jane",  "elroy" ],
 553     [ "homer",  "marge", "bart" ] );
 554
 555 # single line
 556 ( $name, $body ) = ( $2, $3 );
 557
 558 # multiline, but not bare
 559 $text = $main->Scrolled( TextUndo, $yyy, $zzz, $wwwww,
 560     selectbackgroundxxxxx => 'yellow' );
 561
 562 # this will pass for 'h'
 563 my $new = {
 564     %$item,
 565     text  => $leaf,
 566     color => 'green',
 567 };
 568
 569 # matches 'i'
 570 my @list = (
 571
 572     $xx,
 573     $yy,
 574 );
 575
 576 # does not match 'h'
 577 $c1->create(
 578     'rectangle', 40, 60, 80, 80,
 579     -fill => 'red',
 580     -tags => 'rectangle' );
 581
 582 $dasm_frame->Button(
 583     -text    => 'Locate',
 584     -command => sub {
 585         $target_binary = $fs->Show( -popover => 'cursor', -create => 1 );
 586     },
 587 )->pack( -side => 'left' );
 588
 589 my $no_index_1_1 =
 590   { 'map' => { ':key' => { name => \&string, list => { value => \&string } } }
 591   };
 592
 593 #6...........
 594         },
 595
 596         'dwic.def' => {
 597             source => "dwic",
 598             params => "def",
 599             expect => <<'#7...........',
 600     skip_symbols(
 601         [
 602             qw(
 603               Perl_dump_fds
 604               Perl_ErrorNo
 605               Perl_GetVars
 606               PL_sys_intern
 607             )
 608         ],
 609     );
 610 #7...........
 611         },
 612
 613         'dwic.dwic' => {
 614             source => "dwic",
 615             params => "dwic",
 616             expect => <<'#8...........',
 617     skip_symbols( [ qw(
 618         Perl_dump_fds
 619         Perl_ErrorNo
 620         Perl_GetVars
 621         PL_sys_intern
 622     ) ] );
 623 #8...........
 624         },
 625
 626         'wtc.wtc7' => {
 627             source => "wtc",
 628             params => "wtc7",
 629             expect => <<'#9...........',
 630 # both single and multiple line lists:
 631 @LoL = (
 632     [ "fred",   "barney" ],
 633     [ "george", "jane",  "elroy" ],
 634     [ "homer",  "marge", "bart" ] );
 635
 636 # single line
 637 ( $name, $body ) = ( $2, $3 );
 638
 639 # multiline, but not bare
 640 $text = $main->Scrolled( TextUndo, $yyy, $zzz, $wwwww,
 641     selectbackgroundxxxxx => 'yellow' );
 642
 643 # this will pass for 'h'
 644 my $new = {
 645     %$item,
 646     text  => $leaf,
 647     color => 'green',
 648 };
 649
 650 # matches 'i'
 651 my @list = (
 652
 653     $xx,
 654     $yy );
 655
 656 # does not match 'h'
 657 $c1->create(
 658     'rectangle', 40, 60, 80, 80,
 659     -fill => 'red',
 660     -tags => 'rectangle' );
 661
 662 $dasm_frame->Button(
 663     -text    => 'Locate',
 664     -command => sub {
 665         $target_binary = $fs->Show( -popover => 'cursor', -create => 1 );
 666     },
 667 )->pack( -side => 'left' );
 668
 669 my $no_index_1_1 =
 670   { 'map' => { ':key' => { name => \&string, list => { value => \&string } } }
 671   };
 672
 673 #9...........
 674         },
 675
 676         'rt144979.def' => {
 677             source => "rt144979",
 678             params => "def",
 679             expect => <<'#10...........',
 680 # part 1
 681 GetOptions(
 682     "format|f=s" => sub {
 683         my ( $n, $v ) = @_;
 684         if ( ( my $k = $formats{$v} ) ) {
 685             $format = $k;
 686         }
 687         else {
 688             die("--format must be 'system' or 'user'\n");
 689         }
 690         return;
 691     },
 692 );
 693
 694 # part 2
 695 {
 696     {
 697         {
 698             my $desc =
 699               $access
 700               ? "for -$op under use filetest 'access' $desc_tail"
 701               : "for -$op $desc_tail";
 702             {
 703                 local $SIG{__WARN__} = sub {
 704                     my $w = shift;
 705                     if ( $w =~ /^File::stat ignores VMS ACLs/ ) {
 706                         ++$vwarn;
 707                     }
 708                     elsif ( $w =~ /^File::stat ignores use filetest 'access'/ )
 709                     {
 710                         ++$awarn;
 711                     }
 712                     else {
 713                         $warnings .= $w;
 714                     }
 715                 };
 716                 $rv = eval "$access; -$op \$stat";
 717             }
 718         }
 719     }
 720 }
 721
 722 #10...........
 723         },
 724
 725         'rt144979.rt144979' => {
 726             source => "rt144979",
 727             params => "rt144979",
 728             expect => <<'#11...........',
 729 # part 1
 730 GetOptions(
 731       "format|f=s" => sub {
 732           my ( $n, $v ) = @_;
 733           if ( ( my $k = $formats{$v} ) ) {
 734               $format = $k;
 735           } else {
 736               die("--format must be 'system' or 'user'\n");
 737           }
 738           return;
 739       },
 740 );
 741
 742 # part 2
 743 {
 744     {
 745         {
 746             my $desc =
 747               $access
 748               ? "for -$op under use filetest 'access' $desc_tail"
 749               : "for -$op $desc_tail";
 750             {
 751                 local $SIG{__WARN__} = sub {
 752                     my $w = shift;
 753                     if ( $w =~ /^File::stat ignores VMS ACLs/ ) {
 754                         ++$vwarn;
 755                     } elsif (
 756                              $w =~ /^File::stat ignores use filetest 'access'/ )
 757                     {
 758                         ++$awarn;
 759                     } else {
 760                         $warnings .= $w;
 761                     }
 762                 };
 763                 $rv = eval "$access; -$op \$stat";
 764             }
 765         }
 766     }
 767 }
 768
 769 #11...........
 770         },
 771
 772         'bfvt.bfvt0' => {
 773             source => "bfvt",
 774             params => "bfvt0",
 775             expect => <<'#12...........',
 776 # combines with -bfvt>0
 777 eval {
 778     require XSLoader;
 779     XSLoader::load( 'Sys::Syslog', $VERSION );
 780     1;
 781 }
 782   or do {
 783     require DynaLoader;
 784     push @ISA, 'DynaLoader';
 785     bootstrap Sys::Syslog $VERSION;
 786   };
 787
 788 # combines with -bfvt=2
 789 eval {
 790     ( $line, $cond ) = $self->_normalize_if_elif($line);
 791     1;
 792 }
 793   or die sprintf "Error at line %d\nLine %d: %s\n%s",
 794   ( $line_info->start_line_num() ) x 2, $line, $@;
 795
 796 # stable for bfvt<2; combines for bfvt=2; has ci
 797 my $domain = shift
 798   || eval {
 799     require Net::Domain;
 800     Net::Domain::hostfqdn();
 801   }
 802   || "";
 803
 804 # stays combined for all bfvt; has ci
 805 my $domain = shift
 806   || eval {
 807     require Net::Domain;
 808     Net::Domain::hostfqdn();
 809   } || "";
 810 #12...........
 811         },
 812
 813         'bfvt.bfvt2' => {
 814             source => "bfvt",
 815             params => "bfvt2",
 816             expect => <<'#13...........',
 817 # combines with -bfvt>0
 818 eval {
 819     require XSLoader;
 820     XSLoader::load( 'Sys::Syslog', $VERSION );
 821     1;
 822 } or do {
 823     require DynaLoader;
 824     push @ISA, 'DynaLoader';
 825     bootstrap Sys::Syslog $VERSION;
 826 };
 827
 828 # combines with -bfvt=2
 829 eval {
 830     ( $line, $cond ) = $self->_normalize_if_elif($line);
 831     1;
 832 } or die sprintf "Error at line %d\nLine %d: %s\n%s",
 833   ( $line_info->start_line_num() ) x 2, $line, $@;
 834
 835 # stable for bfvt<2; combines for bfvt=2; has ci
 836 my $domain = shift
 837   || eval {
 838     require Net::Domain;
 839     Net::Domain::hostfqdn();
 840   } || "";
 841
 842 # stays combined for all bfvt; has ci
 843 my $domain = shift
 844   || eval {
 845     require Net::Domain;
 846     Net::Domain::hostfqdn();
 847   } || "";
 848 #13...........
 849         },
 850
 851         'bfvt.def' => {
 852             source => "bfvt",
 853             params => "def",
 854             expect => <<'#14...........',
 855 # combines with -bfvt>0
 856 eval {
 857     require XSLoader;
 858     XSLoader::load( 'Sys::Syslog', $VERSION );
 859     1;
 860 } or do {
 861     require DynaLoader;
 862     push @ISA, 'DynaLoader';
 863     bootstrap Sys::Syslog $VERSION;
 864 };
 865
 866 # combines with -bfvt=2
 867 eval {
 868     ( $line, $cond ) = $self->_normalize_if_elif($line);
 869     1;
 870 }
 871   or die sprintf "Error at line %d\nLine %d: %s\n%s",
 872   ( $line_info->start_line_num() ) x 2, $line, $@;
 873
 874 # stable for bfvt<2; combines for bfvt=2; has ci
 875 my $domain = shift
 876   || eval {
 877     require Net::Domain;
 878     Net::Domain::hostfqdn();
 879   }
 880   || "";
 881
 882 # stays combined for all bfvt; has ci
 883 my $domain = shift
 884   || eval {
 885     require Net::Domain;
 886     Net::Domain::hostfqdn();
 887   } || "";
 888 #14...........
 889         },
 890
 891         'cpb.cpb' => {
 892             source => "cpb",
 893             params => "cpb",
 894             expect => <<'#15...........',
 895 foreach my $dir (
 896     '05_lexer', '07_token', '08_regression', '11_util',
 897     '13_data',  '15_transform'
 898 ) {
 899     my @perl = find_files( catdir( 't', 'data', $dir ) );
 900     push @files, @perl;
 901 }
 902
 903 #15...........
 904         },
 905
 906         'cpb.def' => {
 907             source => "cpb",
 908             params => "def",
 909             expect => <<'#16...........',
 910 foreach my $dir (
 911     '05_lexer', '07_token', '08_regression', '11_util',
 912     '13_data',  '15_transform'
 913   )
 914 {
 915     my @perl = find_files( catdir( 't', 'data', $dir ) );
 916     push @files, @perl;
 917 }
 918
 919 #16...........
 920         },
 921
 922         'rt145706.def' => {
 923             source => "rt145706",
 924             params => "def",
 925             expect => <<'#17...........',
 926 # some tests for default setting --use-feature=class, rt145706
 927 class Example::Subclass1 : isa(Example::Base) { ... }
 928 class Example::Subclass2 : isa(Example::Base 2.345) { ... }
 929 class Example::Subclass3 : isa(Example::Base) 1.345 { ... }
 930 field $y : param(the_y_value);
 931 class Pointer 2.0 {
 932     field $x : param;
 933     field $y : param;
 934
 935     method to_string() {
 936         return "($x, $y)";
 937     }
 938 }
 939
 940 ADJUST {
 941     $x = 0;
 942 }
 943
 944 # these should not produce errors
 945 method paint => sub {
 946     ...;
 947 };
 948 method painter
 949
 950   => sub {
 951     ...;
 952   };
 953 is( ( method Pack "a", "b", "c" ), "method,a,b,c" );
 954 class ExtendsBasicAttributes is BasicAttributes {
 955     ...
 956 }
 957 class BrokenExtendsBasicAttributes is BasicAttributes {
 958     ...
 959 }
 960 class +Night with +Bad {
 961     public nine { return 'crazy' }
 962 };
 963 my $x = field(50);
 964 #17...........
 965         },
 966
 967         'olbxl.def' => {
 968             source => "olbxl",
 969             params => "def",
 970             expect => <<'#18...........',
 971             eval { require Ace };
 972
 973             @list =
 974               map { $frm{ ( /@(.*?)>/ ? $1 : $_ ) }++ ? () : ($_); } @list;
 975
 976             $color = join( '/',
 977                 sort { $color_value{$::a} <=> $color_value{$::b}; }
 978                   keys %colors );
 979
 980             @sorted =
 981               sort { $SortDir * $PageTotal{$a} <=> $SortDir * $PageTotal{$b} };
 982 #18...........
 983         },
 984
 985         'olbxl.olbxl1' => {
 986             source => "olbxl",
 987             params => "olbxl1",
 988             expect => <<'#19...........',
 989             eval {
 990                 require Ace;
 991             };
 992
 993             @list =
 994               map { $frm{ ( /@(.*?)>/ ? $1 : $_ ) }++ ? () : ($_); } @list;
 995
 996             $color = join( '/',
 997                 sort { $color_value{$::a} <=> $color_value{$::b}; }
 998                   keys %colors );
 999
1000             @sorted =
1001               sort { $SortDir * $PageTotal{$a} <=> $SortDir * $PageTotal{$b} };
1002 #19...........
1003         },
1004     };
1005
1006     my $ntests = 0 + keys %{$rtests};
1007     plan tests => $ntests;
1008 }
1009
1010 ###############
1011 # EXECUTE TESTS
1012 ###############
1013
1014 foreach my $key ( sort keys %{$rtests} ) {
1015     my $output;
1016     my $sname  = $rtests->{$key}->{source};
1017     my $expect = $rtests->{$key}->{expect};
1018     my $pname  = $rtests->{$key}->{params};
1019     my $source = $rsources->{$sname};
1020     my $params = defined($pname) ? $rparams->{$pname} : "";
1021     my $stderr_string;
1022     my $errorfile_string;
1023     my $err = Perl::Tidy::perltidy(
1024         source      => \$source,
1025         destination => \$output,
1026         perltidyrc  => \$params,
1027         argv        => '',             # for safety; hide any ARGV from perltidy
1028         stderr      => \$stderr_string,
1029         errorfile   => \$errorfile_string,    # not used when -se flag is set
1030     );
1031     if ( $err || $stderr_string || $errorfile_string ) {
1032         print STDERR "Error output received for test '$key'\n";
1033         if ($err) {
1034             print STDERR "An error flag '$err' was returned\n";
1035             ok( !$err );
1036         }
1037         if ($stderr_string) {
1038             print STDERR "---------------------\n";
1039             print STDERR "<<STDERR>>\n$stderr_string\n";
1040             print STDERR "---------------------\n";
1041             ok( !$stderr_string );
1042         }
1043         if ($errorfile_string) {
1044             print STDERR "---------------------\n";
1045             print STDERR "<<.ERR file>>\n$errorfile_string\n";
1046             print STDERR "---------------------\n";
1047             ok( !$errorfile_string );
1048         }
1049     }
1050     else {
1051         if ( !is( $output, $expect, $key ) ) {
1052             my $leno = length($output);
1053             my $lene = length($expect);
1054             if ( $leno == $lene ) {
1055                 print STDERR
1056 "#> Test '$key' gave unexpected output.  Strings differ but both have length $leno\n";
1057             }
1058             else {
1059                 print STDERR
1060 "#> Test '$key' gave unexpected output.  String lengths differ: output=$leno, expected=$lene\n";
1061             }
1062         }
1063     }
1064 }