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::More;
  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             # OLD: do not weld to a one-line block because the function could
 170             # get separated from its opening paren.
 171             # NEW: (30-jan-2021): keep one-line block together for stability
 172             $_[0]->code_handler
 173                  ( sub { $morexxxxxxxxxxxxxxxxxx .= $_[1] . ":" . $_[0] . "\n" } );
 174
 175             # another example; do not weld because the sub is not broken
 176             $wrapped->add_around_modifier(
 177                 sub { push @tracelog => 'around 1'; $_[0]->(); } );
 178
 179             # but okay to weld here because the sub is broken
 180             $wrapped->add_around_modifier( sub {
 181                         push @tracelog => 'around 1'; $_[0]->(); } );
 182 ----------
 183     };
 184
 185     ####################################
 186     # BEGIN SECTION 3: Expected output #
 187     ####################################
 188     $rtests = {
 189
 190         'vtc1.def' => {
 191             source => "vtc1",
 192             params => "def",
 193             expect => <<'#1...........',
 194 @lol = (
 195     [
 196         'Dr. Watson', undef,    '221b', 'Baker St.',
 197         undef,        'London', 'NW1',  undef,
 198         'England',    undef
 199     ],
 200     [
 201         'Sam Gamgee', undef,      undef, 'Bagshot Row',
 202         undef,        'Hobbiton', undef, undef,
 203         'The Shire',  undef
 204     ],
 205 );
 206 #1...........
 207         },
 208
 209         'vtc1.vtc' => {
 210             source => "vtc1",
 211             params => "vtc",
 212             expect => <<'#2...........',
 213 @lol = (
 214     [
 215         'Dr. Watson', undef,    '221b', 'Baker St.',
 216         undef,        'London', 'NW1',  undef,
 217         'England',    undef ],
 218     [
 219         'Sam Gamgee', undef,      undef, 'Bagshot Row',
 220         undef,        'Hobbiton', undef, undef,
 221         'The Shire',  undef ], );
 222 #2...........
 223         },
 224
 225         'vtc2.def' => {
 226             source => "vtc2",
 227             params => "def",
 228             expect => <<'#3...........',
 229     ok(
 230         $s->call(
 231             SOAP::Data->name('getStateName')
 232               ->attr( { xmlns => 'urn:/My/Examples' } ),
 233             1
 234         )->result eq 'Alabama'
 235     );
 236 #3...........
 237         },
 238
 239         'vtc2.vtc' => {
 240             source => "vtc2",
 241             params => "vtc",
 242             expect => <<'#4...........',
 243     ok(
 244         $s->call(
 245             SOAP::Data->name('getStateName')
 246               ->attr( { xmlns => 'urn:/My/Examples' } ),
 247             1 )->result eq 'Alabama' );
 248 #4...........
 249         },
 250
 251         'vtc3.def' => {
 252             source => "vtc3",
 253             params => "def",
 254             expect => <<'#5...........',
 255     $day_long = (
 256         "Sunday",   "Monday", "Tuesday",  "Wednesday",
 257         "Thursday", "Friday", "Saturday", "Sunday"
 258     )[$wday];
 259 #5...........
 260         },
 261
 262         'vtc3.vtc' => {
 263             source => "vtc3",
 264             params => "vtc",
 265             expect => <<'#6...........',
 266     $day_long = (
 267         "Sunday",   "Monday", "Tuesday",  "Wednesday",
 268         "Thursday", "Friday", "Saturday", "Sunday" )[$wday];
 269 #6...........
 270         },
 271
 272         'vtc4.def' => {
 273             source => "vtc4",
 274             params => "def",
 275             expect => <<'#7...........',
 276 my $bg_color = $im->colorAllocate(
 277     unpack(
 278         'C3',
 279         pack(
 280             'H2H2H2',
 281             unpack(
 282                 'a2a2a2',
 283                 (
 284                     length( $options_r->{'bg_color'} )
 285                     ? $options_r->{'bg_color'}
 286                     : $MIDI::Opus::BG_color
 287                 )
 288             )
 289         )
 290     )
 291 );
 292 #7...........
 293         },
 294
 295         'vtc4.vtc' => {
 296             source => "vtc4",
 297             params => "vtc",
 298             expect => <<'#8...........',
 299 my $bg_color = $im->colorAllocate(
 300     unpack(
 301         'C3',
 302         pack(
 303             'H2H2H2',
 304             unpack(
 305                 'a2a2a2',
 306                 (
 307                     length( $options_r->{'bg_color'} )
 308                     ? $options_r->{'bg_color'}
 309                     : $MIDI::Opus::BG_color ) ) ) ) );
 310 #8...........
 311         },
 312
 313         'wn1.def' => {
 314             source => "wn1",
 315             params => "def",
 316             expect => <<'#9...........',
 317     my $bg_color = $im->colorAllocate(
 318         unpack(
 319             'C3',
 320             pack(
 321                 'H2H2H2',
 322                 unpack(
 323                     'a2a2a2',
 324                     (
 325                         length( $options_r->{'bg_color'} )
 326                         ? $options_r->{'bg_color'}
 327                         : $MIDI::Opus::BG_color
 328                     )
 329                 )
 330             )
 331         )
 332     );
 333 #9...........
 334         },
 335
 336         'wn1.wn' => {
 337             source => "wn1",
 338             params => "wn",
 339             expect => <<'#10...........',
 340     my $bg_color = $im->colorAllocate( unpack(
 341         'C3',
 342         pack(
 343             'H2H2H2',
 344             unpack(
 345                 'a2a2a2',
 346                 (
 347                     length( $options_r->{'bg_color'} )
 348                     ? $options_r->{'bg_color'}
 349                     : $MIDI::Opus::BG_color
 350                 )
 351             )
 352         )
 353     ) );
 354 #10...........
 355         },
 356
 357         'wn2.def' => {
 358             source => "wn2",
 359             params => "def",
 360             expect => <<'#11...........',
 361 if ( $PLATFORM eq 'aix' ) {
 362     skip_symbols(
 363         [
 364             qw(
 365               Perl_dump_fds
 366               Perl_ErrorNo
 367               Perl_GetVars
 368               PL_sys_intern
 369             )
 370         ]
 371     );
 372 }
 373 #11...........
 374         },
 375
 376         'wn2.wn' => {
 377             source => "wn2",
 378             params => "wn",
 379             expect => <<'#12...........',
 380 if ( $PLATFORM eq 'aix' ) {
 381     skip_symbols( [ qw(
 382         Perl_dump_fds
 383         Perl_ErrorNo
 384         Perl_GetVars
 385         PL_sys_intern
 386     ) ] );
 387 }
 388 #12...........
 389         },
 390
 391         'wn3.def' => {
 392             source => "wn3",
 393             params => "def",
 394             expect => <<'#13...........',
 395 deferred->resolve->then(
 396     sub {
 397         push @out, 'Resolve';
 398         return $then;
 399     }
 400 )->then(
 401     sub {
 402         push @out, 'Reject';
 403         push @out, @_;
 404     }
 405 );
 406 #13...........
 407         },
 408
 409         'wn3.wn' => {
 410             source => "wn3",
 411             params => "wn",
 412             expect => <<'#14...........',
 413 deferred->resolve->then( sub {
 414     push @out, 'Resolve';
 415     return $then;
 416 } )->then( sub {
 417     push @out, 'Reject';
 418     push @out, @_;
 419 } );
 420 #14...........
 421         },
 422
 423         'wn4.def' => {
 424             source => "wn4",
 425             params => "def",
 426             expect => <<'#15...........',
 427 {
 428     {
 429         {
 430             # Orignal formatting looks nice but would be hard to duplicate
 431             return
 432                  exists $G->{Attr}->{E}
 433               && exists $G->{Attr}->{E}->{$u}
 434               && exists $G->{Attr}->{E}->{$u}->{$v}
 435               ? %{ $G->{Attr}->{E}->{$u}->{$v} }
 436               : ();
 437         }
 438     }
 439 }
 440 #15...........
 441         },
 442
 443         'wn4.wn' => {
 444             source => "wn4",
 445             params => "wn",
 446             expect => <<'#16...........',
 447 { { {
 448
 449     # Orignal formatting looks nice but would be hard to duplicate
 450     return
 451          exists $G->{Attr}->{E}
 452       && exists $G->{Attr}->{E}->{$u} && exists $G->{Attr}->{E}->{$u}->{$v}
 453       ? %{ $G->{Attr}->{E}->{$u}->{$v} }
 454       : ();
 455 } } }
 456 #16...........
 457         },
 458
 459         'wn5.def' => {
 460             source => "wn5",
 461             params => "def",
 462             expect => <<'#17...........',
 463 # qw weld with -wn
 464 use_all_ok(
 465     qw{
 466       PPI
 467       PPI::Tokenizer
 468       PPI::Lexer
 469       PPI::Dumper
 470       PPI::Find
 471       PPI::Normal
 472       PPI::Util
 473       PPI::Cache
 474     }
 475 );
 476 #17...........
 477         },
 478
 479         'wn5.wn' => {
 480             source => "wn5",
 481             params => "wn",
 482             expect => <<'#18...........',
 483 # qw weld with -wn
 484 use_all_ok( qw{
 485     PPI
 486     PPI::Tokenizer
 487     PPI::Lexer
 488     PPI::Dumper
 489     PPI::Find
 490     PPI::Normal
 491     PPI::Util
 492     PPI::Cache
 493 } );
 494 #18...........
 495         },
 496
 497         'wn6.def' => {
 498             source => "wn6",
 499             params => "def",
 500             expect => <<'#19...........',
 501             # illustration of some do-not-weld rules
 502
 503             # do not weld a two-line function call
 504             $trans->add_transformation(
 505                 PDL::Graphics::TriD::Scale->new( $sx, $sy, $sz ) );
 506
 507             # but weld this more complex statement
 508             my $compass = uc(
 509                 opposite_direction(
 510                     line_to_canvas_direction(
 511                         @{ $coords[0] }, @{ $coords[1] }
 512                     )
 513                 )
 514             );
 515
 516             # OLD: do not weld to a one-line block because the function could
 517             # get separated from its opening paren.
 518             # NEW: (30-jan-2021): keep one-line block together for stability
 519             $_[0]->code_handler(
 520                 sub { $morexxxxxxxxxxxxxxxxxx .= $_[1] . ":" . $_[0] . "\n" } );
 521
 522             # another example; do not weld because the sub is not broken
 523             $wrapped->add_around_modifier(
 524                 sub { push @tracelog => 'around 1'; $_[0]->(); } );
 525
 526             # but okay to weld here because the sub is broken
 527             $wrapped->add_around_modifier(
 528                 sub {
 529                     push @tracelog => 'around 1';
 530                     $_[0]->();
 531                 }
 532             );
 533 #19...........
 534         },
 535
 536         'wn6.wn' => {
 537             source => "wn6",
 538             params => "wn",
 539             expect => <<'#20...........',
 540             # illustration of some do-not-weld rules
 541
 542             # do not weld a two-line function call
 543             $trans->add_transformation(
 544                 PDL::Graphics::TriD::Scale->new( $sx, $sy, $sz ) );
 545
 546             # but weld this more complex statement
 547             my $compass = uc( opposite_direction( line_to_canvas_direction(
 548                 @{ $coords[0] }, @{ $coords[1] }
 549             ) ) );
 550
 551             # OLD: do not weld to a one-line block because the function could
 552             # get separated from its opening paren.
 553             # NEW: (30-jan-2021): keep one-line block together for stability
 554             $_[0]->code_handler(
 555                 sub { $morexxxxxxxxxxxxxxxxxx .= $_[1] . ":" . $_[0] . "\n" } );
 556
 557             # another example; do not weld because the sub is not broken
 558             $wrapped->add_around_modifier(
 559                 sub { push @tracelog => 'around 1'; $_[0]->(); } );
 560
 561             # but okay to weld here because the sub is broken
 562             $wrapped->add_around_modifier( sub {
 563                 push @tracelog => 'around 1';
 564                 $_[0]->();
 565             } );
 566 #20...........
 567         },
 568     };
 569
 570     my $ntests = 0 + keys %{$rtests};
 571     plan tests => $ntests;
 572 }
 573
 574 ###############
 575 # EXECUTE TESTS
 576 ###############
 577
 578 foreach my $key ( sort keys %{$rtests} ) {
 579     my $output;
 580     my $sname  = $rtests->{$key}->{source};
 581     my $expect = $rtests->{$key}->{expect};
 582     my $pname  = $rtests->{$key}->{params};
 583     my $source = $rsources->{$sname};
 584     my $params = defined($pname) ? $rparams->{$pname} : "";
 585     my $stderr_string;
 586     my $errorfile_string;
 587     my $err = Perl::Tidy::perltidy(
 588         source      => \$source,
 589         destination => \$output,
 590         perltidyrc  => \$params,
 591         argv        => '',             # for safety; hide any ARGV from perltidy
 592         stderr      => \$stderr_string,
 593         errorfile   => \$errorfile_string,    # not used when -se flag is set
 594     );
 595     if ( $err || $stderr_string || $errorfile_string ) {
 596         print STDERR "Error output received for test '$key'\n";
 597         if ($err) {
 598             print STDERR "An error flag '$err' was returned\n";
 599             ok( !$err );
 600         }
 601         if ($stderr_string) {
 602             print STDERR "---------------------\n";
 603             print STDERR "<<STDERR>>\n$stderr_string\n";
 604             print STDERR "---------------------\n";
 605             ok( !$stderr_string );
 606         }
 607         if ($errorfile_string) {
 608             print STDERR "---------------------\n";
 609             print STDERR "<<.ERR file>>\n$errorfile_string\n";
 610             print STDERR "---------------------\n";
 611             ok( !$errorfile_string );
 612         }
 613     }
 614     else {
 615         if ( !is( $output, $expect, $key ) ) {
 616             my $leno = length($output);
 617             my $lene = length($expect);
 618             if ( $leno == $lene ) {
 619                 print STDERR
 620 "#> Test '$key' gave unexpected output.  Strings differ but both have length $leno\n";
 621             }
 622             else {
 623                 print STDERR
 624 "#> Test '$key' gave unexpected output.  String lengths differ: output=$leno, expected=$lene\n";
 625             }
 626         }
 627     }
 628 }