t/snippets2.t

   1 # Created with: ./make_t.pl
   2
   3 # Contents:
   4 #1 angle.def
   5 #2 arrows1.def
   6 #3 arrows2.def
   7 #4 attrib1.def
   8 #5 attrib2.def
   9 #6 attrib3.def
  10 #7 bar1.bar
  11 #8 bar1.def
  12 #9 block1.def
  13 #10 boc1.boc
  14 #11 boc1.def
  15 #12 boc2.boc
  16 #13 boc2.def
  17 #14 break1.def
  18 #15 break2.def
  19 #16 break3.def
  20 #17 break4.def
  21 #18 carat.def
  22 #19 ce1.ce
  23 #20 ce1.def
  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         'bar' => "-bar",
  42         'boc' => "-boc",
  43         'ce'  => "-cuddled-blocks",
  44         'def' => "",
  45     };
  46
  47     ############################
  48     # BEGIN SECTION 2: Sources #
  49     ############################
  50     $rsources = {
  51
  52         'angle' => <<'----------',
  53 # This is an angle operator:
  54 @message_list =sort sort_algorithm < INDEX_FILE >;# angle operator
  55
  56 # Not an angle operator:
  57 # Patched added in guess routine for this case:
  58 if ( VERSION < 5.009 && $op->name eq 'aassign' ) {
  59 }
  60
  61 ----------
  62
  63         'arrows1' => <<'----------',
  64 # remove spaces around arrows
  65 my $obj = Bio::Variation::AAChange -> new;
  66 my $termcap = Term::Cap -> Tgetent( { TERM => undef } );
  67 ----------
  68
  69         'arrows2' => <<'----------',
  70 $_[ 0]-> Blue -> backColor(( $_[ 0]-> Blue -> backColor == cl::Blue ) ? cl::LightBlue  : cl::Blue );
  71 ----------
  72
  73         'attrib1' => <<'----------',
  74 sub be_careful () : locked method {
  75     my $self = shift;
  76
  77     # ...
  78 }
  79 ----------
  80
  81         'attrib2' => <<'----------',
  82 sub
  83 witch
  84 ()   # prototype may be on new line, but cannot put line break within prototype
  85 :
  86 locked
  87 {
  88         print "and your little dog ";
  89 }
  90 ----------
  91
  92         'attrib3' => <<'----------',
  93 package Canine;
  94 package Dog;
  95 my Canine $spot : Watchful ;
  96 package Felis;
  97 my $cat : Nervous;
  98 package X;
  99 sub foo : locked ;
 100 package X;
 101 sub Y::x : locked { 1 }
 102 package X;
 103 sub foo { 1 }
 104 package Y;
 105 BEGIN { *bar = \&X::foo; }
 106 package Z;
 107 sub Y::bar : locked ;
 108 ----------
 109
 110         'bar1' => <<'----------',
 111 if ($bigwasteofspace1 && $bigwasteofspace2 || $bigwasteofspace3 && $bigwasteofspace4) { }
 112 ----------
 113
 114         'block1' => <<'----------',
 115 # Some block tests
 116 print "start main running\n";
 117 die "main now dying\n";
 118 END {$a=6; print "1st end, a=$a\n"}
 119 CHECK {$a=8; print "1st check, a=$a\n"}
 120 INIT {$a=10; print "1st init, a=$a\n"}
 121 END {$a=12; print "2nd end, a=$a\n"}
 122 BEGIN {$a=14; print "1st begin, a=$a\n"}
 123 INIT {$a=16; print "2nd init, a=$a\n"}
 124 BEGIN {$a=18; print "2nd begin, a=$a\n"}
 125 CHECK {$a=20; print "2nd check, a=$a\n"}
 126 END {$a=23; print "3rd end, a=$a\n"}
 127
 128 ----------
 129
 130         'boc1' => <<'----------',
 131 # RT#98902
 132 # Running with -boc (break-at-old-comma-breakpoints) should not
 133 # allow forming a single line
 134 my @bar = map { {
 135      number => $_,
 136      character => chr $_,
 137      padding => (' ' x $_),
 138 } } ( 0 .. 32 );
 139 ----------
 140
 141         'boc2' => <<'----------',
 142 my @list = (
 143     1,
 144     1, 1,
 145     1, 2, 1,
 146     1, 3, 3, 1,
 147     1, 4, 6, 4, 1,);
 148
 149 ----------
 150
 151         'break1' => <<'----------',
 152     # break at ;
 153     $self->__print("*** Type 'p' now to show start up log\n") ;    # XXX add to banner?
 154 ----------
 155
 156         'break2' => <<'----------',
 157         # break before the '->'
 158         ( $current_feature_item->children )[0]->set( $current_feature->primary_tag );
 159         $sth->{'Database'}->{'xbase_tables'}->{ $parsed_sql->{'table'}[0] }->field_type($_);
 160 ----------
 161
 162         'break3' => <<'----------',
 163     # keep the anonymous hash block together:
 164     my $red_color = $widget->window->get_colormap->color_alloc( { red => 65000, green => 0, blue => 0 } );
 165 ----------
 166
 167         'break4' => <<'----------',
 168         spawn( "$LINTIAN_ROOT/unpack/list-binpkg", "$LINTIAN_LAB/info/binary-packages", $v ) == 0 or fail("cannot create binary package list");
 169 ----------
 170
 171         'carat' => <<'----------',
 172 my $a=${^WARNING_BITS};
 173 @{^HOWDY_PARDNER}=(101,102);
 174 ${^W} = 1;
 175 $bb[$^]] = "bubba";
 176 ----------
 177
 178         'ce1' => <<'----------',
 179 # test -ce with blank lines and comments between blocks
 180 if($value[0] =~ /^(\#)/){    # skip any comment line
 181   last SWITCH;
 182 }
 183
 184
 185 elsif($value[0] =~ /^(o)$/ or $value[0] =~ /^(os)$/){
 186   $os=$value[1];
 187   last SWITCH;
 188 }
 189
 190 elsif($value[0] =~ /^(b)$/ or $value[0] =~ /^(dbfile)$/)
 191
 192 # comment
 193 {
 194   $dbfile=$value[1];
 195   last SWITCH;
 196 # Add the additional site
 197 }else{
 198         $rebase_hash{$name} .= " $site";
 199 }
 200 ----------
 201     };
 202
 203     ####################################
 204     # BEGIN SECTION 3: Expected output #
 205     ####################################
 206     $rtests = {
 207
 208         'angle.def' => {
 209             source => "angle",
 210             params => "def",
 211             expect => <<'#1...........',
 212 # This is an angle operator:
 213 @message_list = sort sort_algorithm < INDEX_FILE >;    # angle operator
 214
 215 # Not an angle operator:
 216 # Patched added in guess routine for this case:
 217 if ( VERSION < 5.009 && $op->name eq 'aassign' ) {
 218 }
 219
 220 #1...........
 221         },
 222
 223         'arrows1.def' => {
 224             source => "arrows1",
 225             params => "def",
 226             expect => <<'#2...........',
 227 # remove spaces around arrows
 228 my $obj     = Bio::Variation::AAChange->new;
 229 my $termcap = Term::Cap->Tgetent( { TERM => undef } );
 230 #2...........
 231         },
 232
 233         'arrows2.def' => {
 234             source => "arrows2",
 235             params => "def",
 236             expect => <<'#3...........',
 237 $_[0]->Blue->backColor(
 238     ( $_[0]->Blue->backColor == cl::Blue ) ? cl::LightBlue : cl::Blue );
 239 #3...........
 240         },
 241
 242         'attrib1.def' => {
 243             source => "attrib1",
 244             params => "def",
 245             expect => <<'#4...........',
 246 sub be_careful () : locked method {
 247     my $self = shift;
 248
 249     # ...
 250 }
 251 #4...........
 252         },
 253
 254         'attrib2.def' => {
 255             source => "attrib2",
 256             params => "def",
 257             expect => <<'#5...........',
 258 sub witch
 259   ()  # prototype may be on new line, but cannot put line break within prototype
 260   : locked {
 261     print "and your little dog ";
 262 }
 263 #5...........
 264         },
 265
 266         'attrib3.def' => {
 267             source => "attrib3",
 268             params => "def",
 269             expect => <<'#6...........',
 270 package Canine;
 271
 272 package Dog;
 273 my Canine $spot : Watchful;
 274
 275 package Felis;
 276 my $cat : Nervous;
 277
 278 package X;
 279 sub foo : locked;
 280
 281 package X;
 282 sub Y::x : locked { 1 }
 283
 284 package X;
 285 sub foo { 1 }
 286
 287 package Y;
 288 BEGIN { *bar = \&X::foo; }
 289
 290 package Z;
 291 sub Y::bar : locked;
 292 #6...........
 293         },
 294
 295         'bar1.bar' => {
 296             source => "bar1",
 297             params => "bar",
 298             expect => <<'#7...........',
 299 if (   $bigwasteofspace1 && $bigwasteofspace2
 300     || $bigwasteofspace3 && $bigwasteofspace4 ) {
 301 }
 302 #7...........
 303         },
 304
 305         'bar1.def' => {
 306             source => "bar1",
 307             params => "def",
 308             expect => <<'#8...........',
 309 if (   $bigwasteofspace1 && $bigwasteofspace2
 310     || $bigwasteofspace3 && $bigwasteofspace4 )
 311 {
 312 }
 313 #8...........
 314         },
 315
 316         'block1.def' => {
 317             source => "block1",
 318             params => "def",
 319             expect => <<'#9...........',
 320 # Some block tests
 321 print "start main running\n";
 322 die "main now dying\n";
 323 END   { $a = 6;  print "1st end, a=$a\n" }
 324 CHECK { $a = 8;  print "1st check, a=$a\n" }
 325 INIT  { $a = 10; print "1st init, a=$a\n" }
 326 END   { $a = 12; print "2nd end, a=$a\n" }
 327 BEGIN { $a = 14; print "1st begin, a=$a\n" }
 328 INIT  { $a = 16; print "2nd init, a=$a\n" }
 329 BEGIN { $a = 18; print "2nd begin, a=$a\n" }
 330 CHECK { $a = 20; print "2nd check, a=$a\n" }
 331 END   { $a = 23; print "3rd end, a=$a\n" }
 332
 333 #9...........
 334         },
 335
 336         'boc1.boc' => {
 337             source => "boc1",
 338             params => "boc",
 339             expect => <<'#10...........',
 340 # RT#98902
 341 # Running with -boc (break-at-old-comma-breakpoints) should not
 342 # allow forming a single line
 343 my @bar = map {
 344     {
 345         number    => $_,
 346         character => chr $_,
 347         padding   => ( ' ' x $_ ),
 348     }
 349 } ( 0 .. 32 );
 350 #10...........
 351         },
 352
 353         'boc1.def' => {
 354             source => "boc1",
 355             params => "def",
 356             expect => <<'#11...........',
 357 # RT#98902
 358 # Running with -boc (break-at-old-comma-breakpoints) should not
 359 # allow forming a single line
 360 my @bar =
 361   map { { number => $_, character => chr $_, padding => ( ' ' x $_ ), } }
 362   ( 0 .. 32 );
 363 #11...........
 364         },
 365
 366         'boc2.boc' => {
 367             source => "boc2",
 368             params => "boc",
 369             expect => <<'#12...........',
 370 my @list = (
 371     1,
 372     1, 1,
 373     1, 2, 1,
 374     1, 3, 3, 1,
 375     1, 4, 6, 4, 1,
 376 );
 377
 378 #12...........
 379         },
 380
 381         'boc2.def' => {
 382             source => "boc2",
 383             params => "def",
 384             expect => <<'#13...........',
 385 my @list = ( 1, 1, 1, 1, 2, 1, 1, 3, 3, 1, 1, 4, 6, 4, 1, );
 386
 387 #13...........
 388         },
 389
 390         'break1.def' => {
 391             source => "break1",
 392             params => "def",
 393             expect => <<'#14...........',
 394     # break at ;
 395     $self->__print("*** Type 'p' now to show start up log\n")
 396       ;    # XXX add to banner?
 397 #14...........
 398         },
 399
 400         'break2.def' => {
 401             source => "break2",
 402             params => "def",
 403             expect => <<'#15...........',
 404         # break before the '->'
 405         ( $current_feature_item->children )[0]
 406           ->set( $current_feature->primary_tag );
 407         $sth->{'Database'}->{'xbase_tables'}->{ $parsed_sql->{'table'}[0] }
 408           ->field_type($_);
 409 #15...........
 410         },
 411
 412         'break3.def' => {
 413             source => "break3",
 414             params => "def",
 415             expect => <<'#16...........',
 416     # keep the anonymous hash block together:
 417     my $red_color = $widget->window->get_colormap->color_alloc(
 418         { red => 65000, green => 0, blue => 0 } );
 419 #16...........
 420         },
 421
 422         'break4.def' => {
 423             source => "break4",
 424             params => "def",
 425             expect => <<'#17...........',
 426         spawn( "$LINTIAN_ROOT/unpack/list-binpkg",
 427             "$LINTIAN_LAB/info/binary-packages", $v ) == 0
 428           or fail("cannot create binary package list");
 429 #17...........
 430         },
 431
 432         'carat.def' => {
 433             source => "carat",
 434             params => "def",
 435             expect => <<'#18...........',
 436 my $a = ${^WARNING_BITS};
 437 @{^HOWDY_PARDNER} = ( 101, 102 );
 438 ${^W}             = 1;
 439 $bb[$^]] = "bubba";
 440 #18...........
 441         },
 442
 443         'ce1.ce' => {
 444             source => "ce1",
 445             params => "ce",
 446             expect => <<'#19...........',
 447 # test -ce with blank lines and comments between blocks
 448 if ( $value[0] =~ /^(\#)/ ) {    # skip any comment line
 449     last SWITCH;
 450
 451 } elsif ( $value[0] =~ /^(o)$/ or $value[0] =~ /^(os)$/ ) {
 452     $os = $value[1];
 453     last SWITCH;
 454
 455 } elsif ( $value[0] =~ /^(b)$/ or $value[0] =~ /^(dbfile)$/ )
 456
 457   # comment
 458 {
 459     $dbfile = $value[1];
 460     last SWITCH;
 461
 462     # Add the additional site
 463 } else {
 464     $rebase_hash{$name} .= " $site";
 465 }
 466 #19...........
 467         },
 468
 469         'ce1.def' => {
 470             source => "ce1",
 471             params => "def",
 472             expect => <<'#20...........',
 473 # test -ce with blank lines and comments between blocks
 474 if ( $value[0] =~ /^(\#)/ ) {    # skip any comment line
 475     last SWITCH;
 476 }
 477
 478 elsif ( $value[0] =~ /^(o)$/ or $value[0] =~ /^(os)$/ ) {
 479     $os = $value[1];
 480     last SWITCH;
 481 }
 482
 483 elsif ( $value[0] =~ /^(b)$/ or $value[0] =~ /^(dbfile)$/ )
 484
 485   # comment
 486 {
 487     $dbfile = $value[1];
 488     last SWITCH;
 489
 490     # Add the additional site
 491 }
 492 else {
 493     $rebase_hash{$name} .= " $site";
 494 }
 495 #20...........
 496         },
 497     };
 498
 499     my $ntests = 0 + keys %{$rtests};
 500     plan tests => $ntests;
 501 }
 502
 503 ###############
 504 # EXECUTE TESTS
 505 ###############
 506
 507 foreach my $key ( sort keys %{$rtests} ) {
 508     my $output;
 509     my $sname  = $rtests->{$key}->{source};
 510     my $expect = $rtests->{$key}->{expect};
 511     my $pname  = $rtests->{$key}->{params};
 512     my $source = $rsources->{$sname};
 513     my $params = defined($pname) ? $rparams->{$pname} : "";
 514     my $stderr_string;
 515     my $errorfile_string;
 516     my $err = Perl::Tidy::perltidy(
 517         source      => \$source,
 518         destination => \$output,
 519         perltidyrc  => \$params,
 520         argv        => '',             # for safety; hide any ARGV from perltidy
 521         stderr      => \$stderr_string,
 522         errorfile => \$errorfile_string,    # not used when -se flag is set
 523     );
 524     if ( $err || $stderr_string || $errorfile_string ) {
 525         if ($err) {
 526             print STDERR
 527 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 528             ok( !$err );
 529         }
 530         if ($stderr_string) {
 531             print STDERR "---------------------\n";
 532             print STDERR "<<STDERR>>\n$stderr_string\n";
 533             print STDERR "---------------------\n";
 534             print STDERR
 535 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 536             ok( !$stderr_string );
 537         }
 538         if ($errorfile_string) {
 539             print STDERR "---------------------\n";
 540             print STDERR "<<.ERR file>>\n$errorfile_string\n";
 541             print STDERR "---------------------\n";
 542             print STDERR
 543 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 544             ok( !$errorfile_string );
 545         }
 546     }
 547     else {
 548         ok( $output, $expect );
 549     }
 550 }