t/snippets7.t

   1 # Created with: ./make_t.pl
   2
   3 # Contents:
   4 #1 rt102451.def
   5 #2 rt104427.def
   6 #3 rt106492.def
   7 #4 rt107832.def
   8 #5 rt107832.rt107832
   9 #6 rt111519.def
  10 #7 rt111519.rt111519
  11 #8 rt112534.def
  12 #9 rt113689.def
  13 #10 rt113689.rt113689
  14 #11 rt113792.def
  15 #12 rt114359.def
  16 #13 rt114909.def
  17 #14 rt116344.def
  18 #15 rt119140.def
  19 #16 rt119588.def
  20 #17 rt119970.def
  21 #18 rt119970.rt119970
  22 #19 rt123492.def
  23 #20 rt123749.def
  24
  25 # To locate test #13 you can search for its name or the string '#13'
  26
  27 use strict;
  28 use Test::More;
  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         'rt107832' => <<'----------',
  43 -lp
  44 -boc
  45 ----------
  46         'rt111519' => <<'----------',
  47 -io
  48 -dac
  49 ----------
  50         'rt113689' => <<'----------',
  51 -blao=2
  52 -blbc=1
  53 -blaol='*'
  54 -blbcl='*'
  55 -mbl=2
  56 ----------
  57         'rt119970' => "-wn",
  58     };
  59
  60     ############################
  61     # BEGIN SECTION 2: Sources #
  62     ############################
  63     $rsources = {
  64
  65         'rt102451' => <<'----------',
  66 # RT#102451 bug test; unwanted spaces added before =head1 on each pass
  67 #<<<
  68
  69 =head1 NAME
  70
  71 =cut
  72
  73 my %KA_CACHE; # indexed by uhost currently, points to [$handle...] array
  74
  75
  76 =head1 NAME
  77
  78 =cut
  79
  80 #>>>
  81 ----------
  82
  83         'rt104427' => <<'----------',
  84 #!/usr/bin/env perl
  85 use v5.020;    #includes strict
  86 use warnings;
  87 use experimental 'signatures';
  88 setidentifier();
  89 exit;
  90 sub setidentifier ( $href = {} ) { say 'hi'; }
  91 ----------
  92
  93         'rt106492' => <<'----------',
  94 my $ct = Courriel::Header::ContentType->new( mime_type => 'multipart/alternative', attributes => { boundary => unique_boundary }, );
  95 ----------
  96
  97         'rt107832' => <<'----------',
  98 my %temp =
  99 (
 100 supsup => 123,
 101 nested => {
 102 asdf => 456,
 103 yarg => 'yarp',
 104 }, );
 105 ----------
 106
 107         'rt111519' => <<'----------',
 108 use strict;
 109 use warnings;
 110 my $x = 1; # comment not removed
 111 # comment will be removed
 112 my $y = 2; # comment also not removed
 113 ----------
 114
 115         'rt112534' => <<'----------',
 116 get( on_ready => sub ($worker) { $on_ready->end; return; }, on_exit => sub ( $worker, $status ) { return; }, on_data => sub ($data) { $self->_on_data(@_) if $self; return; } );
 117 ----------
 118
 119         'rt113689' => <<'----------',
 120 $a = sub {
 121     if ( !defined( $_[0] ) ) {
 122         print("Hello, World\n");
 123     }
 124     else { print( $_[0], "\n" ); }
 125 };
 126 ----------
 127
 128         'rt113792' => <<'----------',
 129 print "hello world\n";
 130 __DATA__
 131 => 1/2 : 0.5
 132 ----------
 133
 134         'rt114359' => <<'----------',
 135 my $x = 2; print $x ** 0.5;
 136 ----------
 137
 138         'rt114909' => <<'----------',
 139 #!perl
 140 use strict;
 141 use warnings;
 142
 143 use experimental 'signatures';
 144
 145 sub reader ( $line_sep, $chomp ) {
 146     return sub ( $fh, $out ) : prototype(*$) {
 147         local $/ = $line_sep;
 148         my $content = <$fh>;
 149         return undef unless defined $content;
 150         chomp $content if $chomp;
 151         $$out .= $content;
 152         return 1;
 153     };
 154 }
 155
 156 BEGIN {
 157     *get_line = reader( "\n", 1 );
 158 }
 159
 160 while ( get_line( STDIN, \my $buf ) ) {
 161     print "Got: $buf\n";
 162 }
 163 ----------
 164
 165         'rt116344' => <<'----------',
 166 # Rt116344
 167 # Attempting to tidy the following code failed:
 168 sub broken {
 169     return ref {} ? 1 : 0;
 170     something();
 171 }
 172 ----------
 173
 174         'rt119140' => <<'----------',
 175 while (<<>>) { }
 176 ----------
 177
 178         'rt119588' => <<'----------',
 179 sub demo {
 180     my $self     = shift;
 181     my $longname = shift // "xyz";
 182 }
 183 ----------
 184
 185         'rt119970' => <<'----------',
 186 my $x = [
 187     {
 188         fooxx => 1,
 189         bar => 1,
 190     }
 191 ];
 192 ----------
 193
 194         'rt123492' => <<'----------',
 195 if (1) {
 196     print <<~EOF;
 197     Hello there
 198     EOF
 199 }
 200 ----------
 201
 202         'rt123749' => <<'----------',
 203 get('http://mojolicious.org')->then(
 204     sub {
 205         my $mojo = shift;
 206         say $mojo->res->code;
 207         return get('http://metacpan.org');
 208     }
 209 )->then(
 210     sub {
 211         my $cpan = shift;
 212         say $cpan->res->code;
 213     }
 214 )->catch(
 215     sub {
 216         my $err = shift;
 217         warn "Something went wrong: $err";
 218     }
 219 )->wait;
 220 ----------
 221     };
 222
 223     ####################################
 224     # BEGIN SECTION 3: Expected output #
 225     ####################################
 226     $rtests = {
 227
 228         'rt102451.def' => {
 229             source => "rt102451",
 230             params => "def",
 231             expect => <<'#1...........',
 232 # RT#102451 bug test; unwanted spaces added before =head1 on each pass
 233 #<<<
 234
 235 =head1 NAME
 236
 237 =cut
 238
 239 my %KA_CACHE; # indexed by uhost currently, points to [$handle...] array
 240
 241
 242 =head1 NAME
 243
 244 =cut
 245
 246 #>>>
 247 #1...........
 248         },
 249
 250         'rt104427.def' => {
 251             source => "rt104427",
 252             params => "def",
 253             expect => <<'#2...........',
 254 #!/usr/bin/env perl
 255 use v5.020;    #includes strict
 256 use warnings;
 257 use experimental 'signatures';
 258 setidentifier();
 259 exit;
 260 sub setidentifier ( $href = {} ) { say 'hi'; }
 261 #2...........
 262         },
 263
 264         'rt106492.def' => {
 265             source => "rt106492",
 266             params => "def",
 267             expect => <<'#3...........',
 268 my $ct = Courriel::Header::ContentType->new(
 269     mime_type  => 'multipart/alternative',
 270     attributes => { boundary => unique_boundary },
 271 );
 272 #3...........
 273         },
 274
 275         'rt107832.def' => {
 276             source => "rt107832",
 277             params => "def",
 278             expect => <<'#4...........',
 279 my %temp = (
 280     supsup => 123,
 281     nested => {
 282         asdf => 456,
 283         yarg => 'yarp',
 284     },
 285 );
 286 #4...........
 287         },
 288
 289         'rt107832.rt107832' => {
 290             source => "rt107832",
 291             params => "rt107832",
 292             expect => <<'#5...........',
 293 my %temp = (
 294     supsup => 123,
 295     nested => {
 296                 asdf => 456,
 297                 yarg => 'yarp',
 298     },
 299 );
 300 #5...........
 301         },
 302
 303         'rt111519.def' => {
 304             source => "rt111519",
 305             params => "def",
 306             expect => <<'#6...........',
 307 use strict;
 308 use warnings;
 309 my $x = 1;    # comment not removed
 310
 311 # comment will be removed
 312 my $y = 2;    # comment also not removed
 313 #6...........
 314         },
 315
 316         'rt111519.rt111519' => {
 317             source => "rt111519",
 318             params => "rt111519",
 319             expect => <<'#7...........',
 320 use strict;
 321 use warnings;
 322 my $x = 1;
 323 my $y = 2;
 324 #7...........
 325         },
 326
 327         'rt112534.def' => {
 328             source => "rt112534",
 329             params => "def",
 330             expect => <<'#8...........',
 331 get(
 332     on_ready => sub ($worker) { $on_ready->end; return; },
 333     on_exit  => sub ( $worker, $status ) { return; },
 334     on_data  => sub ($data) { $self->_on_data(@_) if $self; return; }
 335 );
 336 #8...........
 337         },
 338
 339         'rt113689.def' => {
 340             source => "rt113689",
 341             params => "def",
 342             expect => <<'#9...........',
 343 $a = sub {
 344     if ( !defined( $_[0] ) ) {
 345         print("Hello, World\n");
 346     }
 347     else { print( $_[0], "\n" ); }
 348 };
 349 #9...........
 350         },
 351
 352         'rt113689.rt113689' => {
 353             source => "rt113689",
 354             params => "rt113689",
 355             expect => <<'#10...........',
 356 $a = sub {
 357
 358
 359     if ( !defined( $_[0] ) ) {
 360
 361
 362         print("Hello, World\n");
 363
 364     }
 365     else { print( $_[0], "\n" ); }
 366
 367 };
 368 #10...........
 369         },
 370
 371         'rt113792.def' => {
 372             source => "rt113792",
 373             params => "def",
 374             expect => <<'#11...........',
 375 print "hello world\n";
 376 __DATA__
 377 => 1/2 : 0.5
 378 #11...........
 379         },
 380
 381         'rt114359.def' => {
 382             source => "rt114359",
 383             params => "def",
 384             expect => <<'#12...........',
 385 my $x = 2;
 386 print $x **0.5;
 387 #12...........
 388         },
 389
 390         'rt114909.def' => {
 391             source => "rt114909",
 392             params => "def",
 393             expect => <<'#13...........',
 394 #!perl
 395 use strict;
 396 use warnings;
 397
 398 use experimental 'signatures';
 399
 400 sub reader ( $line_sep, $chomp ) {
 401     return sub ( $fh, $out ) : prototype(*$) {
 402         local $/ = $line_sep;
 403         my $content = <$fh>;
 404         return undef unless defined $content;
 405         chomp $content if $chomp;
 406         $$out .= $content;
 407         return 1;
 408     };
 409 }
 410
 411 BEGIN {
 412     *get_line = reader( "\n", 1 );
 413 }
 414
 415 while ( get_line( STDIN, \my $buf ) ) {
 416     print "Got: $buf\n";
 417 }
 418 #13...........
 419         },
 420
 421         'rt116344.def' => {
 422             source => "rt116344",
 423             params => "def",
 424             expect => <<'#14...........',
 425 # Rt116344
 426 # Attempting to tidy the following code failed:
 427 sub broken {
 428     return ref {} ? 1 : 0;
 429     something();
 430 }
 431 #14...........
 432         },
 433
 434         'rt119140.def' => {
 435             source => "rt119140",
 436             params => "def",
 437             expect => <<'#15...........',
 438 while ( <<>> ) { }
 439 #15...........
 440         },
 441
 442         'rt119588.def' => {
 443             source => "rt119588",
 444             params => "def",
 445             expect => <<'#16...........',
 446 sub demo {
 447     my $self     = shift;
 448     my $longname = shift // "xyz";
 449 }
 450 #16...........
 451         },
 452
 453         'rt119970.def' => {
 454             source => "rt119970",
 455             params => "def",
 456             expect => <<'#17...........',
 457 my $x = [
 458     {
 459         fooxx => 1,
 460         bar   => 1,
 461     }
 462 ];
 463 #17...........
 464         },
 465
 466         'rt119970.rt119970' => {
 467             source => "rt119970",
 468             params => "rt119970",
 469             expect => <<'#18...........',
 470 my $x = [ {
 471     fooxx => 1,
 472     bar   => 1,
 473 } ];
 474 #18...........
 475         },
 476
 477         'rt123492.def' => {
 478             source => "rt123492",
 479             params => "def",
 480             expect => <<'#19...........',
 481 if (1) {
 482     print <<~EOF;
 483     Hello there
 484     EOF
 485 }
 486 #19...........
 487         },
 488
 489         'rt123749.def' => {
 490             source => "rt123749",
 491             params => "def",
 492             expect => <<'#20...........',
 493 get('http://mojolicious.org')->then(
 494     sub {
 495         my $mojo = shift;
 496         say $mojo->res->code;
 497         return get('http://metacpan.org');
 498     }
 499 )->then(
 500     sub {
 501         my $cpan = shift;
 502         say $cpan->res->code;
 503     }
 504 )->catch(
 505     sub {
 506         my $err = shift;
 507         warn "Something went wrong: $err";
 508     }
 509 )->wait;
 510 #20...........
 511         },
 512     };
 513
 514     my $ntests = 0 + keys %{$rtests};
 515     plan tests => $ntests;
 516 }
 517
 518 ###############
 519 # EXECUTE TESTS
 520 ###############
 521
 522 foreach my $key ( sort keys %{$rtests} ) {
 523     my $output;
 524     my $sname  = $rtests->{$key}->{source};
 525     my $expect = $rtests->{$key}->{expect};
 526     my $pname  = $rtests->{$key}->{params};
 527     my $source = $rsources->{$sname};
 528     my $params = defined($pname) ? $rparams->{$pname} : "";
 529     my $stderr_string;
 530     my $errorfile_string;
 531     my $err = Perl::Tidy::perltidy(
 532         source      => \$source,
 533         destination => \$output,
 534         perltidyrc  => \$params,
 535         argv        => '',             # for safety; hide any ARGV from perltidy
 536         stderr      => \$stderr_string,
 537         errorfile   => \$errorfile_string,    # not used when -se flag is set
 538     );
 539     if ( $err || $stderr_string || $errorfile_string ) {
 540         print STDERR "Error output received for test '$key'\n";
 541         if ($err) {
 542             print STDERR "An error flag '$err' was returned\n";
 543             ok( !$err );
 544         }
 545         if ($stderr_string) {
 546             print STDERR "---------------------\n";
 547             print STDERR "<<STDERR>>\n$stderr_string\n";
 548             print STDERR "---------------------\n";
 549             ok( !$stderr_string );
 550         }
 551         if ($errorfile_string) {
 552             print STDERR "---------------------\n";
 553             print STDERR "<<.ERR file>>\n$errorfile_string\n";
 554             print STDERR "---------------------\n";
 555             ok( !$errorfile_string );
 556         }
 557     }
 558     else {
 559         if ( !is( $output, $expect, $key ) ) {
 560             my $leno = length($output);
 561             my $lene = length($expect);
 562             if ( $leno == $lene ) {
 563                 print STDERR
 564 "#> Test '$key' gave unexpected output.  Strings differ but both have length $leno\n";
 565             }
 566             else {
 567                 print STDERR
 568 "#> Test '$key' gave unexpected output.  String lengths differ: output=$leno, expected=$lene\n";
 569             }
 570         }
 571     }
 572 }