t/snippets15.t

   1 # Created with: ./make_t.pl
   2
   3 # Contents:
   4 #1 gnu5.gnu
   5 #2 wngnu1.def
   6 #3 olbs.def
   7 #4 olbs.olbs0
   8 #5 olbs.olbs2
   9 #6 break_old_methods.break_old_methods
  10 #7 break_old_methods.def
  11 #8 bom1.bom
  12 #9 bom1.def
  13 #10 align28.def
  14 #11 align29.def
  15 #12 align30.def
  16 #13 git09.def
  17 #14 git09.git09
  18 #15 git14.def
  19 #16 sal.def
  20 #17 sal.sal
  21 #18 spp.def
  22 #19 spp.spp0
  23
  24 # To locate test #13 you can search for its name or the string '#13'
  25
  26 use strict;
  27 use Test;
  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         'bom'               => "-bom -wn",
  41         'break_old_methods' => "--break-at-old-method-breakpoints",
  42         'def'               => "",
  43         'git09'             => "-ce -cbl=map,sort,grep",
  44         'gnu'               => "-gnu",
  45         'olbs0'             => "-olbs=0",
  46         'olbs2'             => "-olbs=2",
  47         'sal'               => <<'----------',
  48 -sal='method fun'
  49 ----------
  50         'spp0' => "-spp=0",
  51     };
  52
  53     ############################
  54     # BEGIN SECTION 2: Sources #
  55     ############################
  56     $rsources = {
  57
  58         'align28' => <<'----------',
  59 # tests for 'delete_needless_parens'
  60 # align all '='s; but do not align parens
  61 my $w = $columns * $cell_w + ( $columns + 1 ) * $border;
  62 my $h = $rows * $cell_h + ( $rows + 1 ) * $border;
  63 my $img = new Gimp::Image( $w, $h, RGB );
  64
  65 # keep leading paren after if as alignment for padding
  66 eval {
  67     if   ( $a->{'abc'} eq 'ABC' ) { no_op(23) }
  68     else                          { no_op(42) }
  69 };
  70 ----------
  71
  72         'align29' => <<'----------',
  73 # alignment with lots of commas
  74 is( floor(1.23441242), 1, "Basic floor(1.23441242) test" );
  75 is( fmod( 3.5, 2.0 ), 1.5, "Basic fmod(3.5, 2.0) test" );
  76 is( join( " ", frexp(1) ), "0.5 1", "Basic frexp(1) test" );
  77 is( ldexp( 0, 1 ), 0, "Basic ldexp(0,1) test" );
  78 is( log10(1),  0, "Basic log10(1) test" );
  79 ----------
  80
  81         'align30' => <<'----------',
  82 # commas on lhs align, commas on rhs do not (different subs)
  83 ($x,$y,$z)=spherical_to_cartesian($rho,$theta,$phi);
  84 ($rho_c,$theta,$z)=spherical_to_cylindrical($rho_s,$theta,$phi);
  85 ( $r2, $theta2, $z2 )=cartesian_to_cylindrical( $x1, $y1, $z1 );
  86
  87 # two-line if/elsif gets aligned
  88 if($i==$depth){$_++;}
  89 elsif($i>$depth){$_=0;}
  90 ----------
  91
  92         'bom1' => <<'----------',
  93 # keep cuddled call chain with -bom
  94 return Mojo::Promise->resolve(
  95     $query_params
  96 )->then(
  97     &_reveal_event
  98 )->then(sub ($code) {
  99     return $c->render(text => '', status => $code);
 100 })->catch(sub {
 101     # 1. return error
 102     return $c->render(json => {}, status => 400);
 103 });
 104 ----------
 105
 106         'break_old_methods' => <<'----------',
 107 my $q = $rs
 108    ->related_resultset('CDs')
 109    ->related_resultset('Tracks')
 110    ->search({
 111       'track.id' => { -ident => 'none_search.id' },
 112    })
 113    ->as_query;
 114 ----------
 115
 116         'git09' => <<'----------',
 117 # no one-line block for first map with -ce -cbl=map,sort,grep
 118 @sorted = map {
 119     $_->[0]
 120 } sort {
 121     $a->[1] <=> $b->[1] or $a->[0] cmp $b->[0]
 122 } map {
 123     [$_, length($_)]
 124 } @unsorted;
 125 ----------
 126
 127         'git14' => <<'----------',
 128 # git#14; do not break at trailing 'or'
 129 $second = {
 130     key1 => 'aaa',
 131     key2 => 'bbb',
 132 } if $flag1 or $flag2;
 133 ----------
 134
 135         'gnu5' => <<'----------',
 136         # side comments limit gnu type formatting with l=80; note extra comma
 137         push @tests, [
 138             "Lowest code point requiring 13 bytes to represent",    # 2**36
 139             "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
 140             ($::is64bit) ? 0x1000000000 : -1,    # overflows on 32bit
 141           ],
 142           ;
 143 ----------
 144
 145         'olbs' => <<'----------',
 146 for $x ( 1, 2 ) { s/(.*)/+$1/ }
 147 for $x ( 1, 2 ) { s/(.*)/+$1/ }    # side comment
 148 if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked" }
 149 for $x ( 1, 2 ) { s/(.*)/+$1/; }
 150 for $x ( 1, 2 ) { s/(.*)/+$1/; }    # side comment
 151 if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked"; }
 152 ----------
 153
 154         'sal' => <<'----------',
 155 sub get_val () {
 156
 157 }
 158
 159 method get_value () {
 160
 161 }
 162
 163 fun get_other_value () {
 164
 165 }
 166 ----------
 167
 168         'spp' => <<'----------',
 169 sub get_val() { }
 170
 171 sub get_Val  () { }
 172
 173 sub Get_val             () { }
 174 ----------
 175
 176         'wngnu1' => <<'----------',
 177     # test with -wn -gnu
 178     foreach my $parameter (
 179         qw(
 180         set_themes
 181         add_themes
 182         severity
 183         maximum_violations_per_document
 184         _non_public_data
 185         )
 186       )
 187     {
 188         is(
 189             $config->get($parameter),
 190             undef,
 191             qq<"$parameter" is not defined via get() for $policy_short_name.>,
 192         );
 193     }
 194 ----------
 195     };
 196
 197     ####################################
 198     # BEGIN SECTION 3: Expected output #
 199     ####################################
 200     $rtests = {
 201
 202         'gnu5.gnu' => {
 203             source => "gnu5",
 204             params => "gnu",
 205             expect => <<'#1...........',
 206         # side comments limit gnu type formatting with l=80; note extra comma
 207         push @tests, [
 208             "Lowest code point requiring 13 bytes to represent",      # 2**36
 209             "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
 210             ($::is64bit) ? 0x1000000000 : -1,    # overflows on 32bit
 211                      ],
 212           ;
 213 #1...........
 214         },
 215
 216         'wngnu1.def' => {
 217             source => "wngnu1",
 218             params => "def",
 219             expect => <<'#2...........',
 220     # test with -wn -gnu
 221     foreach my $parameter (
 222         qw(
 223         set_themes
 224         add_themes
 225         severity
 226         maximum_violations_per_document
 227         _non_public_data
 228         )
 229       )
 230     {
 231         is(
 232             $config->get($parameter),
 233             undef,
 234             qq<"$parameter" is not defined via get() for $policy_short_name.>,
 235         );
 236     }
 237 #2...........
 238         },
 239
 240         'olbs.def' => {
 241             source => "olbs",
 242             params => "def",
 243             expect => <<'#3...........',
 244 for $x ( 1, 2 ) { s/(.*)/+$1/ }
 245 for $x ( 1, 2 ) { s/(.*)/+$1/ }    # side comment
 246 if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked" }
 247 for $x ( 1, 2 ) { s/(.*)/+$1/; }
 248 for $x ( 1, 2 ) { s/(.*)/+$1/; }    # side comment
 249 if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked"; }
 250 #3...........
 251         },
 252
 253         'olbs.olbs0' => {
 254             source => "olbs",
 255             params => "olbs0",
 256             expect => <<'#4...........',
 257 for $x ( 1, 2 ) { s/(.*)/+$1/ }
 258 for $x ( 1, 2 ) { s/(.*)/+$1/ }    # side comment
 259 if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked" }
 260 for $x ( 1, 2 ) { s/(.*)/+$1/ }
 261 for $x ( 1, 2 ) { s/(.*)/+$1/ }    # side comment
 262 if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked"; }
 263 #4...........
 264         },
 265
 266         'olbs.olbs2' => {
 267             source => "olbs",
 268             params => "olbs2",
 269             expect => <<'#5...........',
 270 for $x ( 1, 2 ) { s/(.*)/+$1/; }
 271 for $x ( 1, 2 ) { s/(.*)/+$1/; }    # side comment
 272 if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked"; }
 273 for $x ( 1, 2 ) { s/(.*)/+$1/; }
 274 for $x ( 1, 2 ) { s/(.*)/+$1/; }    # side comment
 275 if ( $editlblk eq 1 ) { $editlblk = "on"; $editlblkchecked = "checked"; }
 276 #5...........
 277         },
 278
 279         'break_old_methods.break_old_methods' => {
 280             source => "break_old_methods",
 281             params => "break_old_methods",
 282             expect => <<'#6...........',
 283 my $q = $rs
 284   ->related_resultset('CDs')
 285   ->related_resultset('Tracks')
 286   ->search(
 287     {
 288         'track.id' => { -ident => 'none_search.id' },
 289     }
 290 )->as_query;
 291 #6...........
 292         },
 293
 294         'break_old_methods.def' => {
 295             source => "break_old_methods",
 296             params => "def",
 297             expect => <<'#7...........',
 298 my $q = $rs->related_resultset('CDs')->related_resultset('Tracks')->search(
 299     {
 300         'track.id' => { -ident => 'none_search.id' },
 301     }
 302 )->as_query;
 303 #7...........
 304         },
 305
 306         'bom1.bom' => {
 307             source => "bom1",
 308             params => "bom",
 309             expect => <<'#8...........',
 310 # keep cuddled call chain with -bom
 311 return Mojo::Promise->resolve(
 312     $query_params
 313 )->then(
 314     &_reveal_event
 315 )->then( sub ($code) {
 316     return $c->render( text => '', status => $code );
 317 } )->catch( sub {
 318
 319     # 1. return error
 320     return $c->render( json => {}, status => 400 );
 321 } );
 322 #8...........
 323         },
 324
 325         'bom1.def' => {
 326             source => "bom1",
 327             params => "def",
 328             expect => <<'#9...........',
 329 # keep cuddled call chain with -bom
 330 return Mojo::Promise->resolve($query_params)->then(&_reveal_event)->then(
 331     sub ($code) {
 332         return $c->render( text => '', status => $code );
 333     }
 334 )->catch(
 335     sub {
 336         # 1. return error
 337         return $c->render( json => {}, status => 400 );
 338     }
 339 );
 340 #9...........
 341         },
 342
 343         'align28.def' => {
 344             source => "align28",
 345             params => "def",
 346             expect => <<'#10...........',
 347 # tests for 'delete_needless_parens'
 348 # align all '='s; but do not align parens
 349 my $w   = $columns * $cell_w + ( $columns + 1 ) * $border;
 350 my $h   = $rows * $cell_h + ( $rows + 1 ) * $border;
 351 my $img = new Gimp::Image( $w, $h, RGB );
 352
 353 # keep leading paren after if as alignment for padding
 354 eval {
 355     if   ( $a->{'abc'} eq 'ABC' ) { no_op(23) }
 356     else                          { no_op(42) }
 357 };
 358 #10...........
 359         },
 360
 361         'align29.def' => {
 362             source => "align29",
 363             params => "def",
 364             expect => <<'#11...........',
 365 # alignment with lots of commas
 366 is( floor(1.23441242),     1,       "Basic floor(1.23441242) test" );
 367 is( fmod( 3.5, 2.0 ),      1.5,     "Basic fmod(3.5, 2.0) test" );
 368 is( join( " ", frexp(1) ), "0.5 1", "Basic frexp(1) test" );
 369 is( ldexp( 0, 1 ),         0,       "Basic ldexp(0,1) test" );
 370 is( log10(1),              0,       "Basic log10(1) test" );
 371 #11...........
 372         },
 373
 374         'align30.def' => {
 375             source => "align30",
 376             params => "def",
 377             expect => <<'#12...........',
 378 # commas on lhs align, commas on rhs do not (different subs)
 379 ( $x,     $y,      $z )  = spherical_to_cartesian( $rho, $theta, $phi );
 380 ( $rho_c, $theta,  $z )  = spherical_to_cylindrical( $rho_s, $theta, $phi );
 381 ( $r2,    $theta2, $z2 ) = cartesian_to_cylindrical( $x1, $y1, $z1 );
 382
 383 # two-line if/elsif gets aligned
 384 if    ( $i == $depth ) { $_++; }
 385 elsif ( $i > $depth )  { $_ = 0; }
 386 #12...........
 387         },
 388
 389         'git09.def' => {
 390             source => "git09",
 391             params => "def",
 392             expect => <<'#13...........',
 393 # no one-line block for first map with -ce -cbl=map,sort,grep
 394 @sorted =
 395   map  { $_->[0] }
 396   sort { $a->[1] <=> $b->[1] or $a->[0] cmp $b->[0] }
 397   map  { [ $_, length($_) ] } @unsorted;
 398 #13...........
 399         },
 400
 401         'git09.git09' => {
 402             source => "git09",
 403             params => "git09",
 404             expect => <<'#14...........',
 405 # no one-line block for first map with -ce -cbl=map,sort,grep
 406 @sorted = map {
 407     $_->[0]
 408 } sort {
 409     $a->[1] <=> $b->[1] or $a->[0] cmp $b->[0]
 410 } map {
 411     [ $_, length($_) ]
 412 } @unsorted;
 413 #14...........
 414         },
 415
 416         'git14.def' => {
 417             source => "git14",
 418             params => "def",
 419             expect => <<'#15...........',
 420 # git#14; do not break at trailing 'or'
 421 $second = {
 422     key1 => 'aaa',
 423     key2 => 'bbb',
 424 } if $flag1 or $flag2;
 425 #15...........
 426         },
 427
 428         'sal.def' => {
 429             source => "sal",
 430             params => "def",
 431             expect => <<'#16...........',
 432 sub get_val () {
 433
 434 }
 435
 436 method get_value() {
 437
 438 }
 439
 440 fun get_other_value() {
 441
 442 }
 443 #16...........
 444         },
 445
 446         'sal.sal' => {
 447             source => "sal",
 448             params => "sal",
 449             expect => <<'#17...........',
 450 sub get_val () {
 451
 452 }
 453
 454 method get_value () {
 455
 456 }
 457
 458 fun get_other_value () {
 459
 460 }
 461 #17...........
 462         },
 463
 464         'spp.def' => {
 465             source => "spp",
 466             params => "def",
 467             expect => <<'#18...........',
 468 sub get_val() { }
 469
 470 sub get_Val () { }
 471
 472 sub Get_val () { }
 473 #18...........
 474         },
 475
 476         'spp.spp0' => {
 477             source => "spp",
 478             params => "spp0",
 479             expect => <<'#19...........',
 480 sub get_val() { }
 481
 482 sub get_Val() { }
 483
 484 sub Get_val() { }
 485 #19...........
 486         },
 487     };
 488
 489     my $ntests = 0 + keys %{$rtests};
 490     plan tests => $ntests;
 491 }
 492
 493 ###############
 494 # EXECUTE TESTS
 495 ###############
 496
 497 foreach my $key ( sort keys %{$rtests} ) {
 498     my $output;
 499     my $sname  = $rtests->{$key}->{source};
 500     my $expect = $rtests->{$key}->{expect};
 501     my $pname  = $rtests->{$key}->{params};
 502     my $source = $rsources->{$sname};
 503     my $params = defined($pname) ? $rparams->{$pname} : "";
 504     my $stderr_string;
 505     my $errorfile_string;
 506     my $err = Perl::Tidy::perltidy(
 507         source      => \$source,
 508         destination => \$output,
 509         perltidyrc  => \$params,
 510         argv        => '',             # for safety; hide any ARGV from perltidy
 511         stderr      => \$stderr_string,
 512         errorfile => \$errorfile_string,    # not used when -se flag is set
 513     );
 514     if ( $err || $stderr_string || $errorfile_string ) {
 515         if ($err) {
 516             print STDERR
 517 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 518             ok( !$err );
 519         }
 520         if ($stderr_string) {
 521             print STDERR "---------------------\n";
 522             print STDERR "<<STDERR>>\n$stderr_string\n";
 523             print STDERR "---------------------\n";
 524             print STDERR
 525 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 526             ok( !$stderr_string );
 527         }
 528         if ($errorfile_string) {
 529             print STDERR "---------------------\n";
 530             print STDERR "<<.ERR file>>\n$errorfile_string\n";
 531             print STDERR "---------------------\n";
 532             print STDERR
 533 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 534             ok( !$errorfile_string );
 535         }
 536     }
 537     else {
 538         ok( $output, $expect );
 539     }
 540 }