t/snippets8.t

   1 # Created with: ./make_t.pl
   2
   3 # Contents:
   4 #1 rt123749.rt123749
   5 #2 rt123774.def
   6 #3 rt124114.def
   7 #4 rt124354.def
   8 #5 rt124354.rt124354
   9 #6 rt125012.def
  10 #7 rt125012.rt125012
  11 #8 rt125506.def
  12 #9 rt125506.rt125506
  13 #10 rt126965.def
  14 #11 rt15735.def
  15 #12 rt18318.def
  16 #13 rt18318.rt18318
  17 #14 rt27000.def
  18 #15 rt31741.def
  19 #16 rt49289.def
  20 #17 rt50702.def
  21 #18 rt50702.rt50702
  22 #19 rt68870.def
  23 #20 rt70747.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         'def'      => "",
  42         'rt123749' => "-wn",
  43         'rt124354' => "-io",
  44         'rt125012' => <<'----------',
  45 -mangle
  46 -dac
  47 ----------
  48         'rt125506' => "-io",
  49         'rt18318'  => <<'----------',
  50 -nwrs='A'
  51 ----------
  52         'rt50702' => <<'----------',
  53 -wbb='='
  54 ----------
  55     };
  56
  57     ############################
  58     # BEGIN SECTION 2: Sources #
  59     ############################
  60     $rsources = {
  61
  62         'rt123749' => <<'----------',
  63 get('http://mojolicious.org')->then(
  64     sub {
  65         my $mojo = shift;
  66         say $mojo->res->code;
  67         return get('http://metacpan.org');
  68     }
  69 )->then(
  70     sub {
  71         my $cpan = shift;
  72         say $cpan->res->code;
  73     }
  74 )->catch(
  75     sub {
  76         my $err = shift;
  77         warn "Something went wrong: $err";
  78     }
  79 )->wait;
  80 ----------
  81
  82         'rt123774' => <<'----------',
  83 # retain any space between backslash and quote to avoid fooling html formatters
  84 my $var1 = \ "bubba";
  85 my $var2 = \"bubba";
  86 my $var3 = \ 'bubba';
  87 my $var4 = \'bubba';
  88 my $var5 = \            "bubba";
  89 ----------
  90
  91         'rt124114' => <<'----------',
  92 #!/usr/bin/perl
  93 my %h = {
  94     a    => 2 > 3 ? 1 : 0,
  95     bbbb => sub { my $y = "1" },
  96     c    => sub { my $z = "2" },
  97     d    => 2 > 3 ? 1 : 0,
  98 };
  99 ----------
 100
 101         'rt124354' => <<'----------',
 102 package Foo;
 103
 104 use Moose;
 105
 106 has a => ( is => 'ro', isa => 'Int' );
 107 has b => ( is => 'ro', isa => 'Int' );
 108 has c => ( is => 'ro', isa => 'Int' );
 109
 110 __PACKAGE__->meta->make_immutable;
 111 ----------
 112
 113         'rt125012' => <<'----------',
 114 ++$_ for
 115 #one space before eol:
 116 values %_;
 117 system
 118 #one space before eol:
 119 qq{};
 120 ----------
 121
 122         'rt125506' => <<'----------',
 123 my $t = '
 124         un
 125         deux
 126         trois
 127         ';
 128 ----------
 129
 130         'rt126965' => <<'----------',
 131 my $restrict_customer = shift ? 1 : 0;
 132 ----------
 133
 134         'rt15735' => <<'----------',
 135 my $user_prefs = $ref_type eq 'SCALAR' ? _load_from_string( $profile ) : $ref_type eq 'ARRAY' ? _load_from_array( $profile ) : $ref_type eq 'HASH' ? _load_from_hash( $profile ) : _load_from_file( $profile );
 136 ----------
 137
 138         'rt18318' => <<'----------',
 139 # Class::Std attribute list
 140 # The token type of the first colon is 'A' so use -nwrs='A' to avoid space
 141 # after it
 142 my %rank_of : ATTR( :init_arg<starting_rank>  :get<rank>  :set<rank> );
 143 ----------
 144
 145         'rt27000' => <<'----------',
 146 print add( 3, 4 ), "\n";
 147 print add( 4, 3 ), "\n";
 148
 149 sub add {
 150     my ( $term1, $term2 ) = @_;
 151 # line 1234
 152     die "$term1 > $term2" if $term1 > $term2;
 153     return $term1 + $term2;
 154 }
 155 ----------
 156
 157         'rt31741' => <<'----------',
 158 $msg //= 'World';
 159 ----------
 160
 161         'rt49289' => <<'----------',
 162 use constant qw{ DEBUG 0 };
 163 ----------
 164
 165         'rt50702' => <<'----------',
 166 if (1) { my $uid = $ENV{ 'ORIG_LOGNAME' } || $ENV{ 'LOGNAME' } || $ENV{ 'REMOTE_USER' } || 'foobar'; } if (2) { my $uid = ($ENV{ 'ORIG_LOGNAME' } || $ENV{ 'LOGNAME' } || $ENV{ 'REMOTE_USER' } || 'foobar'); }
 167 ----------
 168
 169         'rt68870' => <<'----------',
 170 s///r;
 171 ----------
 172
 173         'rt70747' => <<'----------',
 174 coerce Q2RawStatGroupArray, from ArrayRef [Q2StatGroup], via {
 175   [ map {
 176       my $g = $_->as_hash;
 177       $g->{stats} = [ map { scalar $_->as_array } @{ $g->{stats} } ]; $g;
 178     } @$_;
 179   ]
 180 };
 181 ----------
 182     };
 183
 184     ####################################
 185     # BEGIN SECTION 3: Expected output #
 186     ####################################
 187     $rtests = {
 188
 189         'rt123749.rt123749' => {
 190             source => "rt123749",
 191             params => "rt123749",
 192             expect => <<'#1...........',
 193 get('http://mojolicious.org')->then( sub {
 194     my $mojo = shift;
 195     say $mojo->res->code;
 196     return get('http://metacpan.org');
 197 } )->then( sub {
 198     my $cpan = shift;
 199     say $cpan->res->code;
 200 } )->catch( sub {
 201     my $err = shift;
 202     warn "Something went wrong: $err";
 203 } )->wait;
 204 #1...........
 205         },
 206
 207         'rt123774.def' => {
 208             source => "rt123774",
 209             params => "def",
 210             expect => <<'#2...........',
 211 # retain any space between backslash and quote to avoid fooling html formatters
 212 my $var1 = \ "bubba";
 213 my $var2 = \"bubba";
 214 my $var3 = \ 'bubba';
 215 my $var4 = \'bubba';
 216 my $var5 = \ "bubba";
 217 #2...........
 218         },
 219
 220         'rt124114.def' => {
 221             source => "rt124114",
 222             params => "def",
 223             expect => <<'#3...........',
 224 #!/usr/bin/perl
 225 my %h = {
 226     a    => 2 > 3 ? 1 : 0,
 227     bbbb => sub { my $y = "1" },
 228     c    => sub { my $z = "2" },
 229     d    => 2 > 3 ? 1 : 0,
 230 };
 231 #3...........
 232         },
 233
 234         'rt124354.def' => {
 235             source => "rt124354",
 236             params => "def",
 237             expect => <<'#4...........',
 238 package Foo;
 239
 240 use Moose;
 241
 242 has a => ( is => 'ro', isa => 'Int' );
 243 has b => ( is => 'ro', isa => 'Int' );
 244 has c => ( is => 'ro', isa => 'Int' );
 245
 246 __PACKAGE__->meta->make_immutable;
 247 #4...........
 248         },
 249
 250         'rt124354.rt124354' => {
 251             source => "rt124354",
 252             params => "rt124354",
 253             expect => <<'#5...........',
 254 package Foo;
 255
 256 use Moose;
 257
 258 has a => ( is => 'ro', isa => 'Int' );
 259 has b => ( is => 'ro', isa => 'Int' );
 260 has c => ( is => 'ro', isa => 'Int' );
 261
 262 __PACKAGE__->meta->make_immutable;
 263 #5...........
 264         },
 265
 266         'rt125012.def' => {
 267             source => "rt125012",
 268             params => "def",
 269             expect => <<'#6...........',
 270 ++$_ for
 271
 272   #one space before eol:
 273   values %_;
 274 system
 275
 276   #one space before eol:
 277   qq{};
 278 #6...........
 279         },
 280
 281         'rt125012.rt125012' => {
 282             source => "rt125012",
 283             params => "rt125012",
 284             expect => <<'#7...........',
 285 ++$_ for values%_;
 286 system qq{};
 287 #7...........
 288         },
 289
 290         'rt125506.def' => {
 291             source => "rt125506",
 292             params => "def",
 293             expect => <<'#8...........',
 294 my $t = '
 295         un
 296         deux
 297         trois
 298         ';
 299 #8...........
 300         },
 301
 302         'rt125506.rt125506' => {
 303             source => "rt125506",
 304             params => "rt125506",
 305             expect => <<'#9...........',
 306 my $t = '
 307         un
 308         deux
 309         trois
 310         ';
 311 #9...........
 312         },
 313
 314         'rt126965.def' => {
 315             source => "rt126965",
 316             params => "def",
 317             expect => <<'#10...........',
 318 my $restrict_customer = shift ? 1 : 0;
 319 #10...........
 320         },
 321
 322         'rt15735.def' => {
 323             source => "rt15735",
 324             params => "def",
 325             expect => <<'#11...........',
 326 my $user_prefs =
 327     $ref_type eq 'SCALAR' ? _load_from_string($profile)
 328   : $ref_type eq 'ARRAY'  ? _load_from_array($profile)
 329   : $ref_type eq 'HASH'   ? _load_from_hash($profile)
 330   :                         _load_from_file($profile);
 331 #11...........
 332         },
 333
 334         'rt18318.def' => {
 335             source => "rt18318",
 336             params => "def",
 337             expect => <<'#12...........',
 338 # Class::Std attribute list
 339 # The token type of the first colon is 'A' so use -nwrs='A' to avoid space
 340 # after it
 341 my %rank_of : ATTR( :init_arg<starting_rank>  :get<rank>  :set<rank> );
 342 #12...........
 343         },
 344
 345         'rt18318.rt18318' => {
 346             source => "rt18318",
 347             params => "rt18318",
 348             expect => <<'#13...........',
 349 # Class::Std attribute list
 350 # The token type of the first colon is 'A' so use -nwrs='A' to avoid space
 351 # after it
 352 my %rank_of :ATTR( :init_arg<starting_rank>  :get<rank>  :set<rank> );
 353 #13...........
 354         },
 355
 356         'rt27000.def' => {
 357             source => "rt27000",
 358             params => "def",
 359             expect => <<'#14...........',
 360 print add( 3, 4 ), "\n";
 361 print add( 4, 3 ), "\n";
 362
 363 sub add {
 364     my ( $term1, $term2 ) = @_;
 365 # line 1234
 366     die "$term1 > $term2" if $term1 > $term2;
 367     return $term1 + $term2;
 368 }
 369 #14...........
 370         },
 371
 372         'rt31741.def' => {
 373             source => "rt31741",
 374             params => "def",
 375             expect => <<'#15...........',
 376 $msg //= 'World';
 377 #15...........
 378         },
 379
 380         'rt49289.def' => {
 381             source => "rt49289",
 382             params => "def",
 383             expect => <<'#16...........',
 384 use constant qw{ DEBUG 0 };
 385 #16...........
 386         },
 387
 388         'rt50702.def' => {
 389             source => "rt50702",
 390             params => "def",
 391             expect => <<'#17...........',
 392 if (1) {
 393     my $uid =
 394          $ENV{'ORIG_LOGNAME'}
 395       || $ENV{'LOGNAME'}
 396       || $ENV{'REMOTE_USER'}
 397       || 'foobar';
 398 }
 399 if (2) {
 400     my $uid =
 401       (      $ENV{'ORIG_LOGNAME'}
 402           || $ENV{'LOGNAME'}
 403           || $ENV{'REMOTE_USER'}
 404           || 'foobar' );
 405 }
 406 #17...........
 407         },
 408
 409         'rt50702.rt50702' => {
 410             source => "rt50702",
 411             params => "rt50702",
 412             expect => <<'#18...........',
 413 if (1) {
 414     my $uid
 415       = $ENV{'ORIG_LOGNAME'}
 416       || $ENV{'LOGNAME'}
 417       || $ENV{'REMOTE_USER'}
 418       || 'foobar';
 419 }
 420 if (2) {
 421     my $uid
 422       = (    $ENV{'ORIG_LOGNAME'}
 423           || $ENV{'LOGNAME'}
 424           || $ENV{'REMOTE_USER'}
 425           || 'foobar' );
 426 }
 427 #18...........
 428         },
 429
 430         'rt68870.def' => {
 431             source => "rt68870",
 432             params => "def",
 433             expect => <<'#19...........',
 434 s///r;
 435 #19...........
 436         },
 437
 438         'rt70747.def' => {
 439             source => "rt70747",
 440             params => "def",
 441             expect => <<'#20...........',
 442 coerce Q2RawStatGroupArray, from ArrayRef [Q2StatGroup], via {
 443     [
 444         map {
 445             my $g = $_->as_hash;
 446             $g->{stats} = [ map { scalar $_->as_array } @{ $g->{stats} } ];
 447             $g;
 448         } @$_;
 449     ]
 450 };
 451 #20...........
 452         },
 453     };
 454
 455     my $ntests = 0 + keys %{$rtests};
 456     plan tests => $ntests;
 457 }
 458
 459 ###############
 460 # EXECUTE TESTS
 461 ###############
 462
 463 foreach my $key ( sort keys %{$rtests} ) {
 464     my $output;
 465     my $sname  = $rtests->{$key}->{source};
 466     my $expect = $rtests->{$key}->{expect};
 467     my $pname  = $rtests->{$key}->{params};
 468     my $source = $rsources->{$sname};
 469     my $params = defined($pname) ? $rparams->{$pname} : "";
 470     my $stderr_string;
 471     my $errorfile_string;
 472     my $err = Perl::Tidy::perltidy(
 473         source      => \$source,
 474         destination => \$output,
 475         perltidyrc  => \$params,
 476         argv        => '',             # for safety; hide any ARGV from perltidy
 477         stderr      => \$stderr_string,
 478         errorfile => \$errorfile_string,    # not used when -se flag is set
 479     );
 480     if ( $err || $stderr_string || $errorfile_string ) {
 481         if ($err) {
 482             print STDERR
 483 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 484             ok( !$err );
 485         }
 486         if ($stderr_string) {
 487             print STDERR "---------------------\n";
 488             print STDERR "<<STDERR>>\n$stderr_string\n";
 489             print STDERR "---------------------\n";
 490             print STDERR
 491 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 492             ok( !$stderr_string );
 493         }
 494         if ($errorfile_string) {
 495             print STDERR "---------------------\n";
 496             print STDERR "<<.ERR file>>\n$errorfile_string\n";
 497             print STDERR "---------------------\n";
 498             print STDERR
 499 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 500             ok( !$errorfile_string );
 501         }
 502     }
 503     else {
 504         ok( $output, $expect );
 505     }
 506 }