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