t/snippets12.t

   1 # Created with: ./make_t.pl
   2
   3 # Contents:
   4 #1 vtc1.def
   5 #2 vtc1.vtc
   6 #3 vtc2.def
   7 #4 vtc2.vtc
   8 #5 vtc3.def
   9 #6 vtc3.vtc
  10 #7 vtc4.def
  11 #8 vtc4.vtc
  12 #9 wn1.def
  13 #10 wn1.wn
  14 #11 wn2.def
  15 #12 wn2.wn
  16 #13 wn3.def
  17 #14 wn3.wn
  18 #15 wn4.def
  19 #16 wn4.wn
  20 #17 wn5.def
  21 #18 wn5.wn
  22 #19 wn6.def
  23 #20 wn6.wn
  24
  25 # To locate test #13 you can search for its name or the string '#13'
  26
  27 use strict;
  28 use Test;
  29 use Carp;
  30 use Perl::Tidy;
  31 my $rparams;
  32 my $rsources;
  33 my $rtests;
  34
  35 BEGIN {
  36
  37     ###########################################
  38     # BEGIN SECTION 1: Parameter combinations #
  39     ###########################################
  40     $rparams = {
  41         'def' => "",
  42         'vtc' => <<'----------',
  43 -sbvtc=2
  44 -bvtc=2
  45 -pvtc=2
  46 ----------
  47         'wn' => "-wn",
  48     };
  49
  50     ############################
  51     # BEGIN SECTION 2: Sources #
  52     ############################
  53     $rsources = {
  54
  55         'vtc1' => <<'----------',
  56 @lol = (
  57         [   'Dr. Watson', undef,    '221b', 'Baker St.',
  58             undef,        'London', 'NW1',  undef,
  59             'England',    undef
  60         ],
  61         [   'Sam Gamgee', undef,      undef, 'Bagshot Row',
  62             undef,        'Hobbiton', undef, undef,
  63             'The Shire',  undef],
  64         );
  65 ----------
  66
  67         'vtc2' => <<'----------',
  68     ok(
  69         $s->call(
  70             SOAP::Data->name('getStateName')
  71               ->attr( { xmlns => 'urn:/My/Examples' } ),
  72             1
  73         )->result eq 'Alabama'
  74     );
  75 ----------
  76
  77         'vtc3' => <<'----------',
  78     $day_long = (
  79         "Sunday",   "Monday", "Tuesday",  "Wednesday",
  80         "Thursday", "Friday", "Saturday", "Sunday"
  81     )[$wday];
  82 ----------
  83
  84         'vtc4' => <<'----------',
  85 my$bg_color=$im->colorAllocate(unpack('C3',pack('H2H2H2',unpack('a2a2a2',(length($options_r->{'bg_color'})?$options_r->{'bg_color'}:$MIDI::Opus::BG_color)))));
  86 ----------
  87
  88         'wn1' => <<'----------',
  89     my $bg_color = $im->colorAllocate(
  90         unpack(
  91             'C3',
  92             pack(
  93                 'H2H2H2',
  94                 unpack(
  95                     'a2a2a2',
  96                     (
  97                         length( $options_r->{'bg_color'} )
  98                         ? $options_r->{'bg_color'}
  99                         : $MIDI::Opus::BG_color
 100                     )
 101                 )
 102             )
 103         )
 104     );
 105 ----------
 106
 107         'wn2' => <<'----------',
 108 if ($PLATFORM eq 'aix') {
 109     skip_symbols([qw(
 110               Perl_dump_fds
 111               Perl_ErrorNo
 112               Perl_GetVars
 113               PL_sys_intern
 114     )]);
 115 }
 116 ----------
 117
 118         'wn3' => <<'----------',
 119 deferred->resolve->then(
 120     sub {
 121         push @out, 'Resolve';
 122         return $then;
 123     }
 124 )->then(
 125     sub {
 126         push @out, 'Reject';
 127         push @out, @_;
 128     }
 129 );
 130 ----------
 131
 132         'wn4' => <<'----------',
 133 {{{
 134             # Orignal formatting looks nice but would be hard to duplicate
 135             return exists $G->{ Attr }->{ E } &&
 136                    exists $G->{ Attr }->{ E }->{ $u } &&
 137                    exists $G->{ Attr }->{ E }->{ $u }->{ $v } ?
 138                               %{ $G->{ Attr }->{ E }->{ $u }->{ $v } } :
 139                               ( );
 140 }}}
 141 ----------
 142
 143         'wn5' => <<'----------',
 144 # qw weld with -wn
 145 use_all_ok(
 146  qw{
 147    PPI
 148    PPI::Tokenizer
 149    PPI::Lexer
 150    PPI::Dumper
 151    PPI::Find
 152    PPI::Normal
 153    PPI::Util
 154    PPI::Cache
 155    }
 156 );
 157 ----------
 158
 159         'wn6' => <<'----------',
 160             # illustration of some do-not-weld rules
 161
 162             # do not weld a two-line function call
 163             $trans->add_transformation( PDL::Graphics::TriD::Scale->new( $sx, $sy, $sz ) );
 164
 165             # but weld this more complex statement
 166             my $compass = uc( opposite_direction( line_to_canvas_direction(
 167                 @{ $coords[0] }, @{ $coords[1] } ) ) );
 168
 169             # do not weld to a one-line block because the function could get separated
 170             # from its opening paren
 171             $_[0]->code_handler
 172                  ( sub { $morexxxxxxxxxxxxxxxxxx .= $_[1] . ":" . $_[0] . "\n" } );
 173
 174             # another example; do not weld because the sub is not broken
 175             $wrapped->add_around_modifier(
 176                 sub { push @tracelog => 'around 1'; $_[0]->(); } );
 177
 178             # but okay to weld here because the sub is broken
 179             $wrapped->add_around_modifier( sub {
 180                         push @tracelog => 'around 1'; $_[0]->(); } );
 181 ----------
 182     };
 183
 184     ####################################
 185     # BEGIN SECTION 3: Expected output #
 186     ####################################
 187     $rtests = {
 188
 189         'vtc1.def' => {
 190             source => "vtc1",
 191             params => "def",
 192             expect => <<'#1...........',
 193 @lol = (
 194     [
 195         'Dr. Watson', undef,    '221b', 'Baker St.',
 196         undef,        'London', 'NW1',  undef,
 197         'England',    undef
 198     ],
 199     [
 200         'Sam Gamgee', undef,      undef, 'Bagshot Row',
 201         undef,        'Hobbiton', undef, undef,
 202         'The Shire',  undef
 203     ],
 204 );
 205 #1...........
 206         },
 207
 208         'vtc1.vtc' => {
 209             source => "vtc1",
 210             params => "vtc",
 211             expect => <<'#2...........',
 212 @lol = (
 213     [
 214         'Dr. Watson', undef,    '221b', 'Baker St.',
 215         undef,        'London', 'NW1',  undef,
 216         'England',    undef ],
 217     [
 218         'Sam Gamgee', undef,      undef, 'Bagshot Row',
 219         undef,        'Hobbiton', undef, undef,
 220         'The Shire',  undef ], );
 221 #2...........
 222         },
 223
 224         'vtc2.def' => {
 225             source => "vtc2",
 226             params => "def",
 227             expect => <<'#3...........',
 228     ok(
 229         $s->call(
 230             SOAP::Data->name('getStateName')
 231               ->attr( { xmlns => 'urn:/My/Examples' } ),
 232             1
 233         )->result eq 'Alabama'
 234     );
 235 #3...........
 236         },
 237
 238         'vtc2.vtc' => {
 239             source => "vtc2",
 240             params => "vtc",
 241             expect => <<'#4...........',
 242     ok(
 243         $s->call(
 244             SOAP::Data->name('getStateName')
 245               ->attr( { xmlns => 'urn:/My/Examples' } ),
 246             1 )->result eq 'Alabama' );
 247 #4...........
 248         },
 249
 250         'vtc3.def' => {
 251             source => "vtc3",
 252             params => "def",
 253             expect => <<'#5...........',
 254     $day_long = (
 255         "Sunday",   "Monday", "Tuesday",  "Wednesday",
 256         "Thursday", "Friday", "Saturday", "Sunday"
 257     )[$wday];
 258 #5...........
 259         },
 260
 261         'vtc3.vtc' => {
 262             source => "vtc3",
 263             params => "vtc",
 264             expect => <<'#6...........',
 265     $day_long = (
 266         "Sunday",   "Monday", "Tuesday",  "Wednesday",
 267         "Thursday", "Friday", "Saturday", "Sunday" )[$wday];
 268 #6...........
 269         },
 270
 271         'vtc4.def' => {
 272             source => "vtc4",
 273             params => "def",
 274             expect => <<'#7...........',
 275 my $bg_color = $im->colorAllocate(
 276     unpack(
 277         'C3',
 278         pack(
 279             'H2H2H2',
 280             unpack(
 281                 'a2a2a2',
 282                 (
 283                     length( $options_r->{'bg_color'} )
 284                     ? $options_r->{'bg_color'}
 285                     : $MIDI::Opus::BG_color
 286                 )
 287             )
 288         )
 289     )
 290 );
 291 #7...........
 292         },
 293
 294         'vtc4.vtc' => {
 295             source => "vtc4",
 296             params => "vtc",
 297             expect => <<'#8...........',
 298 my $bg_color = $im->colorAllocate(
 299     unpack(
 300         'C3',
 301         pack(
 302             'H2H2H2',
 303             unpack(
 304                 'a2a2a2',
 305                 (
 306                     length( $options_r->{'bg_color'} )
 307                     ? $options_r->{'bg_color'}
 308                     : $MIDI::Opus::BG_color ) ) ) ) );
 309 #8...........
 310         },
 311
 312         'wn1.def' => {
 313             source => "wn1",
 314             params => "def",
 315             expect => <<'#9...........',
 316     my $bg_color = $im->colorAllocate(
 317         unpack(
 318             'C3',
 319             pack(
 320                 'H2H2H2',
 321                 unpack(
 322                     'a2a2a2',
 323                     (
 324                         length( $options_r->{'bg_color'} )
 325                         ? $options_r->{'bg_color'}
 326                         : $MIDI::Opus::BG_color
 327                     )
 328                 )
 329             )
 330         )
 331     );
 332 #9...........
 333         },
 334
 335         'wn1.wn' => {
 336             source => "wn1",
 337             params => "wn",
 338             expect => <<'#10...........',
 339     my $bg_color = $im->colorAllocate( unpack(
 340         'C3',
 341         pack(
 342             'H2H2H2',
 343             unpack(
 344                 'a2a2a2',
 345                 (
 346                     length( $options_r->{'bg_color'} )
 347                     ? $options_r->{'bg_color'}
 348                     : $MIDI::Opus::BG_color
 349                 )
 350             )
 351         )
 352     ) );
 353 #10...........
 354         },
 355
 356         'wn2.def' => {
 357             source => "wn2",
 358             params => "def",
 359             expect => <<'#11...........',
 360 if ( $PLATFORM eq 'aix' ) {
 361     skip_symbols(
 362         [
 363             qw(
 364               Perl_dump_fds
 365               Perl_ErrorNo
 366               Perl_GetVars
 367               PL_sys_intern
 368               )
 369         ]
 370     );
 371 }
 372 #11...........
 373         },
 374
 375         'wn2.wn' => {
 376             source => "wn2",
 377             params => "wn",
 378             expect => <<'#12...........',
 379 if ( $PLATFORM eq 'aix' ) {
 380     skip_symbols( [ qw(
 381           Perl_dump_fds
 382           Perl_ErrorNo
 383           Perl_GetVars
 384           PL_sys_intern
 385           ) ] );
 386 }
 387 #12...........
 388         },
 389
 390         'wn3.def' => {
 391             source => "wn3",
 392             params => "def",
 393             expect => <<'#13...........',
 394 deferred->resolve->then(
 395     sub {
 396         push @out, 'Resolve';
 397         return $then;
 398     }
 399 )->then(
 400     sub {
 401         push @out, 'Reject';
 402         push @out, @_;
 403     }
 404 );
 405 #13...........
 406         },
 407
 408         'wn3.wn' => {
 409             source => "wn3",
 410             params => "wn",
 411             expect => <<'#14...........',
 412 deferred->resolve->then( sub {
 413     push @out, 'Resolve';
 414     return $then;
 415 } )->then( sub {
 416     push @out, 'Reject';
 417     push @out, @_;
 418 } );
 419 #14...........
 420         },
 421
 422         'wn4.def' => {
 423             source => "wn4",
 424             params => "def",
 425             expect => <<'#15...........',
 426 {
 427     {
 428         {
 429             # Orignal formatting looks nice but would be hard to duplicate
 430             return
 431                  exists $G->{Attr}->{E}
 432               && exists $G->{Attr}->{E}->{$u}
 433               && exists $G->{Attr}->{E}->{$u}->{$v}
 434               ? %{ $G->{Attr}->{E}->{$u}->{$v} }
 435               : ();
 436         }
 437     }
 438 }
 439 #15...........
 440         },
 441
 442         'wn4.wn' => {
 443             source => "wn4",
 444             params => "wn",
 445             expect => <<'#16...........',
 446 { { {
 447
 448     # Orignal formatting looks nice but would be hard to duplicate
 449     return
 450          exists $G->{Attr}->{E}
 451       && exists $G->{Attr}->{E}->{$u} && exists $G->{Attr}->{E}->{$u}->{$v}
 452       ? %{ $G->{Attr}->{E}->{$u}->{$v} }
 453       : ();
 454 } } }
 455 #16...........
 456         },
 457
 458         'wn5.def' => {
 459             source => "wn5",
 460             params => "def",
 461             expect => <<'#17...........',
 462 # qw weld with -wn
 463 use_all_ok(
 464     qw{
 465       PPI
 466       PPI::Tokenizer
 467       PPI::Lexer
 468       PPI::Dumper
 469       PPI::Find
 470       PPI::Normal
 471       PPI::Util
 472       PPI::Cache
 473       }
 474 );
 475 #17...........
 476         },
 477
 478         'wn5.wn' => {
 479             source => "wn5",
 480             params => "wn",
 481             expect => <<'#18...........',
 482 # qw weld with -wn
 483 use_all_ok( qw{
 484       PPI
 485       PPI::Tokenizer
 486       PPI::Lexer
 487       PPI::Dumper
 488       PPI::Find
 489       PPI::Normal
 490       PPI::Util
 491       PPI::Cache
 492       } );
 493 #18...........
 494         },
 495
 496         'wn6.def' => {
 497             source => "wn6",
 498             params => "def",
 499             expect => <<'#19...........',
 500             # illustration of some do-not-weld rules
 501
 502             # do not weld a two-line function call
 503             $trans->add_transformation(
 504                 PDL::Graphics::TriD::Scale->new( $sx, $sy, $sz ) );
 505
 506             # but weld this more complex statement
 507             my $compass = uc(
 508                 opposite_direction(
 509                     line_to_canvas_direction(
 510                         @{ $coords[0] }, @{ $coords[1] }
 511                     )
 512                 )
 513             );
 514
 515       # do not weld to a one-line block because the function could get separated
 516       # from its opening paren
 517             $_[0]->code_handler(
 518                 sub { $morexxxxxxxxxxxxxxxxxx .= $_[1] . ":" . $_[0] . "\n" } );
 519
 520             # another example; do not weld because the sub is not broken
 521             $wrapped->add_around_modifier(
 522                 sub { push @tracelog => 'around 1'; $_[0]->(); } );
 523
 524             # but okay to weld here because the sub is broken
 525             $wrapped->add_around_modifier(
 526                 sub {
 527                     push @tracelog => 'around 1';
 528                     $_[0]->();
 529                 }
 530             );
 531 #19...........
 532         },
 533
 534         'wn6.wn' => {
 535             source => "wn6",
 536             params => "wn",
 537             expect => <<'#20...........',
 538             # illustration of some do-not-weld rules
 539
 540             # do not weld a two-line function call
 541             $trans->add_transformation(
 542                 PDL::Graphics::TriD::Scale->new( $sx, $sy, $sz ) );
 543
 544             # but weld this more complex statement
 545             my $compass = uc( opposite_direction( line_to_canvas_direction(
 546                 @{ $coords[0] }, @{ $coords[1] }
 547             ) ) );
 548
 549       # do not weld to a one-line block because the function could get separated
 550       # from its opening paren
 551             $_[0]->code_handler(
 552                 sub { $morexxxxxxxxxxxxxxxxxx .= $_[1] . ":" . $_[0] . "\n" } );
 553
 554             # another example; do not weld because the sub is not broken
 555             $wrapped->add_around_modifier(
 556                 sub { push @tracelog => 'around 1'; $_[0]->(); } );
 557
 558             # but okay to weld here because the sub is broken
 559             $wrapped->add_around_modifier( sub {
 560                 push @tracelog => 'around 1';
 561                 $_[0]->();
 562             } );
 563 #20...........
 564         },
 565     };
 566
 567     my $ntests = 0 + keys %{$rtests};
 568     plan tests => $ntests;
 569 }
 570
 571 ###############
 572 # EXECUTE TESTS
 573 ###############
 574
 575 foreach my $key ( sort keys %{$rtests} ) {
 576     my $output;
 577     my $sname  = $rtests->{$key}->{source};
 578     my $expect = $rtests->{$key}->{expect};
 579     my $pname  = $rtests->{$key}->{params};
 580     my $source = $rsources->{$sname};
 581     my $params = defined($pname) ? $rparams->{$pname} : "";
 582     my $stderr_string;
 583     my $errorfile_string;
 584     my $err = Perl::Tidy::perltidy(
 585         source      => \$source,
 586         destination => \$output,
 587         perltidyrc  => \$params,
 588         argv        => '',             # for safety; hide any ARGV from perltidy
 589         stderr      => \$stderr_string,
 590         errorfile => \$errorfile_string,    # not used when -se flag is set
 591     );
 592     if ( $err || $stderr_string || $errorfile_string ) {
 593         if ($err) {
 594             print STDERR
 595 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 596             ok( !$err );
 597         }
 598         if ($stderr_string) {
 599             print STDERR "---------------------\n";
 600             print STDERR "<<STDERR>>\n$stderr_string\n";
 601             print STDERR "---------------------\n";
 602             print STDERR
 603 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 604             ok( !$stderr_string );
 605         }
 606         if ($errorfile_string) {
 607             print STDERR "---------------------\n";
 608             print STDERR "<<.ERR file>>\n$errorfile_string\n";
 609             print STDERR "---------------------\n";
 610             print STDERR
 611 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 612             ok( !$errorfile_string );
 613         }
 614     }
 615     else {
 616         ok( $output, $expect );
 617     }
 618 }