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