t/snippets16.t

   1 # Created with: ./make_t.pl
   2
   3 # Contents:
   4 #1 spp.spp1
   5 #2 spp.spp2
   6 #3 git16.def
   7 #4 git10.def
   8 #5 git10.git10
   9 #6 multiple_equals.def
  10 #7 align31.def
  11 #8 almost1.def
  12 #9 almost2.def
  13 #10 almost3.def
  14 #11 rt130394.def
  15 #12 rt131115.def
  16 #13 rt131115.rt131115
  17 #14 ndsm1.def
  18 #15 ndsm1.ndsm
  19 #16 rt131288.def
  20 #17 rt130394.rt130394
  21 #18 git18.def
  22 #19 here2.def
  23
  24 # To locate test #13 you can search for its name or the string '#13'
  25
  26 use strict;
  27 use Test::More;
  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         'def'      => "",
  41         'git10'    => "-wn -ce -cbl=sort,map,grep",
  42         'ndsm'     => "-ndsm",
  43         'rt130394' => "-olbn=1",
  44         'rt131115' => "-bli",
  45         'spp1'     => "-spp=1",
  46         'spp2'     => "-spp=2",
  47     };
  48
  49     ############################
  50     # BEGIN SECTION 2: Sources #
  51     ############################
  52     $rsources = {
  53
  54         'align31' => <<'----------',
  55 # do not align the commas
  56 $w->insert(
  57     ListBox => origin => [ 270, 160 ],
  58     size    => [ 200,           55 ],
  59 );
  60 ----------
  61
  62         'almost1' => <<'----------',
  63 # not a good alignment
  64 my $realname     = catfile( $dir,                  $file );
  65 my $display_name = defined $disp ? catfile( $disp, $file ) : $file;
  66 ----------
  67
  68         'almost2' => <<'----------',
  69 # not a good alignment
  70 my $substname = ( $indtot > 1            ? $indname . $indno : $indname );
  71 my $incname   = $indname . ( $indtot > 1 ? $indno            : "" );
  72 ----------
  73
  74         'almost3' => <<'----------',
  75 # not a good alignment
  76 sub head {
  77     match_on_type @_ => Null => sub { die "Cannot get head of Null" },
  78       ArrayRef       => sub         { $_->[0] };
  79 }
  80
  81 ----------
  82
  83         'git10' => <<'----------',
  84 # perltidy -wn -ce -cbl=sort,map,grep
  85 @sorted = map {
  86     $_->[0]
  87 } sort {
  88     $a->[1] <=> $b->[1] or $a->[0] cmp $b->[0]
  89 } map {
  90     [ $_, length($_) ]
  91 } @unsorted;
  92 ----------
  93
  94         'git16' => <<'----------',
  95 # git#16, two equality lines with fat commas on the right
  96 my $Package = $Self->RepositoryGet( %Param, Result => 'SCALAR' );
  97 my %Structure = $Self->PackageParse( String => $Package );
  98 ----------
  99
 100         'git18' => <<'----------',
 101 # parsing stuff like 'x17' before fat comma
 102 my %bb = (
 103     123x18 => '123x18',
 104     123 x19 => '123 x19',
 105     123x 20 => '123x 20',
 106     2 x 7    => '2 x 7',
 107     x40      => 'x40',
 108     'd' x17    => "'d' x17",
 109     c x17    => 'c x17',
 110 );
 111 foreach my $key ( keys %bb ) {
 112     print "key='$key' => $bb{$key}\n";
 113 }
 114 ----------
 115
 116         'here2' => <<'----------',
 117 $_ = "";
 118 s|(?:)|"${\<<END}"
 119 ok $test - here2.in "" in multiline s///e outside eval
 120 END
 121 |e;
 122 print $_ || "not ok $test\n";
 123 ----------
 124
 125         'multiple_equals' => <<'----------',
 126 # ignore second '=' here
 127 $|          = $debug = 1 if $opt_d;
 128 $full_index = 1          if $opt_i;
 129 $query_all  = $opt_A     if $opt_A;
 130
 131 # not aligning multiple '='s here
 132 $start   = $end     = $len = $ismut = $number = $allele_ori = $allele_mut =
 133   $proof = $xxxxreg = $reg = $dist  = '';
 134 ----------
 135
 136         'ndsm1' => <<'----------',
 137 ;;;;; # 1 trapped semicolon
 138 sub numerically {$a <=> $b};
 139 ;;;;;
 140 sub Numerically {$a <=> $b};  # trapped semicolon
 141 @: = qw;2c72656b636168
 142   2020202020
 143   ;; __;
 144 ----------
 145
 146         'rt130394' => <<'----------',
 147 # rt130394: keep on one line with -olbn=1
 148 $factorial = sub { reduce { $a * $b } 1 .. 11 };
 149 ----------
 150
 151         'rt131115' => <<'----------',
 152 # closing braces to be inteded with -bli
 153 sub a {
 154     my %uniq;
 155     foreach my $par (@_) {
 156         $uniq{$par} = 1;
 157     }
 158 }
 159 ----------
 160
 161         'rt131288' => <<'----------',
 162 sub OptArgs2::STYLE_FULL { 3 }
 163 $style == OptArgs2::STYLE_FULL ? 'FullUsage' : 'NormalUsage', 'usage: ' . $usage . "\n";
 164 ----------
 165
 166         'spp' => <<'----------',
 167 sub get_val() { }
 168
 169 sub get_Val  () { }
 170
 171 sub Get_val             () { }
 172 my $sub1=sub                     () { };
 173 my $sub2=sub () { };
 174 ----------
 175     };
 176
 177     ####################################
 178     # BEGIN SECTION 3: Expected output #
 179     ####################################
 180     $rtests = {
 181
 182         'spp.spp1' => {
 183             source => "spp",
 184             params => "spp1",
 185             expect => <<'#1...........',
 186 sub get_val() { }
 187
 188 sub get_Val () { }
 189
 190 sub Get_val () { }
 191 my $sub1 = sub () { };
 192 my $sub2 = sub () { };
 193 #1...........
 194         },
 195
 196         'spp.spp2' => {
 197             source => "spp",
 198             params => "spp2",
 199             expect => <<'#2...........',
 200 sub get_val () { }
 201
 202 sub get_Val () { }
 203
 204 sub Get_val () { }
 205 my $sub1 = sub () { };
 206 my $sub2 = sub () { };
 207 #2...........
 208         },
 209
 210         'git16.def' => {
 211             source => "git16",
 212             params => "def",
 213             expect => <<'#3...........',
 214 # git#16, two equality lines with fat commas on the right
 215 my $Package   = $Self->RepositoryGet( %Param, Result => 'SCALAR' );
 216 my %Structure = $Self->PackageParse( String => $Package );
 217 #3...........
 218         },
 219
 220         'git10.def' => {
 221             source => "git10",
 222             params => "def",
 223             expect => <<'#4...........',
 224 # perltidy -wn -ce -cbl=sort,map,grep
 225 @sorted =
 226   map  { $_->[0] }
 227   sort { $a->[1] <=> $b->[1] or $a->[0] cmp $b->[0] }
 228   map  { [ $_, length($_) ] } @unsorted;
 229 #4...........
 230         },
 231
 232         'git10.git10' => {
 233             source => "git10",
 234             params => "git10",
 235             expect => <<'#5...........',
 236 # perltidy -wn -ce -cbl=sort,map,grep
 237 @sorted = map {
 238     $_->[0]
 239 } sort {
 240     $a->[1] <=> $b->[1] or $a->[0] cmp $b->[0]
 241 } map {
 242     [ $_, length($_) ]
 243 } @unsorted;
 244 #5...........
 245         },
 246
 247         'multiple_equals.def' => {
 248             source => "multiple_equals",
 249             params => "def",
 250             expect => <<'#6...........',
 251 # ignore second '=' here
 252 $|          = $debug = 1 if $opt_d;
 253 $full_index = 1          if $opt_i;
 254 $query_all  = $opt_A     if $opt_A;
 255
 256 # not aligning multiple '='s here
 257 $start = $end = $len = $ismut = $number = $allele_ori = $allele_mut = $proof =
 258   $xxxxreg = $reg = $dist = '';
 259 #6...........
 260         },
 261
 262         'align31.def' => {
 263             source => "align31",
 264             params => "def",
 265             expect => <<'#7...........',
 266 # do not align the commas
 267 $w->insert(
 268     ListBox => origin => [ 270, 160 ],
 269     size    => [ 200, 55 ],
 270 );
 271 #7...........
 272         },
 273
 274         'almost1.def' => {
 275             source => "almost1",
 276             params => "def",
 277             expect => <<'#8...........',
 278 # not a good alignment
 279 my $realname     = catfile( $dir, $file );
 280 my $display_name = defined $disp ? catfile( $disp, $file ) : $file;
 281 #8...........
 282         },
 283
 284         'almost2.def' => {
 285             source => "almost2",
 286             params => "def",
 287             expect => <<'#9...........',
 288 # not a good alignment
 289 my $substname = ( $indtot > 1 ? $indname . $indno : $indname );
 290 my $incname   = $indname . ( $indtot > 1 ? $indno : "" );
 291 #9...........
 292         },
 293
 294         'almost3.def' => {
 295             source => "almost3",
 296             params => "def",
 297             expect => <<'#10...........',
 298 # not a good alignment
 299 sub head {
 300     match_on_type @_ => Null => sub { die "Cannot get head of Null" },
 301       ArrayRef       => sub { $_->[0] };
 302 }
 303
 304 #10...........
 305         },
 306
 307         'rt130394.def' => {
 308             source => "rt130394",
 309             params => "def",
 310             expect => <<'#11...........',
 311 # rt130394: keep on one line with -olbn=1
 312 $factorial = sub {
 313     reduce { $a * $b } 1 .. 11;
 314 };
 315 #11...........
 316         },
 317
 318         'rt131115.def' => {
 319             source => "rt131115",
 320             params => "def",
 321             expect => <<'#12...........',
 322 # closing braces to be inteded with -bli
 323 sub a {
 324     my %uniq;
 325     foreach my $par (@_) {
 326         $uniq{$par} = 1;
 327     }
 328 }
 329 #12...........
 330         },
 331
 332         'rt131115.rt131115' => {
 333             source => "rt131115",
 334             params => "rt131115",
 335             expect => <<'#13...........',
 336 # closing braces to be inteded with -bli
 337 sub a
 338   {
 339     my %uniq;
 340     foreach my $par (@_)
 341       {
 342         $uniq{$par} = 1;
 343       }
 344   }
 345 #13...........
 346         },
 347
 348         'ndsm1.def' => {
 349             source => "ndsm1",
 350             params => "def",
 351             expect => <<'#14...........',
 352 ;    # 1 trapped semicolon
 353 sub numerically { $a <=> $b }
 354
 355 sub Numerically { $a <=> $b };    # trapped semicolon
 356 @: = qw;2c72656b636168
 357   2020202020
 358   ;;
 359 __;
 360 #14...........
 361         },
 362
 363         'ndsm1.ndsm' => {
 364             source => "ndsm1",
 365             params => "ndsm",
 366             expect => <<'#15...........',
 367 ;
 368 ;
 369 ;
 370 ;
 371 ;    # 1 trapped semicolon
 372 sub numerically { $a <=> $b };
 373 ;
 374 ;
 375 ;
 376 ;
 377 ;
 378 sub Numerically { $a <=> $b };    # trapped semicolon
 379 @: = qw;2c72656b636168
 380   2020202020
 381   ;;
 382 __;
 383 #15...........
 384         },
 385
 386         'rt131288.def' => {
 387             source => "rt131288",
 388             params => "def",
 389             expect => <<'#16...........',
 390 sub OptArgs2::STYLE_FULL { 3 }
 391 $style == OptArgs2::STYLE_FULL ? 'FullUsage' : 'NormalUsage',
 392   'usage: ' . $usage . "\n";
 393 #16...........
 394         },
 395
 396         'rt130394.rt130394' => {
 397             source => "rt130394",
 398             params => "rt130394",
 399             expect => <<'#17...........',
 400 # rt130394: keep on one line with -olbn=1
 401 $factorial = sub { reduce { $a * $b } 1 .. 11 };
 402 #17...........
 403         },
 404
 405         'git18.def' => {
 406             source => "git18",
 407             params => "def",
 408             expect => <<'#18...........',
 409 # parsing stuff like 'x17' before fat comma
 410 my %bb = (
 411     123 x 18 => '123x18',
 412     123 x 19 => '123 x19',
 413     123 x 20 => '123x 20',
 414     2 x 7    => '2 x 7',
 415     x40      => 'x40',
 416     'd' x 17 => "'d' x17",
 417     c x17    => 'c x17',
 418 );
 419 foreach my $key ( keys %bb ) {
 420     print "key='$key' => $bb{$key}\n";
 421 }
 422 #18...........
 423         },
 424
 425         'here2.def' => {
 426             source => "here2",
 427             params => "def",
 428             expect => <<'#19...........',
 429 $_ = "";
 430 s|(?:)|"${\<<END}"
 431 ok $test - here2.in "" in multiline s///e outside eval
 432 END
 433 |e;
 434 print $_ || "not ok $test\n";
 435 #19...........
 436         },
 437     };
 438
 439     my $ntests = 0 + keys %{$rtests};
 440     plan tests => $ntests;
 441 }
 442
 443 ###############
 444 # EXECUTE TESTS
 445 ###############
 446
 447 foreach my $key ( sort keys %{$rtests} ) {
 448     my $output;
 449     my $sname  = $rtests->{$key}->{source};
 450     my $expect = $rtests->{$key}->{expect};
 451     my $pname  = $rtests->{$key}->{params};
 452     my $source = $rsources->{$sname};
 453     my $params = defined($pname) ? $rparams->{$pname} : "";
 454     my $stderr_string;
 455     my $errorfile_string;
 456     my $err = Perl::Tidy::perltidy(
 457         source      => \$source,
 458         destination => \$output,
 459         perltidyrc  => \$params,
 460         argv        => '',             # for safety; hide any ARGV from perltidy
 461         stderr      => \$stderr_string,
 462         errorfile   => \$errorfile_string,    # not used when -se flag is set
 463     );
 464     if ( $err || $stderr_string || $errorfile_string ) {
 465         print STDERR "Error output received for test '$key'\n";
 466         if ($err) {
 467             print STDERR "An error flag '$err' was returned\n";
 468             ok( !$err );
 469         }
 470         if ($stderr_string) {
 471             print STDERR "---------------------\n";
 472             print STDERR "<<STDERR>>\n$stderr_string\n";
 473             print STDERR "---------------------\n";
 474             ok( !$stderr_string );
 475         }
 476         if ($errorfile_string) {
 477             print STDERR "---------------------\n";
 478             print STDERR "<<.ERR file>>\n$errorfile_string\n";
 479             print STDERR "---------------------\n";
 480             ok( !$errorfile_string );
 481         }
 482     }
 483     else {
 484         if ( !is( $output, $expect, $key ) ) {
 485             my $leno = length($output);
 486             my $lene = length($expect);
 487             if ( $leno == $lene ) {
 488                 print STDERR
 489 "#> Test '$key' gave unexpected output.  Strings differ but both have length $leno\n";
 490             }
 491             else {
 492                 print STDERR
 493 "#> Test '$key' gave unexpected output.  String lengths differ: output=$leno, expected=$lene\n";
 494             }
 495         }
 496     }
 497 }