t/snippets26.t

   1 # Created with: ./make_t.pl
   2
   3 # Contents:
   4 #1 bal.bal2
   5 #2 bal.def
   6 #3 lpxl.lpxl6
   7 #4 c133.c133
   8 #5 c133.def
   9 #6 git93.def
  10 #7 git93.git93
  11 #8 c139.def
  12 #9 drc.def
  13 #10 drc.drc
  14 #11 git105.def
  15 #12 git106.def
  16 #13 git106.git106
  17 #14 c154.def
  18 #15 code_skipping.code_skipping
  19 #16 c158.def
  20 #17 git108.def
  21 #18 git108.git108
  22 #19 wtc.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         'bal2'          => "-bal=2",
  41         'c133'          => "-boc",
  42         'code_skipping' => <<'----------',
  43 # same as the default but tests -cs -csb and -cse
  44 --code-skipping
  45 --code-skipping-begin='#<<V'
  46 --code-skipping-end='#>>V'
  47 ----------
  48         'def'    => "",
  49         'drc'    => "-drc",
  50         'git106' => "-xlp -gnu -xci",
  51         'git108' => "-wn -wfc",
  52         'git93'  => <<'----------',
  53 -vxl='q'
  54 ----------
  55         'lpxl6' => <<'----------',
  56 # equivalent to -lpxl='{ [ F(2'
  57 -lp -lpil='f(2'
  58 ----------
  59     };
  60
  61     ############################
  62     # BEGIN SECTION 2: Sources #
  63     ############################
  64     $rsources = {
  65
  66         'bal' => <<'----------',
  67 {
  68   L1:
  69   L2:
  70   L3: return;
  71 };
  72 ----------
  73
  74         'c133' => <<'----------',
  75 # this will make 1 line unless -boc is used
  76 return (
  77     $x * cos($a) - $y * sin($a),
  78     $x * sin($a) + $y * cos($a)
  79 );
  80
  81 # broken list - issue c133
  82 return (
  83     $x * cos($a) - $y * sin($a),
  84     $x * sin($a) + $y * cos($a)
  85
  86 );
  87
  88 # no parens
  89 return
  90   $x * cos($a) - $y * sin($a),
  91   $x * sin($a) + $y * cos($a);
  92 ----------
  93
  94         'c139' => <<'----------',
  95 # The '&' has trailing spaces
  96 @l = &
  97 _
  98 ( -49, -71 );
  99
 100 # This '$' has trailing spaces
 101 my $
 102 b = 40;
 103
 104 # this arrow has trailing spaces
 105 $r = $c->
 106 sql_set_env_attr( $evh, $SQL_ATTR_ODBC_VERSION, $SQL_OV_ODBC2, 0 );
 107
 108 # spaces and blank line
 109 @l = &
 110
 111 _
 112 ( -49, -71 );
 113
 114 # spaces and blank line
 115 $r = $c->
 116
 117 sql_set_env_attr( $evh, $SQL_ATTR_ODBC_VERSION, $SQL_OV_ODBC2, 0 );
 118 ----------
 119
 120         'c154' => <<'----------',
 121 {{{{
 122 for (
 123     $order =
 124     $start_order * $nbSubOrderByOrder + $start_suborder ;
 125     !exists $level_hash{$level}->{$order}
 126     and $order <=
 127     $stop_order * $nbSubOrderByOrder + $stop_suborder ;
 128     $order++
 129   )
 130 {
 131 }
 132
 133 # has comma
 134 for (
 135     $q = 201 ;
 136     print '-' x 79,
 137     "\n" ;
 138     $g = (
 139         $f ^ ( $w = ( $z = $m . $e ) ^ substr $e, $q )
 140           ^ ( $n = $b ^ $d | $a ^ $l )
 141     ) & ( $w | $z ^ $f ^ $n ) & ( $l | $g )
 142   )
 143 {
 144     ...;
 145 }
 146
 147 for (
 148     $j = 0, $match_j = -1 ;
 149     $j < $sub_len
 150       &&
 151
 152       # changed from naive_string_matcher
 153       $sub->[$j] eq $big->[ $i + $j ] ; $j++
 154   )
 155 {
 156     ...;
 157 }
 158 }}}}
 159 ----------
 160
 161         'c158' => <<'----------',
 162 my $meta = try { $package->meta }
 163 or die "$package does not have a ->meta method\n";
 164
 165 my ($curr) = current();
 166 err(@_);
 167 ----------
 168
 169         'code_skipping' => <<'----------',
 170 %Hdr=%U2E=%E2U=%Fallback=();
 171 $in_charmap=$nerror=$nwarning=0;
 172 $.=0;
 173 #<<V  code skipping: perltidy will pass this verbatim without error checking
 174
 175     }}} {{{
 176
 177 #>>V
 178 my $self=shift;
 179 my $cloning=shift;
 180 ----------
 181
 182         'drc' => <<'----------',
 183 ignoreSpec( $file, "file",, \%spec,,, \%Rspec );
 184 ----------
 185
 186         'git105' => <<'----------',
 187 use v5.36;
 188
 189 use experimental 'for_list';
 190
 191 for my ( $k, $v ) ( 1, 2, 3, 4 ) {
 192     say "$k:$v";
 193 }
 194 say 'end';
 195
 196 ----------
 197
 198         'git106' => <<'----------',
 199 is( $module->VERSION, $expected,
 200     "$main_module->VERSION matches $module->VERSION ($expected)" );
 201
 202 ok( ( $@ eq "" && "@b" eq "1 4 5 9" ),
 203     'redefinition should not take effect during the sort' );
 204
 205 &$f(
 206     ( map { $points->slice($_) } @sls1 ),
 207     ( map { $n->slice($_) } @sls1 ),
 208     ( map { $this->{Colors}->slice($_) } @sls1 )
 209 );
 210
 211 AA(
 212     "0123456789012345678901234567890123456789",
 213     "0123456789012345678901234567890123456789"
 214 );
 215
 216 AAAAAA(
 217     "0123456789012345678901234567890123456789",
 218     "0123456789012345678901234567890123456789"
 219 );
 220
 221 # padded
 222 return !( $elem->isa('PPI::Statement::End')
 223     || $elem->isa('PPI::Statement::Data') );
 224
 225 for (
 226     $s = $dbobj->seq( $k, $v, R_LAST ) ;
 227     $s == 0 ;
 228     $s = $dbobj->seq( $k, $v, R_PREV )
 229   )
 230 {
 231     print "$k: $v\n";
 232 }
 233
 234 # excess without -xci
 235 fresh_perl_is( '-C-',
 236     <<'abcdefghijklmnopq', {}, "ambiguous unary operator check doesn't crash" );
 237 Warning: Use of "-C-" without parentheses is ambiguous at - line 1.
 238 abcdefghijklmnopq
 239
 240 # excess with -xci
 241 {
 242     {
 243         {
 244             $self->privmsg( $to,
 245                 "One moment please, I shall display the groups with agendas:" );
 246         }
 247     }
 248 }
 249 ----------
 250
 251         'git108' => <<'----------',
 252 elf->call_method(
 253     method_name_foo => {
 254         some_arg1       => $foo,
 255         some_other_arg3 => $bar->{'baz'},
 256     }
 257 );
 258
 259 # leading dash
 260 my $species = new Bio::Species(
 261     -classification => [
 262         qw(
 263           sapiens Homo Hominidae
 264           Catarrhini Primates Eutheria
 265           Mammalia Vertebrata
 266           Chordata Metazoa Eukaryota
 267         )
 268     ]
 269 );
 270 ----------
 271
 272         'git93' => <<'----------',
 273 use Cwd qw[cwd];
 274 use Carp qw(carp);
 275 use IPC::Cmd qw{can_run run QUOTE};
 276 use File::Path qw/mkpath/;
 277 use File::Temp qw[tempdir];
 278 use Params::Check qw<check>;
 279 use Module::Load::Conditional qw#can_load#;
 280 use Locale::Maketext::Simple Style => 'gettext';    # does not align
 281
 282 # do not align on these 'q' token types - not use statements...
 283 my $gene_color_sets = [
 284     [ qw( blue blue blue blue ) => 'blue' ],
 285     [ qw( brown blue blue blue ) => 'brown' ],
 286     [ qw( brown brown green green ) => 'brown' ],
 287 ];
 288
 289 sub quux : PluginKeyword { 'quux' }
 290 sub qaax : PluginKeyword(qiix) { die "unimplemented" }
 291
 292 use vars qw($curdir);
 293 no strict qw(vars);
 294 ----------
 295
 296         'lpxl' => <<'----------',
 297 # simple function call
 298 my $loanlength = getLoanLength(
 299                                 $borrower->{'categorycode'},    # sc1
 300                                 $iteminformation->{'itemtype'},
 301                                 $borrower->{'branchcode'}       # sc3
 302 );
 303
 304 # function call, more than one level deep
 305 my $o = very::long::class::name->new(
 306     {
 307         propA => "a",
 308         propB => "b",
 309         propC => "c",
 310     }
 311 );
 312
 313 # function call with sublist
 314 debug(
 315       "Connecting to DB.",
 316       "Extra-Parameters: " . join("<->", $extra_parms),
 317       "Config: " . join("<->", %config)
 318      );
 319
 320 # simple function call with code block
 321 $m->command(-label   => 'Save',
 322             -command => sub { print "DOS\n"; save_dialog($win); });
 323
 324 # function call, ternary in list
 325 return
 326   OptArgs2::Result->usage(
 327     $style == OptArgs2::STYLE_FULL ? 'FullUsage' : 'NormalUsage',
 328     'usage: ' . $usage . "\n" );
 329
 330 # not a function call
 331 %blastparam = (
 332     -run            => \%runparam,
 333     -file           => '',
 334     -parse          => 1,
 335     -signif         => 1e-5,
 336 );
 337
 338 # 'local' is a keyword, not a user function
 339     local (
 340         $len,    $pts,      @colspec, $char, $cols,
 341         $repeat, $celldata, $at_text, $after_text
 342     );
 343
 344 # square bracket with sublists
 345 $data = [
 346          ListElem->new(id => 0, val => 100),
 347          ListElem->new(id => 2, val => 50),
 348          ListElem->new(id => 1, val => 10),
 349         ];
 350
 351 # curly brace with sublists
 352 $behaviour = {
 353               cat   => {nap    => "lap",   eat  => "meat"},
 354               dog   => {prowl  => "growl", pool => "drool"},
 355               mouse => {nibble => "kibble"},
 356              };
 357 ----------
 358
 359         'wtc' => <<'----------',
 360 # both single and multiple line lists:
 361 @LoL = (
 362     [ "fred",   "barney", ],
 363     [ "george", "jane",  "elroy" ],
 364     [ "homer",  "marge", "bart", ],
 365 );
 366
 367 # single line
 368 ( $name, $body ) = ( $2, $3, );
 369
 370 # multiline, but not bare
 371 $text = $main->Scrolled( TextUndo, $yyy, $zzz, $wwwww,
 372     selectbackgroundxxxxx => 'yellow', );
 373
 374 # this will pass for 'h'
 375 my $new = {
 376       %$item,
 377       text => $leaf,
 378       color => 'green',
 379 };
 380
 381 # matches 'i'
 382 my @list = (
 383
 384     $xx,
 385     $yy
 386 );
 387
 388 # does not match 'h'
 389 $c1->create(
 390     'rectangle', 40, 60, 80, 80,
 391     -fill => 'red',
 392     -tags => 'rectangle'
 393 );
 394
 395 $dasm_frame->Button(
 396     -text    => 'Locate',
 397     -command => sub {
 398         $target_binary = $fs->Show( -popover => 'cursor', -create  => 1, );
 399     },
 400 )->pack( -side => 'left', );
 401
 402 my $no_index_1_1 =
 403   { 'map' =>
 404       { ':key' => { name => \&string, list => { value => \&string }, }, }, };
 405
 406
 407 ----------
 408     };
 409
 410     ####################################
 411     # BEGIN SECTION 3: Expected output #
 412     ####################################
 413     $rtests = {
 414
 415         'bal.bal2' => {
 416             source => "bal",
 417             params => "bal2",
 418             expect => <<'#1...........',
 419 {
 420   L1: L2: L3: return;
 421 };
 422 #1...........
 423         },
 424
 425         'bal.def' => {
 426             source => "bal",
 427             params => "def",
 428             expect => <<'#2...........',
 429 {
 430   L1:
 431   L2:
 432   L3: return;
 433 };
 434 #2...........
 435         },
 436
 437         'lpxl.lpxl6' => {
 438             source => "lpxl",
 439             params => "lpxl6",
 440             expect => <<'#3...........',
 441 # simple function call
 442 my $loanlength = getLoanLength(
 443                                 $borrower->{'categorycode'},    # sc1
 444                                 $iteminformation->{'itemtype'},
 445                                 $borrower->{'branchcode'}       # sc3
 446 );
 447
 448 # function call, more than one level deep
 449 my $o = very::long::class::name->new(
 450     {
 451         propA => "a",
 452         propB => "b",
 453         propC => "c",
 454     }
 455 );
 456
 457 # function call with sublist
 458 debug(
 459     "Connecting to DB.",
 460     "Extra-Parameters: " . join( "<->", $extra_parms ),
 461     "Config: " . join( "<->", %config )
 462 );
 463
 464 # simple function call with code block
 465 $m->command(
 466     -label   => 'Save',
 467     -command => sub { print "DOS\n"; save_dialog($win); }
 468 );
 469
 470 # function call, ternary in list
 471 return OptArgs2::Result->usage(
 472     $style == OptArgs2::STYLE_FULL ? 'FullUsage' : 'NormalUsage',
 473     'usage: ' . $usage . "\n" );
 474
 475 # not a function call
 476 %blastparam = (
 477     -run    => \%runparam,
 478     -file   => '',
 479     -parse  => 1,
 480     -signif => 1e-5,
 481 );
 482
 483 # 'local' is a keyword, not a user function
 484 local (
 485     $len,    $pts,      @colspec, $char, $cols,
 486     $repeat, $celldata, $at_text, $after_text
 487 );
 488
 489 # square bracket with sublists
 490 $data = [
 491     ListElem->new( id => 0, val => 100 ),
 492     ListElem->new( id => 2, val => 50 ),
 493     ListElem->new( id => 1, val => 10 ),
 494 ];
 495
 496 # curly brace with sublists
 497 $behaviour = {
 498     cat   => { nap    => "lap",   eat  => "meat" },
 499     dog   => { prowl  => "growl", pool => "drool" },
 500     mouse => { nibble => "kibble" },
 501 };
 502 #3...........
 503         },
 504
 505         'c133.c133' => {
 506             source => "c133",
 507             params => "c133",
 508             expect => <<'#4...........',
 509 # this will make 1 line unless -boc is used
 510 return (
 511     $x * cos($a) - $y * sin($a),
 512     $x * sin($a) + $y * cos($a)
 513 );
 514
 515 # broken list - issue c133
 516 return (
 517     $x * cos($a) - $y * sin($a),
 518     $x * sin($a) + $y * cos($a)
 519
 520 );
 521
 522 # no parens
 523 return
 524   $x * cos($a) - $y * sin($a),
 525   $x * sin($a) + $y * cos($a);
 526 #4...........
 527         },
 528
 529         'c133.def' => {
 530             source => "c133",
 531             params => "def",
 532             expect => <<'#5...........',
 533 # this will make 1 line unless -boc is used
 534 return ( $x * cos($a) - $y * sin($a), $x * sin($a) + $y * cos($a) );
 535
 536 # broken list - issue c133
 537 return (
 538     $x * cos($a) - $y * sin($a),
 539     $x * sin($a) + $y * cos($a)
 540
 541 );
 542
 543 # no parens
 544 return
 545   $x * cos($a) - $y * sin($a),
 546   $x * sin($a) + $y * cos($a);
 547 #5...........
 548         },
 549
 550         'git93.def' => {
 551             source => "git93",
 552             params => "def",
 553             expect => <<'#6...........',
 554 use Cwd                       qw[cwd];
 555 use Carp                      qw(carp);
 556 use IPC::Cmd                  qw{can_run run QUOTE};
 557 use File::Path                qw/mkpath/;
 558 use File::Temp                qw[tempdir];
 559 use Params::Check             qw<check>;
 560 use Module::Load::Conditional qw#can_load#;
 561 use Locale::Maketext::Simple Style => 'gettext';    # does not align
 562
 563 # do not align on these 'q' token types - not use statements...
 564 my $gene_color_sets = [
 565     [ qw( blue blue blue blue )     => 'blue' ],
 566     [ qw( brown blue blue blue )    => 'brown' ],
 567     [ qw( brown brown green green ) => 'brown' ],
 568 ];
 569
 570 sub quux : PluginKeyword       { 'quux' }
 571 sub qaax : PluginKeyword(qiix) { die "unimplemented" }
 572
 573 use vars qw($curdir);
 574 no strict qw(vars);
 575 #6...........
 576         },
 577
 578         'git93.git93' => {
 579             source => "git93",
 580             params => "git93",
 581             expect => <<'#7...........',
 582 use Cwd qw[cwd];
 583 use Carp qw(carp);
 584 use IPC::Cmd qw{can_run run QUOTE};
 585 use File::Path qw/mkpath/;
 586 use File::Temp qw[tempdir];
 587 use Params::Check qw<check>;
 588 use Module::Load::Conditional qw#can_load#;
 589 use Locale::Maketext::Simple Style => 'gettext';    # does not align
 590
 591 # do not align on these 'q' token types - not use statements...
 592 my $gene_color_sets = [
 593     [ qw( blue blue blue blue )     => 'blue' ],
 594     [ qw( brown blue blue blue )    => 'brown' ],
 595     [ qw( brown brown green green ) => 'brown' ],
 596 ];
 597
 598 sub quux : PluginKeyword       { 'quux' }
 599 sub qaax : PluginKeyword(qiix) { die "unimplemented" }
 600
 601 use vars qw($curdir);
 602 no strict qw(vars);
 603 #7...........
 604         },
 605
 606         'c139.def' => {
 607             source => "c139",
 608             params => "def",
 609             expect => <<'#8...........',
 610 # The '&' has trailing spaces
 611 @l = &_( -49, -71 );
 612
 613 # This '$' has trailing spaces
 614 my $b = 40;
 615
 616 # this arrow has trailing spaces
 617 $r = $c->sql_set_env_attr( $evh, $SQL_ATTR_ODBC_VERSION, $SQL_OV_ODBC2, 0 );
 618
 619 # spaces and blank line
 620 @l = &
 621
 622   _( -49, -71 );
 623
 624 # spaces and blank line
 625 $r = $c->
 626
 627   sql_set_env_attr( $evh, $SQL_ATTR_ODBC_VERSION, $SQL_OV_ODBC2, 0 );
 628 #8...........
 629         },
 630
 631         'drc.def' => {
 632             source => "drc",
 633             params => "def",
 634             expect => <<'#9...........',
 635 ignoreSpec( $file, "file",, \%spec,,, \%Rspec );
 636 #9...........
 637         },
 638
 639         'drc.drc' => {
 640             source => "drc",
 641             params => "drc",
 642             expect => <<'#10...........',
 643 ignoreSpec( $file, "file", \%spec, \%Rspec );
 644 #10...........
 645         },
 646
 647         'git105.def' => {
 648             source => "git105",
 649             params => "def",
 650             expect => <<'#11...........',
 651 use v5.36;
 652
 653 use experimental 'for_list';
 654
 655 for my ( $k, $v ) ( 1, 2, 3, 4 ) {
 656     say "$k:$v";
 657 }
 658 say 'end';
 659
 660 #11...........
 661         },
 662
 663         'git106.def' => {
 664             source => "git106",
 665             params => "def",
 666             expect => <<'#12...........',
 667 is( $module->VERSION, $expected,
 668     "$main_module->VERSION matches $module->VERSION ($expected)" );
 669
 670 ok( ( $@ eq "" && "@b" eq "1 4 5 9" ),
 671     'redefinition should not take effect during the sort' );
 672
 673 &$f(
 674     ( map { $points->slice($_) } @sls1 ),
 675     ( map { $n->slice($_) } @sls1 ),
 676     ( map { $this->{Colors}->slice($_) } @sls1 )
 677 );
 678
 679 AA(
 680     "0123456789012345678901234567890123456789",
 681     "0123456789012345678901234567890123456789"
 682 );
 683
 684 AAAAAA(
 685     "0123456789012345678901234567890123456789",
 686     "0123456789012345678901234567890123456789"
 687 );
 688
 689 # padded
 690 return !( $elem->isa('PPI::Statement::End')
 691     || $elem->isa('PPI::Statement::Data') );
 692
 693 for (
 694     $s = $dbobj->seq( $k, $v, R_LAST ) ;
 695     $s == 0 ;
 696     $s = $dbobj->seq( $k, $v, R_PREV )
 697   )
 698 {
 699     print "$k: $v\n";
 700 }
 701
 702 # excess without -xci
 703 fresh_perl_is( '-C-',
 704     <<'abcdefghijklmnopq', {}, "ambiguous unary operator check doesn't crash" );
 705 Warning: Use of "-C-" without parentheses is ambiguous at - line 1.
 706 abcdefghijklmnopq
 707
 708 # excess with -xci
 709 {
 710     {
 711         {
 712             $self->privmsg( $to,
 713                 "One moment please, I shall display the groups with agendas:" );
 714         }
 715     }
 716 }
 717 #12...........
 718         },
 719
 720         'git106.git106' => {
 721             source => "git106",
 722             params => "git106",
 723             expect => <<'#13...........',
 724 is($module->VERSION, $expected,
 725    "$main_module->VERSION matches $module->VERSION ($expected)");
 726
 727 ok(($@ eq "" && "@b" eq "1 4 5 9"),
 728    'redefinition should not take effect during the sort');
 729
 730 &$f((map { $points->slice($_) } @sls1),
 731     (map { $n->slice($_) } @sls1),
 732     (map { $this->{Colors}->slice($_) } @sls1));
 733
 734 AA("0123456789012345678901234567890123456789",
 735    "0123456789012345678901234567890123456789");
 736
 737 AAAAAA("0123456789012345678901234567890123456789",
 738        "0123456789012345678901234567890123456789");
 739
 740 # padded
 741 return !(   $elem->isa('PPI::Statement::End')
 742          || $elem->isa('PPI::Statement::Data'));
 743
 744 for ($s = $dbobj->seq($k, $v, R_LAST) ;
 745      $s == 0 ;
 746      $s = $dbobj->seq($k, $v, R_PREV))
 747 {
 748     print "$k: $v\n";
 749 }
 750
 751 # excess without -xci
 752 fresh_perl_is('-C-',
 753      <<'abcdefghijklmnopq', {}, "ambiguous unary operator check doesn't crash");
 754 Warning: Use of "-C-" without parentheses is ambiguous at - line 1.
 755 abcdefghijklmnopq
 756
 757 # excess with -xci
 758 {
 759     {
 760         {
 761             $self->privmsg($to,
 762                    "One moment please, I shall display the groups with agendas:"
 763             );
 764         }
 765     }
 766 }
 767 #13...........
 768         },
 769
 770         'c154.def' => {
 771             source => "c154",
 772             params => "def",
 773             expect => <<'#14...........',
 774 {
 775     {
 776         {
 777             {
 778                 for (
 779                     $order =
 780                       $start_order * $nbSubOrderByOrder + $start_suborder ;
 781                     !exists $level_hash{$level}->{$order}
 782                       and $order <=
 783                       $stop_order * $nbSubOrderByOrder + $stop_suborder ;
 784                     $order++
 785                   )
 786                 {
 787                 }
 788
 789                 # has comma
 790                 for (
 791                     $q = 201 ;
 792                     print '-' x 79, "\n" ;
 793                     $g = (
 794                           $f ^ ( $w = ( $z = $m . $e ) ^ substr $e, $q )
 795                           ^ ( $n = $b ^ $d | $a ^ $l )
 796                     ) & ( $w | $z ^ $f ^ $n ) & ( $l | $g )
 797                   )
 798                 {
 799                     ...;
 800                 }
 801
 802                 for (
 803                     $j = 0, $match_j = -1 ;
 804                     $j < $sub_len
 805                       &&
 806
 807                       # changed from naive_string_matcher
 808                       $sub->[$j] eq $big->[ $i + $j ] ;
 809                     $j++
 810                   )
 811                 {
 812                     ...;
 813                 }
 814             }
 815         }
 816     }
 817 }
 818 #14...........
 819         },
 820
 821         'code_skipping.code_skipping' => {
 822             source => "code_skipping",
 823             params => "code_skipping",
 824             expect => <<'#15...........',
 825 %Hdr        = %U2E    = %E2U      = %Fallback = ();
 826 $in_charmap = $nerror = $nwarning = 0;
 827 $.          = 0;
 828 #<<V  code skipping: perltidy will pass this verbatim without error checking
 829
 830     }}} {{{
 831
 832 #>>V
 833 my $self    = shift;
 834 my $cloning = shift;
 835 #15...........
 836         },
 837
 838         'c158.def' => {
 839             source => "c158",
 840             params => "def",
 841             expect => <<'#16...........',
 842 my $meta = try { $package->meta }
 843   or die "$package does not have a ->meta method\n";
 844
 845 my ($curr) = current();
 846 err(@_);
 847 #16...........
 848         },
 849
 850         'git108.def' => {
 851             source => "git108",
 852             params => "def",
 853             expect => <<'#17...........',
 854 elf->call_method(
 855     method_name_foo => {
 856         some_arg1       => $foo,
 857         some_other_arg3 => $bar->{'baz'},
 858     }
 859 );
 860
 861 # leading dash
 862 my $species = new Bio::Species(
 863     -classification => [
 864         qw(
 865           sapiens Homo Hominidae
 866           Catarrhini Primates Eutheria
 867           Mammalia Vertebrata
 868           Chordata Metazoa Eukaryota
 869         )
 870     ]
 871 );
 872 #17...........
 873         },
 874
 875         'git108.git108' => {
 876             source => "git108",
 877             params => "git108",
 878             expect => <<'#18...........',
 879 elf->call_method( method_name_foo => {
 880     some_arg1       => $foo,
 881     some_other_arg3 => $bar->{'baz'},
 882 } );
 883
 884 # leading dash
 885 my $species = new Bio::Species( -classification => [ qw(
 886     sapiens Homo Hominidae
 887     Catarrhini Primates Eutheria
 888     Mammalia Vertebrata
 889     Chordata Metazoa Eukaryota
 890 ) ] );
 891 #18...........
 892         },
 893
 894         'wtc.def' => {
 895             source => "wtc",
 896             params => "def",
 897             expect => <<'#19...........',
 898 # both single and multiple line lists:
 899 @LoL = (
 900     [ "fred",   "barney", ],
 901     [ "george", "jane",  "elroy" ],
 902     [ "homer",  "marge", "bart", ],
 903 );
 904
 905 # single line
 906 ( $name, $body ) = ( $2, $3, );
 907
 908 # multiline, but not bare
 909 $text = $main->Scrolled( TextUndo, $yyy, $zzz, $wwwww,
 910     selectbackgroundxxxxx => 'yellow', );
 911
 912 # this will pass for 'h'
 913 my $new = {
 914     %$item,
 915     text  => $leaf,
 916     color => 'green',
 917 };
 918
 919 # matches 'i'
 920 my @list = (
 921
 922     $xx,
 923     $yy
 924 );
 925
 926 # does not match 'h'
 927 $c1->create(
 928     'rectangle', 40, 60, 80, 80,
 929     -fill => 'red',
 930     -tags => 'rectangle'
 931 );
 932
 933 $dasm_frame->Button(
 934     -text    => 'Locate',
 935     -command => sub {
 936         $target_binary = $fs->Show( -popover => 'cursor', -create => 1, );
 937     },
 938 )->pack( -side => 'left', );
 939
 940 my $no_index_1_1 =
 941   { 'map' =>
 942       { ':key' => { name => \&string, list => { value => \&string }, }, }, };
 943
 944 #19...........
 945         },
 946     };
 947
 948     my $ntests = 0 + keys %{$rtests};
 949     plan tests => $ntests;
 950 }
 951
 952 ###############
 953 # EXECUTE TESTS
 954 ###############
 955
 956 foreach my $key ( sort keys %{$rtests} ) {
 957     my $output;
 958     my $sname  = $rtests->{$key}->{source};
 959     my $expect = $rtests->{$key}->{expect};
 960     my $pname  = $rtests->{$key}->{params};
 961     my $source = $rsources->{$sname};
 962     my $params = defined($pname) ? $rparams->{$pname} : "";
 963     my $stderr_string;
 964     my $errorfile_string;
 965     my $err = Perl::Tidy::perltidy(
 966         source      => \$source,
 967         destination => \$output,
 968         perltidyrc  => \$params,
 969         argv        => '',             # for safety; hide any ARGV from perltidy
 970         stderr      => \$stderr_string,
 971         errorfile   => \$errorfile_string,    # not used when -se flag is set
 972     );
 973     if ( $err || $stderr_string || $errorfile_string ) {
 974         print STDERR "Error output received for test '$key'\n";
 975         if ($err) {
 976             print STDERR "An error flag '$err' was returned\n";
 977             ok( !$err );
 978         }
 979         if ($stderr_string) {
 980             print STDERR "---------------------\n";
 981             print STDERR "<<STDERR>>\n$stderr_string\n";
 982             print STDERR "---------------------\n";
 983             ok( !$stderr_string );
 984         }
 985         if ($errorfile_string) {
 986             print STDERR "---------------------\n";
 987             print STDERR "<<.ERR file>>\n$errorfile_string\n";
 988             print STDERR "---------------------\n";
 989             ok( !$errorfile_string );
 990         }
 991     }
 992     else {
 993         if ( !is( $output, $expect, $key ) ) {
 994             my $leno = length($output);
 995             my $lene = length($expect);
 996             if ( $leno == $lene ) {
 997                 print STDERR
 998 "#> Test '$key' gave unexpected output.  Strings differ but both have length $leno\n";
 999             }
1000             else {
1001                 print STDERR
1002 "#> Test '$key' gave unexpected output.  String lengths differ: output=$leno, expected=$lene\n";
1003             }
1004         }
1005     }
1006 }