t/snippets22.t

   1 # Created with: ./make_t.pl
   2
   3 # Contents:
   4 #1 here_long.here_long
   5 #2 bbhb.bbhb2
   6 #3 bbhb.bbhb3
   7 #4 bbhb.def
   8 #5 bbhb.bbhb4
   9 #6 bbhb.bbhb5
  10 #7 braces.braces7
  11 #8 xci.def
  12 #9 xci.xci1
  13 #10 xci.xci2
  14 #11 mangle4.def
  15 #12 mangle4.mangle
  16 #13 extrude5.def
  17 #14 extrude5.extrude
  18 #15 kba1.def
  19 #16 kba1.kba1
  20 #17 git45.def
  21 #18 git45.git45
  22 #19 boa.boa
  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         'bbhb2' => "-bbhb=2 -bbp=2",
  41         'bbhb3' => "-bbhb=3 -bbp=3",
  42         'bbhb4' => "-bbhb=3 -bbp=3 -bbhbi=2 -bbpi=2",
  43         'bbhb5' => "-bbhb=3 -bbp=3 -bbhbi=1 -bbpi=1",
  44         'boa'   => <<'----------',
  45 # -boa is default so we test nboa
  46 -nboa
  47 ----------
  48         'braces7' => <<'----------',
  49 -bli -blil='*'
  50 ----------
  51         'def'       => "",
  52         'extrude'   => "--extrude",
  53         'git45'     => "-vtc=1 -wn",
  54         'here_long' => "-l=33",
  55         'kba1'      => <<'----------',
  56 -kbb='=> ,' -kba='=>'
  57 ----------
  58         'mangle' => "--mangle",
  59         'xci1'   => "-xci",
  60         'xci2'   => "-pbp -nst -nse -xci",
  61     };
  62
  63     ############################
  64     # BEGIN SECTION 2: Sources #
  65     ############################
  66     $rsources = {
  67
  68         'bbhb' => <<'----------',
  69 my %temp =
  70 (
  71 supsup => 123,
  72 nested => {
  73 asdf => 456,
  74 yarg => 'yarp',
  75 }, );
  76 ----------
  77
  78         'boa' => <<'----------',
  79 my @field
  80   : field
  81   : Default(1)
  82   : Get('Name' => 'foo')
  83   : Set('Name');
  84 ----------
  85
  86         'braces' => <<'----------',
  87 sub message {
  88     if ( !defined( $_[0] ) ) {
  89         print("Hello, World\n");
  90     }
  91     else {
  92         print( $_[0], "\n" );
  93     }
  94 }
  95
  96 $myfun = sub {
  97     print("Hello, World\n");
  98 };
  99
 100 eval {
 101     my $app = App::perlbrew->new( "install-patchperl", "-q" );
 102     $app->run();
 103 } or do {
 104     $error          = $@;
 105     $produced_error = 1;
 106 };
 107
 108 Mojo::IOLoop->next_tick(
 109     sub {
 110         $ua->get(
 111             '/' => sub {
 112                 push @kept_alive, pop->kept_alive;
 113                 Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
 114             }
 115         );
 116     }
 117 );
 118
 119 $r = do {
 120     sswitch( $words[ rand @words ] ) {
 121         case $words[0]:
 122         case $words[1]:
 123         case $words[2]:
 124         case $words[3]: { 'ok' }
 125       default: { 'wtf' }
 126     }
 127 };
 128
 129 try {
 130     die;
 131 }
 132 catch {
 133     die;
 134 };
 135 ----------
 136
 137         'extrude5' => <<'----------',
 138 use perl6-alpha;
 139 $var{-y} = 1;
 140 ----------
 141
 142         'git45' => <<'----------',
 143 # git#45 -vtc=n and -wn were not working together
 144 if (
 145     $self->_add_fqdn_host(
 146         name  => $name,
 147         realm => $realm
 148     )
 149   )
 150 {
 151     ...;
 152 }
 153
 154 # do not stack )->pack(
 155 my $hlist = $control::control->Scrolled(
 156     'HList',
 157     drawbranch  => 1,
 158     width       => 20,
 159     -scrollbars => 'w'
 160 )->pack(
 161     -side   => 'bottom',
 162     -expand => 1
 163 );
 164
 165 ----------
 166
 167         'here_long' => <<'----------',
 168 # must not break after here target regardless of maximum-line-length
 169 $sth= $dbh->prepare (<<"END_OF_SELECT") or die "Couldn't prepare SQL" ;
 170     SELECT COUNT(duration),SUM(duration)
 171     FROM logins WHERE username='$user'
 172 END_OF_SELECT
 173
 174 ----------
 175
 176         'kba1' => <<'----------',
 177 $this_env = join("", $before, $closures
 178           , $contents
 179           , ($defenv ? '': &balance_tags())
 180           , $reopens ); $_ = $after;
 181
 182 method 'foo1'
 183   => [ Int, Int ]
 184   => sub {
 185     my ( $self, $x, $y ) = ( shift, @_ );
 186     ...;
 187   };
 188
 189 method 'foo2'=>
 190   [ Int, Int ]=>
 191   sub {
 192     my ( $self, $x, $y ) = ( shift, @_ );
 193     ...;
 194   };
 195
 196 ----------
 197
 198         'mangle4' => <<'----------',
 199 # a useful parsing test from 'signatures.t'
 200 use feature "signatures";
 201 no warnings "experimental::signatures";
 202 sub t086
 203     ( #foo)))
 204     $ #foo)))
 205     a #foo)))
 206     , #foo)))
 207     , #foo)))
 208     $ #foo)))
 209     b #foo)))
 210     = #foo)))
 211     333 #foo)))
 212     , #foo)))
 213     , #foo)))
 214     ) #foo)))
 215     { $a.$b }
 216 ----------
 217
 218         'xci' => <<'----------',
 219 $self->{_text} = (
 220   !$section  ? ''
 221  : $type eq 'item' ? "the $section entry"
 222  : "the section on $section"
 223  )
 224  . (
 225  $page
 226  ? ( $section ? ' in ' : '' ) . "the $page$page_ext manpage"
 227  : ' elsewhere in this document'
 228  );
 229
 230 my $otherHashRef =
 231  $condition
 232  ? {
 233  'a' => 'a value',
 234  'b' => 'b value',
 235  'c' => {
 236   'd' => 'd value',
 237   'e' => 'e value'
 238  }
 239  }
 240  : undef;
 241
 242 my @globlist = ( grep { defined } @opt{qw( l q S t )} )
 243   ? do {
 244     local *DIR;
 245     opendir DIR, './' or die "can't opendir './': $!";
 246     my @a = grep { not /^\.+$/ } readdir DIR;
 247     closedir DIR;
 248     @a;
 249   }
 250   : ();
 251 ----------
 252     };
 253
 254     ####################################
 255     # BEGIN SECTION 3: Expected output #
 256     ####################################
 257     $rtests = {
 258
 259         'here_long.here_long' => {
 260             source => "here_long",
 261             params => "here_long",
 262             expect => <<'#1...........',
 263 # must not break after here target regardless of maximum-line-length
 264 $sth = $dbh->prepare(
 265     <<"END_OF_SELECT") or die "Couldn't prepare SQL";
 266     SELECT COUNT(duration),SUM(duration)
 267     FROM logins WHERE username='$user'
 268 END_OF_SELECT
 269
 270 #1...........
 271         },
 272
 273         'bbhb.bbhb2' => {
 274             source => "bbhb",
 275             params => "bbhb2",
 276             expect => <<'#2...........',
 277 my %temp =
 278   (
 279     supsup => 123,
 280     nested =>
 281       {
 282         asdf => 456,
 283         yarg => 'yarp',
 284       },
 285   );
 286 #2...........
 287         },
 288
 289         'bbhb.bbhb3' => {
 290             source => "bbhb",
 291             params => "bbhb3",
 292             expect => <<'#3...........',
 293 my %temp =
 294   (
 295     supsup => 123,
 296     nested =>
 297       {
 298         asdf => 456,
 299         yarg => 'yarp',
 300       },
 301   );
 302 #3...........
 303         },
 304
 305         'bbhb.def' => {
 306             source => "bbhb",
 307             params => "def",
 308             expect => <<'#4...........',
 309 my %temp = (
 310     supsup => 123,
 311     nested => {
 312         asdf => 456,
 313         yarg => 'yarp',
 314     },
 315 );
 316 #4...........
 317         },
 318
 319         'bbhb.bbhb4' => {
 320             source => "bbhb",
 321             params => "bbhb4",
 322             expect => <<'#5...........',
 323 my %temp =
 324     (
 325     supsup => 123,
 326     nested =>
 327         {
 328         asdf => 456,
 329         yarg => 'yarp',
 330         },
 331     );
 332 #5...........
 333         },
 334
 335         'bbhb.bbhb5' => {
 336             source => "bbhb",
 337             params => "bbhb5",
 338             expect => <<'#6...........',
 339 my %temp =
 340 (
 341     supsup => 123,
 342     nested =>
 343     {
 344         asdf => 456,
 345         yarg => 'yarp',
 346     },
 347 );
 348 #6...........
 349         },
 350
 351         'braces.braces7' => {
 352             source => "braces",
 353             params => "braces7",
 354             expect => <<'#7...........',
 355 sub message
 356   {
 357     if ( !defined( $_[0] ) )
 358       {
 359         print("Hello, World\n");
 360       }
 361     else
 362       {
 363         print( $_[0], "\n" );
 364       }
 365   }
 366
 367 $myfun = sub
 368   {
 369     print("Hello, World\n");
 370   };
 371
 372 eval
 373   {
 374     my $app = App::perlbrew->new( "install-patchperl", "-q" );
 375     $app->run();
 376   } or do
 377   {
 378     $error          = $@;
 379     $produced_error = 1;
 380   };
 381
 382 Mojo::IOLoop->next_tick(
 383     sub
 384       {
 385         $ua->get(
 386             '/' => sub
 387               {
 388                 push @kept_alive, pop->kept_alive;
 389                 Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
 390               }
 391         );
 392       }
 393 );
 394
 395 $r = do
 396   {
 397     sswitch( $words[ rand @words ] )
 398       {
 399         case $words[0]:
 400         case $words[1]:
 401         case $words[2]:
 402         case $words[3]: { 'ok' }
 403       default: { 'wtf' }
 404       }
 405   };
 406
 407 try
 408   {
 409     die;
 410   }
 411 catch
 412   {
 413     die;
 414   };
 415 #7...........
 416         },
 417
 418         'xci.def' => {
 419             source => "xci",
 420             params => "def",
 421             expect => <<'#8...........',
 422 $self->{_text} = (
 423      !$section        ? ''
 424     : $type eq 'item' ? "the $section entry"
 425     :                   "the section on $section"
 426   )
 427   . (
 428     $page
 429     ? ( $section ? ' in ' : '' ) . "the $page$page_ext manpage"
 430     : ' elsewhere in this document'
 431   );
 432
 433 my $otherHashRef =
 434   $condition
 435   ? {
 436     'a' => 'a value',
 437     'b' => 'b value',
 438     'c' => {
 439         'd' => 'd value',
 440         'e' => 'e value'
 441     }
 442   }
 443   : undef;
 444
 445 my @globlist = ( grep { defined } @opt{qw( l q S t )} )
 446   ? do {
 447     local *DIR;
 448     opendir DIR, './' or die "can't opendir './': $!";
 449     my @a = grep { not /^\.+$/ } readdir DIR;
 450     closedir DIR;
 451     @a;
 452   }
 453   : ();
 454 #8...........
 455         },
 456
 457         'xci.xci1' => {
 458             source => "xci",
 459             params => "xci1",
 460             expect => <<'#9...........',
 461 $self->{_text} = (
 462      !$section        ? ''
 463     : $type eq 'item' ? "the $section entry"
 464     :                   "the section on $section"
 465   )
 466   . (
 467       $page
 468       ? ( $section ? ' in ' : '' ) . "the $page$page_ext manpage"
 469       : ' elsewhere in this document'
 470   );
 471
 472 my $otherHashRef =
 473   $condition
 474   ? {
 475       'a' => 'a value',
 476       'b' => 'b value',
 477       'c' => {
 478           'd' => 'd value',
 479           'e' => 'e value'
 480       }
 481   }
 482   : undef;
 483
 484 my @globlist = ( grep { defined } @opt{qw( l q S t )} )
 485   ? do {
 486       local *DIR;
 487       opendir DIR, './' or die "can't opendir './': $!";
 488       my @a = grep { not /^\.+$/ } readdir DIR;
 489       closedir DIR;
 490       @a;
 491   }
 492   : ();
 493 #9...........
 494         },
 495
 496         'xci.xci2' => {
 497             source => "xci",
 498             params => "xci2",
 499             expect => <<'#10...........',
 500 $self->{_text} = (
 501      !$section        ? ''
 502     : $type eq 'item' ? "the $section entry"
 503     :                   "the section on $section"
 504     )
 505     . ( $page
 506         ? ( $section ? ' in ' : '' ) . "the $page$page_ext manpage"
 507         : ' elsewhere in this document'
 508     );
 509
 510 my $otherHashRef
 511     = $condition
 512     ? { 'a' => 'a value',
 513         'b' => 'b value',
 514         'c' => {
 515             'd' => 'd value',
 516             'e' => 'e value'
 517         }
 518     }
 519     : undef;
 520
 521 my @globlist = ( grep {defined} @opt{qw( l q S t )} )
 522     ? do {
 523         local *DIR;
 524         opendir DIR, './' or die "can't opendir './': $!";
 525         my @a = grep { not /^\.+$/ } readdir DIR;
 526         closedir DIR;
 527         @a;
 528     }
 529     : ();
 530 #10...........
 531         },
 532
 533         'mangle4.def' => {
 534             source => "mangle4",
 535             params => "def",
 536             expect => <<'#11...........',
 537 # a useful parsing test from 'signatures.t'
 538 use feature "signatures";
 539 no warnings "experimental::signatures";
 540
 541 sub t086 (    #foo)))
 542     $         #foo)))
 543       a       #foo)))
 544     ,         #foo)))
 545     ,         #foo)))
 546     $         #foo)))
 547       b       #foo)))
 548       =       #foo)))
 549       333     #foo)))
 550     ,         #foo)))
 551     ,         #foo)))
 552   )           #foo)))
 553 { $a . $b }
 554 #11...........
 555         },
 556
 557         'mangle4.mangle' => {
 558             source => "mangle4",
 559             params => "mangle",
 560             expect => <<'#12...........',
 561 # a useful parsing test from 'signatures.t'
 562 use feature "signatures";
 563 no warnings "experimental::signatures";
 564 sub t086(#foo)))
 565 $ #foo)))
 566   a#foo)))
 567 ,#foo)))
 568 ,#foo)))
 569 $ #foo)))
 570   b#foo)))
 571   =#foo)))
 572   333#foo)))
 573 ,#foo)))
 574 ,#foo)))
 575   )#foo)))
 576 {$a.$b}
 577 #12...........
 578         },
 579
 580         'extrude5.def' => {
 581             source => "extrude5",
 582             params => "def",
 583             expect => <<'#13...........',
 584 use perl6-alpha;
 585 $var{-y} = 1;
 586 #13...........
 587         },
 588
 589         'extrude5.extrude' => {
 590             source => "extrude5",
 591             params => "extrude",
 592             expect => <<'#14...........',
 593 use
 594 perl6-alpha
 595 ;
 596 $var{-y}
 597 =
 598 1
 599 ;
 600 #14...........
 601         },
 602
 603         'kba1.def' => {
 604             source => "kba1",
 605             params => "def",
 606             expect => <<'#15...........',
 607 $this_env = join( "",
 608     $before, $closures, $contents, ( $defenv ? '' : &balance_tags() ),
 609     $reopens );
 610 $_ = $after;
 611
 612 method 'foo1' => [ Int, Int ] => sub {
 613     my ( $self, $x, $y ) = ( shift, @_ );
 614     ...;
 615 };
 616
 617 method 'foo2' => [ Int, Int ] => sub {
 618     my ( $self, $x, $y ) = ( shift, @_ );
 619     ...;
 620 };
 621
 622 #15...........
 623         },
 624
 625         'kba1.kba1' => {
 626             source => "kba1",
 627             params => "kba1",
 628             expect => <<'#16...........',
 629 $this_env = join(
 630     "", $before, $closures
 631     ,   $contents
 632     , ( $defenv ? '' : &balance_tags() )
 633     , $reopens
 634 );
 635 $_ = $after;
 636
 637 method 'foo1'
 638   => [ Int, Int ]
 639   => sub {
 640     my ( $self, $x, $y ) = ( shift, @_ );
 641     ...;
 642   };
 643
 644 method 'foo2'  =>
 645   [ Int, Int ] =>
 646   sub {
 647     my ( $self, $x, $y ) = ( shift, @_ );
 648     ...;
 649   };
 650
 651 #16...........
 652         },
 653
 654         'git45.def' => {
 655             source => "git45",
 656             params => "def",
 657             expect => <<'#17...........',
 658 # git#45 -vtc=n and -wn were not working together
 659 if (
 660     $self->_add_fqdn_host(
 661         name  => $name,
 662         realm => $realm
 663     )
 664   )
 665 {
 666     ...;
 667 }
 668
 669 # do not stack )->pack(
 670 my $hlist = $control::control->Scrolled(
 671     'HList',
 672     drawbranch  => 1,
 673     width       => 20,
 674     -scrollbars => 'w'
 675 )->pack(
 676     -side   => 'bottom',
 677     -expand => 1
 678 );
 679
 680 #17...........
 681         },
 682
 683         'git45.git45' => {
 684             source => "git45",
 685             params => "git45",
 686             expect => <<'#18...........',
 687 # git#45 -vtc=n and -wn were not working together
 688 if ( $self->_add_fqdn_host(
 689     name  => $name,
 690     realm => $realm ) )
 691 {
 692     ...;
 693 }
 694
 695 # do not stack )->pack(
 696 my $hlist = $control::control->Scrolled(
 697     'HList',
 698     drawbranch  => 1,
 699     width       => 20,
 700     -scrollbars => 'w'
 701 )->pack(
 702     -side   => 'bottom',
 703     -expand => 1 );
 704
 705 #18...........
 706         },
 707
 708         'boa.boa' => {
 709             source => "boa",
 710             params => "boa",
 711             expect => <<'#19...........',
 712 my @field : field : Default(1) : Get('Name' => 'foo') : Set('Name');
 713 #19...........
 714         },
 715     };
 716
 717     my $ntests = 0 + keys %{$rtests};
 718     plan tests => $ntests;
 719 }
 720
 721 ###############
 722 # EXECUTE TESTS
 723 ###############
 724
 725 foreach my $key ( sort keys %{$rtests} ) {
 726     my $output;
 727     my $sname  = $rtests->{$key}->{source};
 728     my $expect = $rtests->{$key}->{expect};
 729     my $pname  = $rtests->{$key}->{params};
 730     my $source = $rsources->{$sname};
 731     my $params = defined($pname) ? $rparams->{$pname} : "";
 732     my $stderr_string;
 733     my $errorfile_string;
 734     my $err = Perl::Tidy::perltidy(
 735         source      => \$source,
 736         destination => \$output,
 737         perltidyrc  => \$params,
 738         argv        => '',             # for safety; hide any ARGV from perltidy
 739         stderr      => \$stderr_string,
 740         errorfile   => \$errorfile_string,    # not used when -se flag is set
 741     );
 742     if ( $err || $stderr_string || $errorfile_string ) {
 743         print STDERR "Error output received for test '$key'\n";
 744         if ($err) {
 745             print STDERR "An error flag '$err' was returned\n";
 746             ok( !$err );
 747         }
 748         if ($stderr_string) {
 749             print STDERR "---------------------\n";
 750             print STDERR "<<STDERR>>\n$stderr_string\n";
 751             print STDERR "---------------------\n";
 752             ok( !$stderr_string );
 753         }
 754         if ($errorfile_string) {
 755             print STDERR "---------------------\n";
 756             print STDERR "<<.ERR file>>\n$errorfile_string\n";
 757             print STDERR "---------------------\n";
 758             ok( !$errorfile_string );
 759         }
 760     }
 761     else {
 762         if ( !is( $output, $expect, $key ) ) {
 763             my $leno = length($output);
 764             my $lene = length($expect);
 765             if ( $leno == $lene ) {
 766                 print STDERR
 767 "#> Test '$key' gave unexpected output.  Strings differ but both have length $leno\n";
 768             }
 769             else {
 770                 print STDERR
 771 "#> Test '$key' gave unexpected output.  String lengths differ: output=$leno, expected=$lene\n";
 772             }
 773         }
 774     }
 775 }