t/snippets23.t

   1 # Created with: ./make_t.pl
   2
   3 # Contents:
   4 #1 boa.def
   5 #2 bol.bol
   6 #3 bol.def
   7 #4 bot.bot
   8 #5 bot.def
   9 #6 hash_bang.def
  10 #7 hash_bang.hash_bang
  11 #8 listop1.listop1
  12 #9 sbcp.def
  13 #10 sbcp.sbcp1
  14 #11 wnxl.def
  15 #12 wnxl.wnxl1
  16 #13 wnxl.wnxl2
  17 #14 wnxl.wnxl3
  18 #15 wnxl.wnxl4
  19 #16 align34.def
  20 #17 git47.def
  21 #18 git47.git47
  22 #19 qw.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         'bol' => <<'----------',
  41 # -bol is default, so test -nbol
  42 -nbol
  43 ----------
  44         'bot' => <<'----------',
  45 # -bot is default so we test -nbot
  46 -nbot
  47 ----------
  48         'def'   => "",
  49         'git47' => <<'----------',
  50 # perltidyrc from git #47
  51 -pbp     # Start with Perl Best Practices
  52 -w       # Show all warnings
  53 -iob     # Ignore old breakpoints
  54 -l=120   # 120 characters per line
  55 -mbl=2   # No more than 2 blank lines
  56 -i=2     # Indentation is 2 columns
  57 -ci=2    # Continuation indentation is 2 columns
  58 -vt=0    # Less vertical tightness
  59 -pt=2    # High parenthesis tightness
  60 -bt=2    # High brace tightness
  61 -sbt=2   # High square bracket tightness
  62 -wn      # Weld nested containers
  63 -isbc    # Don't indent comments without leading space
  64 -nst     # Don't output to STDOUT
  65 ----------
  66         'hash_bang' => "-x",
  67         'listop1'   => <<'----------',
  68 # -bok is default so we test nbok
  69 -nbok
  70 ----------
  71         'sbcp1' => <<'----------',
  72 -sbc -sbcp='#x#'
  73 ----------
  74         'wnxl1' => <<'----------',
  75 # only weld parens, and only if leading keyword
  76 -wn -wnxl='^K( [ { q'
  77 ----------
  78         'wnxl2' => <<'----------',
  79 # do not weld leading '['
  80 -wn -wnxl='^['
  81 ----------
  82         'wnxl3' => <<'----------',
  83 # do not weld interior or ending '{' without a keyword
  84 -wn -wnxl='.K{'
  85
  86 ----------
  87         'wnxl4' => <<'----------',
  88 # do not weld except parens or trailing brace with keyword
  89 -wn -wnxl='.K{ ^{ ['
  90 ----------
  91     };
  92
  93     ############################
  94     # BEGIN SECTION 2: Sources #
  95     ############################
  96     $rsources = {
  97
  98         'align34' => <<'----------',
  99 # align all '{' and runs of '='
 100 if    ( $line =~ /^NAME>(.*)/i )       { $Cookies{'name'} = $1; }
 101 elsif ( $line =~ /^EMAIL>(.*)/i )      { $email = $1; }
 102 elsif ( $line =~ /^IP_ADDRESS>(.*)/i ) { $ipaddress = $1; }
 103 elsif ( $line =~ /^<!--(.*)-->/i )     { $remoteuser = $1; }
 104 elsif ( $line =~ /^PASSWORD>(.*)/i )   { next; }
 105 elsif ( $line =~ /^IMAGE>(.*)/i )      { $image_url = $1; }
 106 elsif ( $line =~ /^LINKNAME>(.*)/i )   { $linkname = $1; }
 107 elsif ( $line =~ /^LINKURL>(.*)/i )    { $linkurl = $1; }
 108 else                                   { $body .= $line; }
 109 ----------
 110
 111         'boa' => <<'----------',
 112 my @field
 113   : field
 114   : Default(1)
 115   : Get('Name' => 'foo')
 116   : Set('Name');
 117 ----------
 118
 119         'bol' => <<'----------',
 120 return unless $cmd = $cmd || ($dot
 121           && $Last_Shell) || &prompt('|');
 122 ----------
 123
 124         'bot' => <<'----------',
 125 $foo =
 126   $condition
 127   ? undef
 128   : 1;
 129 ----------
 130
 131         'git47' => <<'----------',
 132 # cannot weld here
 133 $promises[$i]->then(
 134     sub { $all->resolve(@_); () },
 135     sub {
 136         $results->[$i] = [@_];
 137         $all->reject(@$results) if --$remaining <= 0;
 138         return ();
 139     }
 140 );
 141
 142 sub _absolutize { [
 143     map { _is_scoped($_) ? $_ : [ [ [ 'pc', 'scope' ] ], ' ', @$_ ] }
 144       @{ shift() } ] }
 145
 146 $c->helpers->log->debug( sub {
 147     my $req    = $c->req;
 148     my $method = $req->method;
 149     my $path   = $req->url->path->to_abs_string;
 150     $c->helpers->timing->begin('mojo.timer');
 151     return qq{$method "$path"};
 152 } ) unless $stash->{'mojo.static'};
 153
 154 # A single signature var can weld
 155 return Mojo::Promise->resolve($query_params)->then(&_reveal_event)->then(
 156     sub ($code) {
 157         return $c->render( text => '', status => $code );
 158     }
 159 );
 160 ----------
 161
 162         'hash_bang' => <<'----------',
 163
 164
 165
 166
 167 # above spaces will be retained with -x but not by default
 168 #!/usr/bin/perl
 169 my $date = localtime();
 170 ----------
 171
 172         'listop1' => <<'----------',
 173 my @sorted = map { $_->[0] }
 174   sort { $a->[1] <=> $b->[1] }
 175   map { [ $_, rand ] } @list;
 176 ----------
 177
 178         'qw' => <<'----------',
 179     # do not outdent ending ) more than initial qw line
 180     if ( $pos == 0 ) {
 181         @return = grep( /^$word/,
 182             sort qw(
 183               ! a b d h i m o q r u autobundle clean
 184               make test install force reload look
 185         ) );
 186     }
 187
 188     # outdent ')' even if opening is not '('
 189     @EXPORT = (
 190         qw)
 191           i Re Im rho theta arg
 192           sqrt log ln
 193           log10 logn cbrt root
 194           cplx cplxe
 195         ),
 196         @trig
 197     );
 198
 199     # outdent '>' like ')'
 200     @EXPORT = (
 201         qw<
 202           i Re Im rho theta arg
 203           sqrt log ln
 204           log10 logn cbrt root
 205           cplx cplxe
 206         >,
 207         @trig
 208     );
 209
 210     # but ';' not outdented
 211     @EXPORT = (
 212         qw;
 213           i Re Im rho theta arg
 214           sqrt log ln
 215           log10 logn cbrt root
 216           cplx cplxe
 217           ;,
 218         @trig
 219     );
 220 ----------
 221
 222         'sbcp' => <<'----------',
 223 @month_of_year = (
 224     'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
 225 #x# 'Dec', 'Nov'
 226 ## 'Dec', 'Nov'
 227     'Nov', 'Dec'
 228 );
 229 ----------
 230
 231         'wnxl' => <<'----------',
 232 if ( $PLATFORM eq 'aix' ) {
 233     skip_symbols(
 234         [ qw(
 235             Perl_dump_fds
 236             Perl_ErrorNo
 237             Perl_GetVars
 238             PL_sys_intern
 239         ) ]
 240     );
 241 }
 242
 243 if ( _add_fqdn_host(
 244     name => ...,
 245     fqdn => ...
 246 ) )
 247 {
 248     ...;
 249 }
 250
 251 do {{
 252     next if ($n % 2);
 253     print $n, "\n";
 254 }} while ($n++ < 10);
 255
 256 threads->create( sub {
 257     my (%hash3);
 258     share(%hash3);
 259     $hash2{hash} = \%hash3;
 260     $hash3{"thread"} = "yes";
 261 } )->join();
 262 ----------
 263     };
 264
 265     ####################################
 266     # BEGIN SECTION 3: Expected output #
 267     ####################################
 268     $rtests = {
 269
 270         'boa.def' => {
 271             source => "boa",
 272             params => "def",
 273             expect => <<'#1...........',
 274 my @field
 275   : field
 276   : Default(1)
 277   : Get('Name' => 'foo')
 278   : Set('Name');
 279 #1...........
 280         },
 281
 282         'bol.bol' => {
 283             source => "bol",
 284             params => "bol",
 285             expect => <<'#2...........',
 286 return unless $cmd = $cmd || ( $dot && $Last_Shell ) || &prompt('|');
 287 #2...........
 288         },
 289
 290         'bol.def' => {
 291             source => "bol",
 292             params => "def",
 293             expect => <<'#3...........',
 294 return
 295   unless $cmd = $cmd
 296   || ( $dot
 297     && $Last_Shell )
 298   || &prompt('|');
 299 #3...........
 300         },
 301
 302         'bot.bot' => {
 303             source => "bot",
 304             params => "bot",
 305             expect => <<'#4...........',
 306 $foo = $condition ? undef : 1;
 307 #4...........
 308         },
 309
 310         'bot.def' => {
 311             source => "bot",
 312             params => "def",
 313             expect => <<'#5...........',
 314 $foo =
 315   $condition
 316   ? undef
 317   : 1;
 318 #5...........
 319         },
 320
 321         'hash_bang.def' => {
 322             source => "hash_bang",
 323             params => "def",
 324             expect => <<'#6...........',
 325
 326 # above spaces will be retained with -x but not by default
 327 #!/usr/bin/perl
 328 my $date = localtime();
 329 #6...........
 330         },
 331
 332         'hash_bang.hash_bang' => {
 333             source => "hash_bang",
 334             params => "hash_bang",
 335             expect => <<'#7...........',
 336
 337
 338
 339
 340 # above spaces will be retained with -x but not by default
 341 #!/usr/bin/perl
 342 my $date = localtime();
 343 #7...........
 344         },
 345
 346         'listop1.listop1' => {
 347             source => "listop1",
 348             params => "listop1",
 349             expect => <<'#8...........',
 350 my @sorted =
 351   map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, rand ] } @list;
 352 #8...........
 353         },
 354
 355         'sbcp.def' => {
 356             source => "sbcp",
 357             params => "def",
 358             expect => <<'#9...........',
 359 @month_of_year = (
 360     'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
 361
 362     #x# 'Dec', 'Nov'
 363 ## 'Dec', 'Nov'
 364     'Nov', 'Dec'
 365 );
 366 #9...........
 367         },
 368
 369         'sbcp.sbcp1' => {
 370             source => "sbcp",
 371             params => "sbcp1",
 372             expect => <<'#10...........',
 373 @month_of_year = (
 374     'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
 375 #x# 'Dec', 'Nov'
 376     ## 'Dec', 'Nov'
 377     'Nov', 'Dec'
 378 );
 379 #10...........
 380         },
 381
 382         'wnxl.def' => {
 383             source => "wnxl",
 384             params => "def",
 385             expect => <<'#11...........',
 386 if ( $PLATFORM eq 'aix' ) {
 387     skip_symbols(
 388         [
 389             qw(
 390               Perl_dump_fds
 391               Perl_ErrorNo
 392               Perl_GetVars
 393               PL_sys_intern
 394             )
 395         ]
 396     );
 397 }
 398
 399 if (
 400     _add_fqdn_host(
 401         name => ...,
 402         fqdn => ...
 403     )
 404   )
 405 {
 406     ...;
 407 }
 408
 409 do {
 410     {
 411         next if ( $n % 2 );
 412         print $n, "\n";
 413     }
 414 } while ( $n++ < 10 );
 415
 416 threads->create(
 417     sub {
 418         my (%hash3);
 419         share(%hash3);
 420         $hash2{hash}     = \%hash3;
 421         $hash3{"thread"} = "yes";
 422     }
 423 )->join();
 424 #11...........
 425         },
 426
 427         'wnxl.wnxl1' => {
 428             source => "wnxl",
 429             params => "wnxl1",
 430             expect => <<'#12...........',
 431 if ( $PLATFORM eq 'aix' ) {
 432     skip_symbols(
 433         [
 434             qw(
 435               Perl_dump_fds
 436               Perl_ErrorNo
 437               Perl_GetVars
 438               PL_sys_intern
 439             )
 440         ]
 441     );
 442 }
 443
 444 if ( _add_fqdn_host(
 445     name => ...,
 446     fqdn => ...
 447 ) )
 448 {
 449     ...;
 450 }
 451
 452 do {
 453     {
 454         next if ( $n % 2 );
 455         print $n, "\n";
 456     }
 457 } while ( $n++ < 10 );
 458
 459 threads->create(
 460     sub {
 461         my (%hash3);
 462         share(%hash3);
 463         $hash2{hash}     = \%hash3;
 464         $hash3{"thread"} = "yes";
 465     }
 466 )->join();
 467 #12...........
 468         },
 469
 470         'wnxl.wnxl2' => {
 471             source => "wnxl",
 472             params => "wnxl2",
 473             expect => <<'#13...........',
 474 if ( $PLATFORM eq 'aix' ) {
 475     skip_symbols( [ qw(
 476         Perl_dump_fds
 477         Perl_ErrorNo
 478         Perl_GetVars
 479         PL_sys_intern
 480     ) ] );
 481 }
 482
 483 if ( _add_fqdn_host(
 484     name => ...,
 485     fqdn => ...
 486 ) )
 487 {
 488     ...;
 489 }
 490
 491 do { {
 492     next if ( $n % 2 );
 493     print $n, "\n";
 494 } } while ( $n++ < 10 );
 495
 496 threads->create( sub {
 497     my (%hash3);
 498     share(%hash3);
 499     $hash2{hash}     = \%hash3;
 500     $hash3{"thread"} = "yes";
 501 } )->join();
 502 #13...........
 503         },
 504
 505         'wnxl.wnxl3' => {
 506             source => "wnxl",
 507             params => "wnxl3",
 508             expect => <<'#14...........',
 509 if ( $PLATFORM eq 'aix' ) {
 510     skip_symbols( [ qw(
 511         Perl_dump_fds
 512         Perl_ErrorNo
 513         Perl_GetVars
 514         PL_sys_intern
 515     ) ] );
 516 }
 517
 518 if ( _add_fqdn_host(
 519     name => ...,
 520     fqdn => ...
 521 ) )
 522 {
 523     ...;
 524 }
 525
 526 do {
 527     {
 528         next if ( $n % 2 );
 529         print $n, "\n";
 530     }
 531 } while ( $n++ < 10 );
 532
 533 threads->create( sub {
 534     my (%hash3);
 535     share(%hash3);
 536     $hash2{hash}     = \%hash3;
 537     $hash3{"thread"} = "yes";
 538 } )->join();
 539 #14...........
 540         },
 541
 542         'wnxl.wnxl4' => {
 543             source => "wnxl",
 544             params => "wnxl4",
 545             expect => <<'#15...........',
 546 if ( $PLATFORM eq 'aix' ) {
 547     skip_symbols(
 548         [
 549             qw(
 550               Perl_dump_fds
 551               Perl_ErrorNo
 552               Perl_GetVars
 553               PL_sys_intern
 554             )
 555         ]
 556     );
 557 }
 558
 559 if ( _add_fqdn_host(
 560     name => ...,
 561     fqdn => ...
 562 ) )
 563 {
 564     ...;
 565 }
 566
 567 do {
 568     {
 569         next if ( $n % 2 );
 570         print $n, "\n";
 571     }
 572 } while ( $n++ < 10 );
 573
 574 threads->create( sub {
 575     my (%hash3);
 576     share(%hash3);
 577     $hash2{hash}     = \%hash3;
 578     $hash3{"thread"} = "yes";
 579 } )->join();
 580 #15...........
 581         },
 582
 583         'align34.def' => {
 584             source => "align34",
 585             params => "def",
 586             expect => <<'#16...........',
 587 # align all '{' and runs of '='
 588 if    ( $line =~ /^NAME>(.*)/i )       { $Cookies{'name'} = $1; }
 589 elsif ( $line =~ /^EMAIL>(.*)/i )      { $email           = $1; }
 590 elsif ( $line =~ /^IP_ADDRESS>(.*)/i ) { $ipaddress       = $1; }
 591 elsif ( $line =~ /^<!--(.*)-->/i )     { $remoteuser      = $1; }
 592 elsif ( $line =~ /^PASSWORD>(.*)/i )   { next; }
 593 elsif ( $line =~ /^IMAGE>(.*)/i )      { $image_url = $1; }
 594 elsif ( $line =~ /^LINKNAME>(.*)/i )   { $linkname  = $1; }
 595 elsif ( $line =~ /^LINKURL>(.*)/i )    { $linkurl   = $1; }
 596 else                                   { $body .= $line; }
 597 #16...........
 598         },
 599
 600         'git47.def' => {
 601             source => "git47",
 602             params => "def",
 603             expect => <<'#17...........',
 604 # cannot weld here
 605 $promises[$i]->then(
 606     sub { $all->resolve(@_); () },
 607     sub {
 608         $results->[$i] = [@_];
 609         $all->reject(@$results) if --$remaining <= 0;
 610         return ();
 611     }
 612 );
 613
 614 sub _absolutize {
 615     [ map { _is_scoped($_) ? $_ : [ [ [ 'pc', 'scope' ] ], ' ', @$_ ] }
 616           @{ shift() } ]
 617 }
 618
 619 $c->helpers->log->debug(
 620     sub {
 621         my $req    = $c->req;
 622         my $method = $req->method;
 623         my $path   = $req->url->path->to_abs_string;
 624         $c->helpers->timing->begin('mojo.timer');
 625         return qq{$method "$path"};
 626     }
 627 ) unless $stash->{'mojo.static'};
 628
 629 # A single signature var can weld
 630 return Mojo::Promise->resolve($query_params)->then(&_reveal_event)->then(
 631     sub ($code) {
 632         return $c->render( text => '', status => $code );
 633     }
 634 );
 635 #17...........
 636         },
 637
 638         'git47.git47' => {
 639             source => "git47",
 640             params => "git47",
 641             expect => <<'#18...........',
 642 # cannot weld here
 643 $promises[$i]->then(
 644   sub { $all->resolve(@_); () },
 645   sub {
 646     $results->[$i] = [@_];
 647     $all->reject(@$results) if --$remaining <= 0;
 648     return ();
 649   }
 650 );
 651
 652 sub _absolutize { [map { _is_scoped($_) ? $_ : [[['pc', 'scope']], ' ', @$_] } @{shift()}] }
 653
 654 $c->helpers->log->debug(sub {
 655   my $req    = $c->req;
 656   my $method = $req->method;
 657   my $path   = $req->url->path->to_abs_string;
 658   $c->helpers->timing->begin('mojo.timer');
 659   return qq{$method "$path"};
 660 }) unless $stash->{'mojo.static'};
 661
 662 # A single signature var can weld
 663 return Mojo::Promise->resolve($query_params)->then(&_reveal_event)->then(sub ($code) {
 664   return $c->render(text => '', status => $code);
 665 });
 666 #18...........
 667         },
 668
 669         'qw.def' => {
 670             source => "qw",
 671             params => "def",
 672             expect => <<'#19...........',
 673     # do not outdent ending ) more than initial qw line
 674     if ( $pos == 0 ) {
 675         @return = grep( /^$word/,
 676             sort qw(
 677               ! a b d h i m o q r u autobundle clean
 678               make test install force reload look
 679             ) );
 680     }
 681
 682     # outdent ')' even if opening is not '('
 683     @EXPORT = (
 684         qw)
 685           i Re Im rho theta arg
 686           sqrt log ln
 687           log10 logn cbrt root
 688           cplx cplxe
 689         ),
 690         @trig
 691     );
 692
 693     # outdent '>' like ')'
 694     @EXPORT = (
 695         qw<
 696           i Re Im rho theta arg
 697           sqrt log ln
 698           log10 logn cbrt root
 699           cplx cplxe
 700         >,
 701         @trig
 702     );
 703
 704     # but ';' not outdented
 705     @EXPORT = (
 706         qw;
 707           i Re Im rho theta arg
 708           sqrt log ln
 709           log10 logn cbrt root
 710           cplx cplxe
 711           ;,
 712         @trig
 713     );
 714 #19...........
 715         },
 716     };
 717
 718     my $ntests = 0 + keys %{$rtests};
 719     plan tests => $ntests;
 720 }
 721
 722 ###############
 723 # EXECUTE TESTS
 724 ###############
 725
 726 foreach my $key ( sort keys %{$rtests} ) {
 727     my $output;
 728     my $sname  = $rtests->{$key}->{source};
 729     my $expect = $rtests->{$key}->{expect};
 730     my $pname  = $rtests->{$key}->{params};
 731     my $source = $rsources->{$sname};
 732     my $params = defined($pname) ? $rparams->{$pname} : "";
 733     my $stderr_string;
 734     my $errorfile_string;
 735     my $err = Perl::Tidy::perltidy(
 736         source      => \$source,
 737         destination => \$output,
 738         perltidyrc  => \$params,
 739         argv        => '',             # for safety; hide any ARGV from perltidy
 740         stderr      => \$stderr_string,
 741         errorfile   => \$errorfile_string,    # not used when -se flag is set
 742     );
 743     if ( $err || $stderr_string || $errorfile_string ) {
 744         print STDERR "Error output received for test '$key'\n";
 745         if ($err) {
 746             print STDERR "An error flag '$err' was returned\n";
 747             ok( !$err );
 748         }
 749         if ($stderr_string) {
 750             print STDERR "---------------------\n";
 751             print STDERR "<<STDERR>>\n$stderr_string\n";
 752             print STDERR "---------------------\n";
 753             ok( !$stderr_string );
 754         }
 755         if ($errorfile_string) {
 756             print STDERR "---------------------\n";
 757             print STDERR "<<.ERR file>>\n$errorfile_string\n";
 758             print STDERR "---------------------\n";
 759             ok( !$errorfile_string );
 760         }
 761     }
 762     else {
 763         if ( !is( $output, $expect, $key ) ) {
 764             my $leno = length($output);
 765             my $lene = length($expect);
 766             if ( $leno == $lene ) {
 767                 print STDERR
 768 "#> Test '$key' gave unexpected output.  Strings differ but both have length $leno\n";
 769             }
 770             else {
 771                 print STDERR
 772 "#> Test '$key' gave unexpected output.  String lengths differ: output=$leno, expected=$lene\n";
 773             }
 774         }
 775     }
 776 }