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='*' -blixl='eval'
  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     my $app = App::perlbrew->new( "install-patchperl", "-q" );
 374     $app->run();
 375 } or do
 376   {
 377     $error          = $@;
 378     $produced_error = 1;
 379   };
 380
 381 Mojo::IOLoop->next_tick(
 382     sub
 383       {
 384         $ua->get(
 385             '/' => sub
 386               {
 387                 push @kept_alive, pop->kept_alive;
 388                 Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
 389               }
 390         );
 391       }
 392 );
 393
 394 $r = do
 395   {
 396     sswitch( $words[ rand @words ] )
 397       {
 398         case $words[0]:
 399         case $words[1]:
 400         case $words[2]:
 401         case $words[3]: { 'ok' }
 402       default: { 'wtf' }
 403       }
 404   };
 405
 406 try
 407   {
 408     die;
 409   }
 410 catch
 411   {
 412     die;
 413   };
 414 #7...........
 415         },
 416
 417         'xci.def' => {
 418             source => "xci",
 419             params => "def",
 420             expect => <<'#8...........',
 421 $self->{_text} = (
 422      !$section        ? ''
 423     : $type eq 'item' ? "the $section entry"
 424     :                   "the section on $section"
 425   )
 426   . (
 427     $page
 428     ? ( $section ? ' in ' : '' ) . "the $page$page_ext manpage"
 429     : ' elsewhere in this document'
 430   );
 431
 432 my $otherHashRef =
 433   $condition
 434   ? {
 435     'a' => 'a value',
 436     'b' => 'b value',
 437     'c' => {
 438         'd' => 'd value',
 439         'e' => 'e value'
 440     }
 441   }
 442   : undef;
 443
 444 my @globlist = ( grep { defined } @opt{qw( l q S t )} )
 445   ? do {
 446     local *DIR;
 447     opendir DIR, './' or die "can't opendir './': $!";
 448     my @a = grep { not /^\.+$/ } readdir DIR;
 449     closedir DIR;
 450     @a;
 451   }
 452   : ();
 453 #8...........
 454         },
 455
 456         'xci.xci1' => {
 457             source => "xci",
 458             params => "xci1",
 459             expect => <<'#9...........',
 460 $self->{_text} = (
 461      !$section        ? ''
 462     : $type eq 'item' ? "the $section entry"
 463     :                   "the section on $section"
 464   )
 465   . (
 466       $page
 467       ? ( $section ? ' in ' : '' ) . "the $page$page_ext manpage"
 468       : ' elsewhere in this document'
 469   );
 470
 471 my $otherHashRef =
 472   $condition
 473   ? {
 474       'a' => 'a value',
 475       'b' => 'b value',
 476       'c' => {
 477           'd' => 'd value',
 478           'e' => 'e value'
 479       }
 480   }
 481   : undef;
 482
 483 my @globlist = ( grep { defined } @opt{qw( l q S t )} )
 484   ? do {
 485       local *DIR;
 486       opendir DIR, './' or die "can't opendir './': $!";
 487       my @a = grep { not /^\.+$/ } readdir DIR;
 488       closedir DIR;
 489       @a;
 490   }
 491   : ();
 492 #9...........
 493         },
 494
 495         'xci.xci2' => {
 496             source => "xci",
 497             params => "xci2",
 498             expect => <<'#10...........',
 499 $self->{_text} = (
 500      !$section        ? ''
 501     : $type eq 'item' ? "the $section entry"
 502     :                   "the section on $section"
 503     )
 504     . ( $page
 505         ? ( $section ? ' in ' : '' ) . "the $page$page_ext manpage"
 506         : ' elsewhere in this document'
 507     );
 508
 509 my $otherHashRef
 510     = $condition
 511     ? { 'a' => 'a value',
 512         'b' => 'b value',
 513         'c' => {
 514             'd' => 'd value',
 515             'e' => 'e value'
 516         }
 517     }
 518     : undef;
 519
 520 my @globlist = ( grep {defined} @opt{qw( l q S t )} )
 521     ? do {
 522         local *DIR;
 523         opendir DIR, './' or die "can't opendir './': $!";
 524         my @a = grep { not /^\.+$/ } readdir DIR;
 525         closedir DIR;
 526         @a;
 527     }
 528     : ();
 529 #10...........
 530         },
 531
 532         'mangle4.def' => {
 533             source => "mangle4",
 534             params => "def",
 535             expect => <<'#11...........',
 536 # a useful parsing test from 'signatures.t'
 537 use feature "signatures";
 538 no warnings "experimental::signatures";
 539
 540 sub t086 (    #foo)))
 541     $         #foo)))
 542       a       #foo)))
 543     ,         #foo)))
 544     ,         #foo)))
 545     $         #foo)))
 546       b       #foo)))
 547       =       #foo)))
 548       333     #foo)))
 549     ,         #foo)))
 550     ,         #foo)))
 551   )           #foo)))
 552 { $a . $b }
 553 #11...........
 554         },
 555
 556         'mangle4.mangle' => {
 557             source => "mangle4",
 558             params => "mangle",
 559             expect => <<'#12...........',
 560 # a useful parsing test from 'signatures.t'
 561 use feature "signatures";
 562 no warnings "experimental::signatures";
 563 sub t086(#foo)))
 564 $ #foo)))
 565   a#foo)))
 566 ,#foo)))
 567 ,#foo)))
 568 $ #foo)))
 569   b#foo)))
 570   =#foo)))
 571   333#foo)))
 572 ,#foo)))
 573 ,#foo)))
 574   )#foo)))
 575 {$a.$b}
 576 #12...........
 577         },
 578
 579         'extrude5.def' => {
 580             source => "extrude5",
 581             params => "def",
 582             expect => <<'#13...........',
 583 use perl6-alpha;
 584 $var{-y} = 1;
 585 #13...........
 586         },
 587
 588         'extrude5.extrude' => {
 589             source => "extrude5",
 590             params => "extrude",
 591             expect => <<'#14...........',
 592 use
 593 perl6-alpha
 594 ;
 595 $var{-y}
 596 =
 597 1
 598 ;
 599 #14...........
 600         },
 601
 602         'kba1.def' => {
 603             source => "kba1",
 604             params => "def",
 605             expect => <<'#15...........',
 606 $this_env = join( "",
 607     $before, $closures, $contents, ( $defenv ? '' : &balance_tags() ),
 608     $reopens );
 609 $_ = $after;
 610
 611 method 'foo1' => [ Int, Int ] => sub {
 612     my ( $self, $x, $y ) = ( shift, @_ );
 613     ...;
 614 };
 615
 616 method 'foo2' => [ Int, Int ] => sub {
 617     my ( $self, $x, $y ) = ( shift, @_ );
 618     ...;
 619 };
 620
 621 #15...........
 622         },
 623
 624         'kba1.kba1' => {
 625             source => "kba1",
 626             params => "kba1",
 627             expect => <<'#16...........',
 628 $this_env = join(
 629     "", $before, $closures
 630     ,   $contents
 631     , ( $defenv ? '' : &balance_tags() )
 632     , $reopens
 633 );
 634 $_ = $after;
 635
 636 method 'foo1'
 637   => [ Int, Int ]
 638   => sub {
 639     my ( $self, $x, $y ) = ( shift, @_ );
 640     ...;
 641   };
 642
 643 method 'foo2'  =>
 644   [ Int, Int ] =>
 645   sub {
 646     my ( $self, $x, $y ) = ( shift, @_ );
 647     ...;
 648   };
 649
 650 #16...........
 651         },
 652
 653         'git45.def' => {
 654             source => "git45",
 655             params => "def",
 656             expect => <<'#17...........',
 657 # git#45 -vtc=n and -wn were not working together
 658 if (
 659     $self->_add_fqdn_host(
 660         name  => $name,
 661         realm => $realm
 662     )
 663   )
 664 {
 665     ...;
 666 }
 667
 668 # do not stack )->pack(
 669 my $hlist = $control::control->Scrolled(
 670     'HList',
 671     drawbranch  => 1,
 672     width       => 20,
 673     -scrollbars => 'w'
 674 )->pack(
 675     -side   => 'bottom',
 676     -expand => 1
 677 );
 678
 679 #17...........
 680         },
 681
 682         'git45.git45' => {
 683             source => "git45",
 684             params => "git45",
 685             expect => <<'#18...........',
 686 # git#45 -vtc=n and -wn were not working together
 687 if ( $self->_add_fqdn_host(
 688     name  => $name,
 689     realm => $realm ) )
 690 {
 691     ...;
 692 }
 693
 694 # do not stack )->pack(
 695 my $hlist = $control::control->Scrolled(
 696     'HList',
 697     drawbranch  => 1,
 698     width       => 20,
 699     -scrollbars => 'w'
 700 )->pack(
 701     -side   => 'bottom',
 702     -expand => 1 );
 703
 704 #18...........
 705         },
 706
 707         'boa.boa' => {
 708             source => "boa",
 709             params => "boa",
 710             expect => <<'#19...........',
 711 my @field : field : Default(1) : Get('Name' => 'foo') : Set('Name');
 712 #19...........
 713         },
 714     };
 715
 716     my $ntests = 0 + keys %{$rtests};
 717     plan tests => $ntests;
 718 }
 719
 720 ###############
 721 # EXECUTE TESTS
 722 ###############
 723
 724 foreach my $key ( sort keys %{$rtests} ) {
 725     my $output;
 726     my $sname  = $rtests->{$key}->{source};
 727     my $expect = $rtests->{$key}->{expect};
 728     my $pname  = $rtests->{$key}->{params};
 729     my $source = $rsources->{$sname};
 730     my $params = defined($pname) ? $rparams->{$pname} : "";
 731     my $stderr_string;
 732     my $errorfile_string;
 733     my $err = Perl::Tidy::perltidy(
 734         source      => \$source,
 735         destination => \$output,
 736         perltidyrc  => \$params,
 737         argv        => '',             # for safety; hide any ARGV from perltidy
 738         stderr      => \$stderr_string,
 739         errorfile   => \$errorfile_string,    # not used when -se flag is set
 740     );
 741     if ( $err || $stderr_string || $errorfile_string ) {
 742         print STDERR "Error output received for test '$key'\n";
 743         if ($err) {
 744             print STDERR "An error flag '$err' was returned\n";
 745             ok( !$err );
 746         }
 747         if ($stderr_string) {
 748             print STDERR "---------------------\n";
 749             print STDERR "<<STDERR>>\n$stderr_string\n";
 750             print STDERR "---------------------\n";
 751             ok( !$stderr_string );
 752         }
 753         if ($errorfile_string) {
 754             print STDERR "---------------------\n";
 755             print STDERR "<<.ERR file>>\n$errorfile_string\n";
 756             print STDERR "---------------------\n";
 757             ok( !$errorfile_string );
 758         }
 759     }
 760     else {
 761         if ( !is( $output, $expect, $key ) ) {
 762             my $leno = length($output);
 763             my $lene = length($expect);
 764             if ( $leno == $lene ) {
 765                 print STDERR
 766 "#> Test '$key' gave unexpected output.  Strings differ but both have length $leno\n";
 767             }
 768             else {
 769                 print STDERR
 770 "#> Test '$key' gave unexpected output.  String lengths differ: output=$leno, expected=$lene\n";
 771             }
 772         }
 773     }
 774 }