t/snippets26.t

   1 # Created with: ./make_t.pl
   2
   3 # Contents:
   4 #1 bal.bal2
   5 #2 bal.def
   6 #3 lpxl.lpxl6
   7 #4 c133.c133
   8 #5 c133.def
   9 #6 git93.def
  10 #7 git93.git93
  11 #8 c139.def
  12
  13 # To locate test #13 you can search for its name or the string '#13'
  14
  15 use strict;
  16 use Test::More;
  17 use Carp;
  18 use Perl::Tidy;
  19 my $rparams;
  20 my $rsources;
  21 my $rtests;
  22
  23 BEGIN {
  24
  25     ###########################################
  26     # BEGIN SECTION 1: Parameter combinations #
  27     ###########################################
  28     $rparams = {
  29         'bal2'  => "-bal=2",
  30         'c133'  => "-boc",
  31         'def'   => "",
  32         'git93' => <<'----------',
  33 -vxl='q'
  34 ----------
  35         'lpxl6' => <<'----------',
  36 # equivalent to -lpxl='{ [ F(2'
  37 -lp -lpil='f(2'
  38 ----------
  39     };
  40
  41     ############################
  42     # BEGIN SECTION 2: Sources #
  43     ############################
  44     $rsources = {
  45
  46         'bal' => <<'----------',
  47 {
  48   L1:
  49   L2:
  50   L3: return;
  51 };
  52 ----------
  53
  54         'c133' => <<'----------',
  55 # this will make 1 line unless -boc is used
  56 return (
  57     $x * cos($a) - $y * sin($a),
  58     $x * sin($a) + $y * cos($a)
  59 );
  60
  61 # broken list - issue c133
  62 return (
  63     $x * cos($a) - $y * sin($a),
  64     $x * sin($a) + $y * cos($a)
  65
  66 );
  67
  68 # no parens
  69 return
  70   $x * cos($a) - $y * sin($a),
  71   $x * sin($a) + $y * cos($a);
  72 ----------
  73
  74         'c139' => <<'----------',
  75 # The '&' has trailing spaces
  76 @l = &
  77 _
  78 ( -49, -71 );
  79
  80 # This '$' has trailing spaces
  81 my $
  82 b = 40;
  83
  84 # this arrow has trailing spaces
  85 $r = $c->
  86 sql_set_env_attr( $evh, $SQL_ATTR_ODBC_VERSION, $SQL_OV_ODBC2, 0 );
  87
  88 # spaces and blank line
  89 @l = &
  90
  91 _
  92 ( -49, -71 );
  93
  94 # spaces and blank line
  95 $r = $c->
  96
  97 sql_set_env_attr( $evh, $SQL_ATTR_ODBC_VERSION, $SQL_OV_ODBC2, 0 );
  98 ----------
  99
 100         'git93' => <<'----------',
 101 use Cwd qw[cwd];
 102 use Carp qw(carp);
 103 use IPC::Cmd qw{can_run run QUOTE};
 104 use File::Path qw/mkpath/;
 105 use File::Temp qw[tempdir];
 106 use Params::Check qw<check>;
 107 use Module::Load::Conditional qw#can_load#;
 108 use Locale::Maketext::Simple Style => 'gettext';    # does not align
 109
 110 # do not align on these 'q' token types - not use statements...
 111 my $gene_color_sets = [
 112     [ qw( blue blue blue blue ) => 'blue' ],
 113     [ qw( brown blue blue blue ) => 'brown' ],
 114     [ qw( brown brown green green ) => 'brown' ],
 115 ];
 116
 117 sub quux : PluginKeyword { 'quux' }
 118 sub qaax : PluginKeyword(qiix) { die "unimplemented" }
 119
 120 use vars qw($curdir);
 121 no strict qw(vars);
 122 ----------
 123
 124         'lpxl' => <<'----------',
 125 # simple function call
 126 my $loanlength = getLoanLength(
 127                                 $borrower->{'categorycode'},    # sc1
 128                                 $iteminformation->{'itemtype'},
 129                                 $borrower->{'branchcode'}       # sc3
 130 );
 131
 132 # function call, more than one level deep
 133 my $o = very::long::class::name->new(
 134     {
 135         propA => "a",
 136         propB => "b",
 137         propC => "c",
 138     }
 139 );
 140
 141 # function call with sublist
 142 debug(
 143       "Connecting to DB.",
 144       "Extra-Parameters: " . join("<->", $extra_parms),
 145       "Config: " . join("<->", %config)
 146      );
 147
 148 # simple function call with code block
 149 $m->command(-label   => 'Save',
 150             -command => sub { print "DOS\n"; save_dialog($win); });
 151
 152 # function call, ternary in list
 153 return
 154   OptArgs2::Result->usage(
 155     $style == OptArgs2::STYLE_FULL ? 'FullUsage' : 'NormalUsage',
 156     'usage: ' . $usage . "\n" );
 157
 158 # not a function call
 159 %blastparam = (
 160     -run            => \%runparam,
 161     -file           => '',
 162     -parse          => 1,
 163     -signif         => 1e-5,
 164 );
 165
 166 # 'local' is a keyword, not a user function
 167     local (
 168         $len,    $pts,      @colspec, $char, $cols,
 169         $repeat, $celldata, $at_text, $after_text
 170     );
 171
 172 # square bracket with sublists
 173 $data = [
 174          ListElem->new(id => 0, val => 100),
 175          ListElem->new(id => 2, val => 50),
 176          ListElem->new(id => 1, val => 10),
 177         ];
 178
 179 # curly brace with sublists
 180 $behaviour = {
 181               cat   => {nap    => "lap",   eat  => "meat"},
 182               dog   => {prowl  => "growl", pool => "drool"},
 183               mouse => {nibble => "kibble"},
 184              };
 185 ----------
 186     };
 187
 188     ####################################
 189     # BEGIN SECTION 3: Expected output #
 190     ####################################
 191     $rtests = {
 192
 193         'bal.bal2' => {
 194             source => "bal",
 195             params => "bal2",
 196             expect => <<'#1...........',
 197 {
 198   L1: L2: L3: return;
 199 };
 200 #1...........
 201         },
 202
 203         'bal.def' => {
 204             source => "bal",
 205             params => "def",
 206             expect => <<'#2...........',
 207 {
 208   L1:
 209   L2:
 210   L3: return;
 211 };
 212 #2...........
 213         },
 214
 215         'lpxl.lpxl6' => {
 216             source => "lpxl",
 217             params => "lpxl6",
 218             expect => <<'#3...........',
 219 # simple function call
 220 my $loanlength = getLoanLength(
 221                                 $borrower->{'categorycode'},    # sc1
 222                                 $iteminformation->{'itemtype'},
 223                                 $borrower->{'branchcode'}       # sc3
 224 );
 225
 226 # function call, more than one level deep
 227 my $o = very::long::class::name->new(
 228     {
 229         propA => "a",
 230         propB => "b",
 231         propC => "c",
 232     }
 233 );
 234
 235 # function call with sublist
 236 debug(
 237     "Connecting to DB.",
 238     "Extra-Parameters: " . join( "<->", $extra_parms ),
 239     "Config: " . join( "<->", %config )
 240 );
 241
 242 # simple function call with code block
 243 $m->command(
 244     -label   => 'Save',
 245     -command => sub { print "DOS\n"; save_dialog($win); }
 246 );
 247
 248 # function call, ternary in list
 249 return OptArgs2::Result->usage(
 250     $style == OptArgs2::STYLE_FULL ? 'FullUsage' : 'NormalUsage',
 251     'usage: ' . $usage . "\n" );
 252
 253 # not a function call
 254 %blastparam = (
 255     -run    => \%runparam,
 256     -file   => '',
 257     -parse  => 1,
 258     -signif => 1e-5,
 259 );
 260
 261 # 'local' is a keyword, not a user function
 262 local (
 263     $len,    $pts,      @colspec, $char, $cols,
 264     $repeat, $celldata, $at_text, $after_text
 265 );
 266
 267 # square bracket with sublists
 268 $data = [
 269     ListElem->new( id => 0, val => 100 ),
 270     ListElem->new( id => 2, val => 50 ),
 271     ListElem->new( id => 1, val => 10 ),
 272 ];
 273
 274 # curly brace with sublists
 275 $behaviour = {
 276     cat   => { nap    => "lap",   eat  => "meat" },
 277     dog   => { prowl  => "growl", pool => "drool" },
 278     mouse => { nibble => "kibble" },
 279 };
 280 #3...........
 281         },
 282
 283         'c133.c133' => {
 284             source => "c133",
 285             params => "c133",
 286             expect => <<'#4...........',
 287 # this will make 1 line unless -boc is used
 288 return (
 289     $x * cos($a) - $y * sin($a),
 290     $x * sin($a) + $y * cos($a)
 291 );
 292
 293 # broken list - issue c133
 294 return (
 295     $x * cos($a) - $y * sin($a),
 296     $x * sin($a) + $y * cos($a)
 297
 298 );
 299
 300 # no parens
 301 return
 302   $x * cos($a) - $y * sin($a),
 303   $x * sin($a) + $y * cos($a);
 304 #4...........
 305         },
 306
 307         'c133.def' => {
 308             source => "c133",
 309             params => "def",
 310             expect => <<'#5...........',
 311 # this will make 1 line unless -boc is used
 312 return ( $x * cos($a) - $y * sin($a), $x * sin($a) + $y * cos($a) );
 313
 314 # broken list - issue c133
 315 return (
 316     $x * cos($a) - $y * sin($a),
 317     $x * sin($a) + $y * cos($a)
 318
 319 );
 320
 321 # no parens
 322 return
 323   $x * cos($a) - $y * sin($a),
 324   $x * sin($a) + $y * cos($a);
 325 #5...........
 326         },
 327
 328         'git93.def' => {
 329             source => "git93",
 330             params => "def",
 331             expect => <<'#6...........',
 332 use Cwd                       qw[cwd];
 333 use Carp                      qw(carp);
 334 use IPC::Cmd                  qw{can_run run QUOTE};
 335 use File::Path                qw/mkpath/;
 336 use File::Temp                qw[tempdir];
 337 use Params::Check             qw<check>;
 338 use Module::Load::Conditional qw#can_load#;
 339 use Locale::Maketext::Simple Style => 'gettext';    # does not align
 340
 341 # do not align on these 'q' token types - not use statements...
 342 my $gene_color_sets = [
 343     [ qw( blue blue blue blue )     => 'blue' ],
 344     [ qw( brown blue blue blue )    => 'brown' ],
 345     [ qw( brown brown green green ) => 'brown' ],
 346 ];
 347
 348 sub quux : PluginKeyword       { 'quux' }
 349 sub qaax : PluginKeyword(qiix) { die "unimplemented" }
 350
 351 use vars qw($curdir);
 352 no strict qw(vars);
 353 #6...........
 354         },
 355
 356         'git93.git93' => {
 357             source => "git93",
 358             params => "git93",
 359             expect => <<'#7...........',
 360 use Cwd qw[cwd];
 361 use Carp qw(carp);
 362 use IPC::Cmd qw{can_run run QUOTE};
 363 use File::Path qw/mkpath/;
 364 use File::Temp qw[tempdir];
 365 use Params::Check qw<check>;
 366 use Module::Load::Conditional qw#can_load#;
 367 use Locale::Maketext::Simple Style => 'gettext';    # does not align
 368
 369 # do not align on these 'q' token types - not use statements...
 370 my $gene_color_sets = [
 371     [ qw( blue blue blue blue )     => 'blue' ],
 372     [ qw( brown blue blue blue )    => 'brown' ],
 373     [ qw( brown brown green green ) => 'brown' ],
 374 ];
 375
 376 sub quux : PluginKeyword       { 'quux' }
 377 sub qaax : PluginKeyword(qiix) { die "unimplemented" }
 378
 379 use vars qw($curdir);
 380 no strict qw(vars);
 381 #7...........
 382         },
 383
 384         'c139.def' => {
 385             source => "c139",
 386             params => "def",
 387             expect => <<'#8...........',
 388 # The '&' has trailing spaces
 389 @l = &_( -49, -71 );
 390
 391 # This '$' has trailing spaces
 392 my $b = 40;
 393
 394 # this arrow has trailing spaces
 395 $r = $c->sql_set_env_attr( $evh, $SQL_ATTR_ODBC_VERSION, $SQL_OV_ODBC2, 0 );
 396
 397 # spaces and blank line
 398 @l = &
 399
 400   _( -49, -71 );
 401
 402 # spaces and blank line
 403 $r = $c->
 404
 405   sql_set_env_attr( $evh, $SQL_ATTR_ODBC_VERSION, $SQL_OV_ODBC2, 0 );
 406 #8...........
 407         },
 408     };
 409
 410     my $ntests = 0 + keys %{$rtests};
 411     plan tests => $ntests;
 412 }
 413
 414 ###############
 415 # EXECUTE TESTS
 416 ###############
 417
 418 foreach my $key ( sort keys %{$rtests} ) {
 419     my $output;
 420     my $sname  = $rtests->{$key}->{source};
 421     my $expect = $rtests->{$key}->{expect};
 422     my $pname  = $rtests->{$key}->{params};
 423     my $source = $rsources->{$sname};
 424     my $params = defined($pname) ? $rparams->{$pname} : "";
 425     my $stderr_string;
 426     my $errorfile_string;
 427     my $err = Perl::Tidy::perltidy(
 428         source      => \$source,
 429         destination => \$output,
 430         perltidyrc  => \$params,
 431         argv        => '',             # for safety; hide any ARGV from perltidy
 432         stderr      => \$stderr_string,
 433         errorfile   => \$errorfile_string,    # not used when -se flag is set
 434     );
 435     if ( $err || $stderr_string || $errorfile_string ) {
 436         print STDERR "Error output received for test '$key'\n";
 437         if ($err) {
 438             print STDERR "An error flag '$err' was returned\n";
 439             ok( !$err );
 440         }
 441         if ($stderr_string) {
 442             print STDERR "---------------------\n";
 443             print STDERR "<<STDERR>>\n$stderr_string\n";
 444             print STDERR "---------------------\n";
 445             ok( !$stderr_string );
 446         }
 447         if ($errorfile_string) {
 448             print STDERR "---------------------\n";
 449             print STDERR "<<.ERR file>>\n$errorfile_string\n";
 450             print STDERR "---------------------\n";
 451             ok( !$errorfile_string );
 452         }
 453     }
 454     else {
 455         if ( !is( $output, $expect, $key ) ) {
 456             my $leno = length($output);
 457             my $lene = length($expect);
 458             if ( $leno == $lene ) {
 459                 print STDERR
 460 "#> Test '$key' gave unexpected output.  Strings differ but both have length $leno\n";
 461             }
 462             else {
 463                 print STDERR
 464 "#> Test '$key' gave unexpected output.  String lengths differ: output=$leno, expected=$lene\n";
 465             }
 466         }
 467     }
 468 }