t/snippets11.t

   1 # Created with: ./make_t.pl
   2
   3 # Contents:
   4 #1 sub1.def
   5 #2 sub2.def
   6 #3 switch1.def
   7 #4 syntax1.def
   8 #5 syntax2.def
   9 #6 ternary1.def
  10 #7 ternary2.def
  11 #8 tick1.def
  12 #9 trim_quote.def
  13 #10 tso1.def
  14 #11 tso1.tso
  15 #12 tutor.def
  16 #13 undoci1.def
  17 #14 use1.def
  18 #15 use2.def
  19 #16 version1.def
  20 #17 version2.def
  21 #18 vert.def
  22 #19 vmll.def
  23 #20 vmll.vmll
  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         'tso'  => "-tso",
  43         'vmll' => <<'----------',
  44 -vmll
  45 -bbt=2
  46 -bt=2
  47 -pt=2
  48 -sbt=2
  49 ----------
  50     };
  51
  52     ############################
  53     # BEGIN SECTION 2: Sources #
  54     ############################
  55     $rsources = {
  56
  57         'sub1' => <<'----------',
  58 my::doit();
  59 join::doit();
  60 for::doit();
  61 sub::doit();
  62 package::doit();
  63 __END__::doit();
  64 __DATA__::doit();
  65 package my;
  66 sub doit{print"Hello My\n";}package join;
  67 sub doit{print"Hello Join\n";}package for;
  68 sub doit{print"Hello for\n";}package package;
  69 sub doit{print"Hello package\n";}package sub;
  70 sub doit{print"Hello sub\n";}package __END__;
  71 sub doit{print"Hello __END__\n";}package __DATA__;
  72 sub doit{print"Hello __DATA__\n";}
  73 ----------
  74
  75         'sub2' => <<'----------',
  76 my $selector;
  77
  78 # leading atrribute separator:
  79 $a =
  80   sub
  81   : locked {
  82     print "Hello, World!\n";
  83   };
  84 $a->();
  85
  86 # colon as both ?/: and attribute separator
  87 $a = $selector
  88   ? sub  : locked {
  89     print "Hello, World!\n";
  90   }
  91   : sub : locked {
  92     print "GOODBYE!\n";
  93   };
  94 $a->();
  95 ----------
  96
  97         'switch1' => <<'----------',
  98 sub classify_digit($digit)
  99   { switch($digit)
 100     { case 0 { return 'zero' } case [ 2, 4, 6, 8 ]{ return 'even' }
 101         case [ 1, 3, 4, 7, 9 ]{ return 'odd' } case /[A-F]/i { return 'hex' } }
 102   }
 103 ----------
 104
 105         'syntax1' => <<'----------',
 106 # Caused trouble:
 107 print $x **2;
 108 ----------
 109
 110         'syntax2' => <<'----------',
 111 # ? was taken as pattern
 112 my $case_flag = File::Spec->case_tolerant ? '(?i)' : '';
 113 ----------
 114
 115         'ternary1' => <<'----------',
 116 my $flags =
 117   ( $_ & 1 ) ? ( $_ & 4 ) ? $THRf_DEAD : $THRf_ZOMBIE :
 118   ( $_ & 4 ) ? $THRf_R_DETACHED : $THRf_R_JOINABLE;
 119 ----------
 120
 121         'ternary2' => <<'----------',
 122 my $a=($b) ? ($c) ? ($d) ? $d1
 123                          : $d2
 124                   : ($e) ? $e1
 125                          : $e2
 126            : ($f) ? ($g) ? $g1
 127                          : $g2
 128                   : ($h) ? $h1
 129                          : $h2;
 130 ----------
 131
 132         'tick1' => <<'----------',
 133 sub a'this { $p'u'a = "mooo\n"; print $p::u::a; }
 134 a::this();       # print "mooo"
 135 print $p'u'a;    # print "mooo"
 136 sub a::that {
 137     $p't'u = "wwoo\n";
 138     return sub { print $p't'u}
 139 }
 140 $a'that = a'that();
 141 $a'that->();     # print "wwoo"
 142 $a'that  = a'that();
 143 $p::t::u = "booo\n";
 144 $a'that->();     # print "booo"
 145 ----------
 146
 147         'trim_quote' => <<'----------',
 148 # space after quote will get trimmed
 149     push @m, '
 150 all :: pure_all manifypods
 151         ' . $self->{NOECHO} . '$(NOOP)
 152 '
 153       unless $self->{SKIPHASH}{'all'};
 154 ----------
 155
 156         'tso1' => <<'----------',
 157 print 0+ '42 EUR';    # 42
 158 ----------
 159
 160         'tutor' => <<'----------',
 161 #!/usr/bin/perl
 162 $y=shift||5;for $i(1..10){$l[$i]="T";$w[$i]=999999;}while(1){print"Name:";$u=<STDIN>;$t=50;$a=time;for(0..9){$x="";for(1..$y){$x.=chr(int(rand(126-33)+33));}while($z ne $x){print"\r\n$x\r\n";$z=<STDIN>;chomp($z);$t-=5;}}$b=time;$t-=($b-$a)*2;$t=0-$t;$z=1;@q=@l;@p=@w;print "You scored $t points\r\nTopTen\r\n";for $i(1..10){if ($t<$p[$z]){$l[$i]=$u;chomp($l[$i]);$w[$i]=$t;$t=1000000}else{$l[$i]=$q[$z];$w[$i]=$p[$z];$z++;}print $l[$i],"\t",$w[$i],"\r\n";}}
 163 ----------
 164
 165         'undoci1' => <<'----------',
 166         $rinfo{deleteStyle} = [
 167             -fill      => 'red',
 168               -stipple => '@' . Tk->findINC('demos/images/grey.25'),
 169         ];
 170 ----------
 171
 172         'use1' => <<'----------',
 173 # previously this caused an incorrect error message after '2.42'
 174 use lib "$Common::global::gInstallRoot/lib";
 175 use CGI 2.42 qw(fatalsToBrowser);
 176 use RRDs 1.000101;
 177
 178 # the 0666 must expect an operator
 179 use constant MODE => do { 0666 & ( 0777 & ~umask ) };
 180
 181 use IO::File ();
 182 ----------
 183
 184         'use2' => <<'----------',
 185 # Keep the space before the '()' here:
 186 use Foo::Bar ();
 187 use Foo::Bar ();
 188 use Foo::Bar 1.0 ();
 189 use Foo::Bar qw(baz);
 190 use Foo::Bar 1.0 qw(baz);
 191 ----------
 192
 193         'version1' => <<'----------',
 194 # VERSION statement unbroken, no semicolon added;
 195 our $VERSION = do { my @r = ( q$Revision: 2.2 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r }
 196 ----------
 197
 198         'version2' => <<'----------',
 199 # On one line so MakeMaker will see it.
 200 require Exporter; our $VERSION = $Exporter::VERSION;
 201 ----------
 202
 203         'vert' => <<'----------',
 204 # if $w->vert is tokenized as type 'U' then the ? will start a quote
 205 # and an error will occur.
 206 sub vert {
 207 }
 208 sub Restore {
 209     $w->vert ? $w->delta_width(0) : $w->delta_height(0);
 210 }
 211 ----------
 212
 213         'vmll' => <<'----------',
 214     # perltidy -act=2 -vmll will leave these intact and greater than 80 columns
 215     # in length, which is what vmll does
 216     BEGIN {is_deeply(\@init_metas_called, [1]) || diag(Dumper(\@init_metas_called))}
 217
 218     This has the comma on the next line
 219     exception {Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo)},
 220 ----------
 221     };
 222
 223     ####################################
 224     # BEGIN SECTION 3: Expected output #
 225     ####################################
 226     $rtests = {
 227
 228         'sub1.def' => {
 229             source => "sub1",
 230             params => "def",
 231             expect => <<'#1...........',
 232 my::doit();
 233 join::doit();
 234 for::doit();
 235 sub::doit();
 236 package::doit();
 237 __END__::doit();
 238 __DATA__::doit();
 239
 240 package my;
 241 sub doit { print "Hello My\n"; }
 242
 243 package join;
 244 sub doit { print "Hello Join\n"; }
 245
 246 package for;
 247 sub doit { print "Hello for\n"; }
 248
 249 package package;
 250 sub doit { print "Hello package\n"; }
 251
 252 package sub;
 253 sub doit { print "Hello sub\n"; }
 254
 255 package __END__;
 256 sub doit { print "Hello __END__\n"; }
 257
 258 package __DATA__;
 259 sub doit { print "Hello __DATA__\n"; }
 260 #1...........
 261         },
 262
 263         'sub2.def' => {
 264             source => "sub2",
 265             params => "def",
 266             expect => <<'#2...........',
 267 my $selector;
 268
 269 # leading atrribute separator:
 270 $a = sub
 271   : locked {
 272     print "Hello, World!\n";
 273   };
 274 $a->();
 275
 276 # colon as both ?/: and attribute separator
 277 $a = $selector
 278   ? sub : locked {
 279     print "Hello, World!\n";
 280   }
 281   : sub : locked {
 282     print "GOODBYE!\n";
 283   };
 284 $a->();
 285 #2...........
 286         },
 287
 288         'switch1.def' => {
 289             source => "switch1",
 290             params => "def",
 291             expect => <<'#3...........',
 292 sub classify_digit($digit) {
 293     switch ($digit) {
 294         case 0 { return 'zero' }
 295         case [ 2, 4, 6, 8 ]{ return 'even' }
 296         case [ 1, 3, 4, 7, 9 ]{ return 'odd' }
 297         case /[A-F]/i { return 'hex' }
 298     }
 299 }
 300 #3...........
 301         },
 302
 303         'syntax1.def' => {
 304             source => "syntax1",
 305             params => "def",
 306             expect => <<'#4...........',
 307 # Caused trouble:
 308 print $x **2;
 309 #4...........
 310         },
 311
 312         'syntax2.def' => {
 313             source => "syntax2",
 314             params => "def",
 315             expect => <<'#5...........',
 316 # ? was taken as pattern
 317 my $case_flag = File::Spec->case_tolerant ? '(?i)' : '';
 318 #5...........
 319         },
 320
 321         'ternary1.def' => {
 322             source => "ternary1",
 323             params => "def",
 324             expect => <<'#6...........',
 325 my $flags =
 326     ( $_ & 1 )
 327   ? ( $_ & 4 )
 328       ? $THRf_DEAD
 329       : $THRf_ZOMBIE
 330   : ( $_ & 4 ) ? $THRf_R_DETACHED
 331   :              $THRf_R_JOINABLE;
 332 #6...........
 333         },
 334
 335         'ternary2.def' => {
 336             source => "ternary2",
 337             params => "def",
 338             expect => <<'#7...........',
 339 my $a =
 340     ($b)
 341   ? ($c)
 342       ? ($d)
 343           ? $d1
 344           : $d2
 345       : ($e) ? $e1
 346     : $e2
 347   : ($f) ? ($g)
 348       ? $g1
 349       : $g2
 350   : ($h) ? $h1
 351   :        $h2;
 352 #7...........
 353         },
 354
 355         'tick1.def' => {
 356             source => "tick1",
 357             params => "def",
 358             expect => <<'#8...........',
 359 sub a'this { $p'u'a = "mooo\n"; print $p::u::a; }
 360 a::this();       # print "mooo"
 361 print $p'u'a;    # print "mooo"
 362
 363 sub a::that {
 364     $p't'u = "wwoo\n";
 365     return sub { print $p't'u}
 366 }
 367 $a'that = a'that();
 368 $a'that->();     # print "wwoo"
 369 $a'that  = a'that();
 370 $p::t::u = "booo\n";
 371 $a'that->();     # print "booo"
 372 #8...........
 373         },
 374
 375         'trim_quote.def' => {
 376             source => "trim_quote",
 377             params => "def",
 378             expect => <<'#9...........',
 379     # space after quote will get trimmed
 380     push @m, '
 381 all :: pure_all manifypods
 382         ' . $self->{NOECHO} . '$(NOOP)
 383 '
 384       unless $self->{SKIPHASH}{'all'};
 385 #9...........
 386         },
 387
 388         'tso1.def' => {
 389             source => "tso1",
 390             params => "def",
 391             expect => <<'#10...........',
 392 print 0 + '42 EUR';    # 42
 393 #10...........
 394         },
 395
 396         'tso1.tso' => {
 397             source => "tso1",
 398             params => "tso",
 399             expect => <<'#11...........',
 400 print 0+ '42 EUR';    # 42
 401 #11...........
 402         },
 403
 404         'tutor.def' => {
 405             source => "tutor",
 406             params => "def",
 407             expect => <<'#12...........',
 408 #!/usr/bin/perl
 409 $y = shift || 5;
 410 for $i ( 1 .. 10 ) { $l[$i] = "T"; $w[$i] = 999999; }
 411 while (1) {
 412     print "Name:";
 413     $u = <STDIN>;
 414     $t = 50;
 415     $a = time;
 416     for ( 0 .. 9 ) {
 417         $x = "";
 418         for ( 1 .. $y ) { $x .= chr( int( rand( 126 - 33 ) + 33 ) ); }
 419         while ( $z ne $x ) {
 420             print "\r\n$x\r\n";
 421             $z = <STDIN>;
 422             chomp($z);
 423             $t -= 5;
 424         }
 425     }
 426     $b = time;
 427     $t -= ( $b - $a ) * 2;
 428     $t = 0 - $t;
 429     $z = 1;
 430     @q = @l;
 431     @p = @w;
 432     print "You scored $t points\r\nTopTen\r\n";
 433
 434     for $i ( 1 .. 10 ) {
 435         if ( $t < $p[$z] ) {
 436             $l[$i] = $u;
 437             chomp( $l[$i] );
 438             $w[$i] = $t;
 439             $t = 1000000;
 440         }
 441         else { $l[$i] = $q[$z]; $w[$i] = $p[$z]; $z++; }
 442         print $l[$i], "\t", $w[$i], "\r\n";
 443     }
 444 }
 445 #12...........
 446         },
 447
 448         'undoci1.def' => {
 449             source => "undoci1",
 450             params => "def",
 451             expect => <<'#13...........',
 452         $rinfo{deleteStyle} = [
 453             -fill    => 'red',
 454             -stipple => '@' . Tk->findINC('demos/images/grey.25'),
 455         ];
 456 #13...........
 457         },
 458
 459         'use1.def' => {
 460             source => "use1",
 461             params => "def",
 462             expect => <<'#14...........',
 463 # previously this caused an incorrect error message after '2.42'
 464 use lib "$Common::global::gInstallRoot/lib";
 465 use CGI 2.42 qw(fatalsToBrowser);
 466 use RRDs 1.000101;
 467
 468 # the 0666 must expect an operator
 469 use constant MODE => do { 0666 & ( 0777 & ~umask ) };
 470
 471 use IO::File ();
 472 #14...........
 473         },
 474
 475         'use2.def' => {
 476             source => "use2",
 477             params => "def",
 478             expect => <<'#15...........',
 479 # Keep the space before the '()' here:
 480 use Foo::Bar ();
 481 use Foo::Bar ();
 482 use Foo::Bar 1.0 ();
 483 use Foo::Bar qw(baz);
 484 use Foo::Bar 1.0 qw(baz);
 485 #15...........
 486         },
 487
 488         'version1.def' => {
 489             source => "version1",
 490             params => "def",
 491             expect => <<'#16...........',
 492 # VERSION statement unbroken, no semicolon added;
 493 our $VERSION = do { my @r = ( q$Revision: 2.2 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r }
 494 #16...........
 495         },
 496
 497         'version2.def' => {
 498             source => "version2",
 499             params => "def",
 500             expect => <<'#17...........',
 501 # On one line so MakeMaker will see it.
 502 require Exporter; our $VERSION = $Exporter::VERSION;
 503 #17...........
 504         },
 505
 506         'vert.def' => {
 507             source => "vert",
 508             params => "def",
 509             expect => <<'#18...........',
 510 # if $w->vert is tokenized as type 'U' then the ? will start a quote
 511 # and an error will occur.
 512 sub vert {
 513 }
 514
 515 sub Restore {
 516     $w->vert ? $w->delta_width(0) : $w->delta_height(0);
 517 }
 518 #18...........
 519         },
 520
 521         'vmll.def' => {
 522             source => "vmll",
 523             params => "def",
 524             expect => <<'#19...........',
 525     # perltidy -act=2 -vmll will leave these intact and greater than 80 columns
 526     # in length, which is what vmll does
 527     BEGIN {
 528         is_deeply( \@init_metas_called, [1] )
 529           || diag( Dumper( \@init_metas_called ) );
 530     }
 531
 532     This has the comma on the next line exception {
 533         Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo)
 534     },
 535 #19...........
 536         },
 537
 538         'vmll.vmll' => {
 539             source => "vmll",
 540             params => "vmll",
 541             expect => <<'#20...........',
 542     # perltidy -act=2 -vmll will leave these intact and greater than 80 columns
 543     # in length, which is what vmll does
 544     BEGIN {is_deeply(\@init_metas_called, [1]) || diag(Dumper(\@init_metas_called))}
 545
 546     This has the comma on the next line exception {
 547         Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo)
 548     },
 549 #20...........
 550         },
 551     };
 552
 553     my $ntests = 0 + keys %{$rtests};
 554     plan tests => $ntests;
 555 }
 556
 557 ###############
 558 # EXECUTE TESTS
 559 ###############
 560
 561 foreach my $key ( sort keys %{$rtests} ) {
 562     my $output;
 563     my $sname  = $rtests->{$key}->{source};
 564     my $expect = $rtests->{$key}->{expect};
 565     my $pname  = $rtests->{$key}->{params};
 566     my $source = $rsources->{$sname};
 567     my $params = defined($pname) ? $rparams->{$pname} : "";
 568     my $stderr_string;
 569     my $errorfile_string;
 570     my $err = Perl::Tidy::perltidy(
 571         source      => \$source,
 572         destination => \$output,
 573         perltidyrc  => \$params,
 574         argv        => '',             # for safety; hide any ARGV from perltidy
 575         stderr      => \$stderr_string,
 576         errorfile => \$errorfile_string,    # not used when -se flag is set
 577     );
 578     if ( $err || $stderr_string || $errorfile_string ) {
 579         if ($err) {
 580             print STDERR
 581 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 582             ok( !$err );
 583         }
 584         if ($stderr_string) {
 585             print STDERR "---------------------\n";
 586             print STDERR "<<STDERR>>\n$stderr_string\n";
 587             print STDERR "---------------------\n";
 588             print STDERR
 589 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 590             ok( !$stderr_string );
 591         }
 592         if ($errorfile_string) {
 593             print STDERR "---------------------\n";
 594             print STDERR "<<.ERR file>>\n$errorfile_string\n";
 595             print STDERR "---------------------\n";
 596             print STDERR
 597 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 598             ok( !$errorfile_string );
 599         }
 600     }
 601     else {
 602         ok( $output, $expect );
 603     }
 604 }