t/snippets6.t

   1 # Created with: ./make_t.pl
   2
   3 # Contents:
   4 #1 otr1.otr
   5 #2 pbp1.def
   6 #3 pbp1.pbp
   7 #4 pbp2.def
   8 #5 pbp2.pbp
   9 #6 pbp3.def
  10 #7 pbp3.pbp
  11 #8 pbp4.def
  12 #9 pbp4.pbp
  13 #10 pbp5.def
  14 #11 pbp5.pbp
  15 #12 print1.def
  16 #13 q1.def
  17 #14 q2.def
  18 #15 recombine1.def
  19 #16 recombine2.def
  20 #17 recombine3.def
  21 #18 recombine4.def
  22 #19 rt101547.def
  23 #20 rt102371.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         'otr' => <<'----------',
  43 -ohbr
  44 -opr
  45 -osbr
  46 ----------
  47         'pbp' => "-pbp -nst -nse",
  48     };
  49
  50     ############################
  51     # BEGIN SECTION 2: Sources #
  52     ############################
  53     $rsources = {
  54
  55         'otr1' => <<'----------',
  56 return $pdl->slice(
  57     join ',',
  58     (
  59         map {
  60                 $_ eq "X" ? ":"
  61               : ref $_ eq "ARRAY" ? join ':', @$_
  62               : !ref $_ ? $_
  63               : die "INVALID SLICE DEF $_"
  64         } @_
  65     )
  66 );
  67 ----------
  68
  69         'pbp1' => <<'----------',
  70             # break after '+' if default, before + if pbp
  71             my $min_gnu_indentation = $standard_increment +
  72               $gnu_stack[$max_gnu_stack_index]->get_SPACES();
  73 ----------
  74
  75         'pbp2' => <<'----------',
  76 $tmp = $day - 32075 + 1461 * ( $year + 4800 - ( 14 - $month ) / 12 ) / 4 + 367 * ( $month - 2 + ( ( 14 - $month ) / 12 ) * 12 ) / 12 - 3 * ( ( $year + 4900 - ( 14 - $month ) / 12 ) / 100 ) / 4;
  77 ----------
  78
  79         'pbp3' => <<'----------',
  80 return $sec + $SecOff + ( SECS_PER_MINUTE * $min ) + ( SECS_PER_HOUR * $hour ) + ( SECS_PER_DAY * $days );
  81
  82
  83 ----------
  84
  85         'pbp4' => <<'----------',
  86 # with defaults perltidy will break after the '=' here
  87 my @host_seq = $level eq "easy" ?
  88             @reordered : 0..$last;  # reordered has CDROM up front
  89 ----------
  90
  91         'pbp5' => <<'----------',
  92 # illustates problem with -pbp: -ci should not equal -i
  93 say 'ok_200_24_hours.value '.average({'$and'=>[{time=>{'$gt',$time-60*60*24}},{status=>200}]});
  94
  95 ----------
  96
  97         'print1' => <<'----------',
  98 # same text twice. Has uncontained commas; -- leave as is
  99 print "conformability (Not the same dimension)\n",
 100   "\t",
 101   $have, " is ",
 102   text_unit($hu), "\n", "\t", $want, " is ", text_unit($wu), "\n",;
 103
 104 print
 105   "conformability (Not the same dimension)\n",
 106   "\t", $have, " is ", text_unit($hu), "\n",
 107   "\t", $want, " is ", text_unit($wu), "\n",
 108   ;
 109 ----------
 110
 111         'q1' => <<'----------',
 112 print qq(You are in zone $thisTZ
 113 Difference with respect to GMT is ), $offset / 3600, qq( hours
 114 And local time is $hour hours $min minutes $sec seconds
 115 );
 116 ----------
 117
 118         'q2' => <<'----------',
 119 $a=qq
 120 XHello World\nX;
 121 print "$a";
 122 ----------
 123
 124         'recombine1' => <<'----------',
 125 # recombine '= [' here:
 126 $retarray =
 127   [ &{ $sth->{'xbase_parsed_sql'}{'selectfn'} }
 128       ( $xbase, $values, $sth->{'xbase_bind_values'} ) ]
 129   if defined $values;
 130 ----------
 131
 132         'recombine2' => <<'----------',
 133     # recombine = unless old break there
 134     $a = [ length( $self->{fb}[-1] ), $#{ $self->{fb} } ] ;    # set cursor at end of buffer and print this cursor
 135 ----------
 136
 137         'recombine3' => <<'----------',
 138         # recombine final line
 139         $command = (
 140                     ($catpage =~ m:\.gz:)
 141                     ? $ZCAT
 142                     : $CAT
 143                    )
 144           . " < $catpage";
 145 ----------
 146
 147         'recombine4' => <<'----------',
 148     # do not recombine into two lines after a comma if
 149     # the term is complex (has parens) or changes level
 150     $delta_time = sprintf "%.4f", ( ( $done[0] + ( $done[1] / 1e6 ) ) - ( $start[0] + ( $start[1] / 1e6 ) ) );
 151 ----------
 152
 153         'rt101547' => <<'----------',
 154 { source_host => MM::Config->instance->host // q{}, }
 155 ----------
 156
 157         'rt102371' => <<'----------',
 158 state $b //= ccc();
 159 ----------
 160     };
 161
 162     ####################################
 163     # BEGIN SECTION 3: Expected output #
 164     ####################################
 165     $rtests = {
 166
 167         'otr1.otr' => {
 168             source => "otr1",
 169             params => "otr",
 170             expect => <<'#1...........',
 171 return $pdl->slice(
 172     join ',', (
 173         map {
 174                 $_ eq "X" ? ":"
 175               : ref $_ eq "ARRAY" ? join ':', @$_
 176               : !ref $_ ? $_
 177               : die "INVALID SLICE DEF $_"
 178         } @_
 179     )
 180 );
 181 #1...........
 182         },
 183
 184         'pbp1.def' => {
 185             source => "pbp1",
 186             params => "def",
 187             expect => <<'#2...........',
 188             # break after '+' if default, before + if pbp
 189             my $min_gnu_indentation = $standard_increment +
 190               $gnu_stack[$max_gnu_stack_index]->get_SPACES();
 191 #2...........
 192         },
 193
 194         'pbp1.pbp' => {
 195             source => "pbp1",
 196             params => "pbp",
 197             expect => <<'#3...........',
 198             # break after '+' if default, before + if pbp
 199             my $min_gnu_indentation = $standard_increment
 200                 + $gnu_stack[$max_gnu_stack_index]->get_SPACES();
 201 #3...........
 202         },
 203
 204         'pbp2.def' => {
 205             source => "pbp2",
 206             params => "def",
 207             expect => <<'#4...........',
 208 $tmp =
 209   $day - 32075 +
 210   1461 * ( $year + 4800 - ( 14 - $month ) / 12 ) / 4 +
 211   367 * ( $month - 2 + ( ( 14 - $month ) / 12 ) * 12 ) / 12 -
 212   3 * ( ( $year + 4900 - ( 14 - $month ) / 12 ) / 100 ) / 4;
 213 #4...........
 214         },
 215
 216         'pbp2.pbp' => {
 217             source => "pbp2",
 218             params => "pbp",
 219             expect => <<'#5...........',
 220 $tmp
 221     = $day - 32075
 222     + 1461 * ( $year + 4800 - ( 14 - $month ) / 12 ) / 4
 223     + 367 * ( $month - 2 + ( ( 14 - $month ) / 12 ) * 12 ) / 12
 224     - 3 * ( ( $year + 4900 - ( 14 - $month ) / 12 ) / 100 ) / 4;
 225 #5...........
 226         },
 227
 228         'pbp3.def' => {
 229             source => "pbp3",
 230             params => "def",
 231             expect => <<'#6...........',
 232 return $sec + $SecOff +
 233   ( SECS_PER_MINUTE * $min ) +
 234   ( SECS_PER_HOUR * $hour ) +
 235   ( SECS_PER_DAY * $days );
 236
 237 #6...........
 238         },
 239
 240         'pbp3.pbp' => {
 241             source => "pbp3",
 242             params => "pbp",
 243             expect => <<'#7...........',
 244 return
 245       $sec + $SecOff
 246     + ( SECS_PER_MINUTE * $min )
 247     + ( SECS_PER_HOUR * $hour )
 248     + ( SECS_PER_DAY * $days );
 249
 250 #7...........
 251         },
 252
 253         'pbp4.def' => {
 254             source => "pbp4",
 255             params => "def",
 256             expect => <<'#8...........',
 257 # with defaults perltidy will break after the '=' here
 258 my @host_seq =
 259   $level eq "easy" ? @reordered : 0 .. $last;    # reordered has CDROM up front
 260 #8...........
 261         },
 262
 263         'pbp4.pbp' => {
 264             source => "pbp4",
 265             params => "pbp",
 266             expect => <<'#9...........',
 267 # with defaults perltidy will break after the '=' here
 268 my @host_seq
 269     = $level eq "easy"
 270     ? @reordered
 271     : 0 .. $last;    # reordered has CDROM up front
 272 #9...........
 273         },
 274
 275         'pbp5.def' => {
 276             source => "pbp5",
 277             params => "def",
 278             expect => <<'#10...........',
 279 # illustates problem with -pbp: -ci should not equal -i
 280 say 'ok_200_24_hours.value '
 281   . average(
 282     {
 283         '$and' =>
 284           [ { time => { '$gt', $time - 60 * 60 * 24 } }, { status => 200 } ]
 285     }
 286   );
 287
 288 #10...........
 289         },
 290
 291         'pbp5.pbp' => {
 292             source => "pbp5",
 293             params => "pbp",
 294             expect => <<'#11...........',
 295 # illustates problem with -pbp: -ci should not equal -i
 296 say 'ok_200_24_hours.value '
 297     . average(
 298     {   '$and' => [
 299             { time => { '$gt', $time - 60 * 60 * 24 } }, { status => 200 }
 300         ]
 301     }
 302     );
 303
 304 #11...........
 305         },
 306
 307         'print1.def' => {
 308             source => "print1",
 309             params => "def",
 310             expect => <<'#12...........',
 311 # same text twice. Has uncontained commas; -- leave as is
 312 print "conformability (Not the same dimension)\n",
 313   "\t",
 314   $have, " is ",
 315   text_unit($hu), "\n", "\t", $want, " is ", text_unit($wu), "\n",;
 316
 317 print
 318   "conformability (Not the same dimension)\n",
 319   "\t", $have, " is ", text_unit($hu), "\n",
 320   "\t", $want, " is ", text_unit($wu), "\n",
 321   ;
 322 #12...........
 323         },
 324
 325         'q1.def' => {
 326             source => "q1",
 327             params => "def",
 328             expect => <<'#13...........',
 329 print qq(You are in zone $thisTZ
 330 Difference with respect to GMT is ), $offset / 3600, qq( hours
 331 And local time is $hour hours $min minutes $sec seconds
 332 );
 333 #13...........
 334         },
 335
 336         'q2.def' => {
 337             source => "q2",
 338             params => "def",
 339             expect => <<'#14...........',
 340 $a = qq
 341 XHello World\nX;
 342 print "$a";
 343 #14...........
 344         },
 345
 346         'recombine1.def' => {
 347             source => "recombine1",
 348             params => "def",
 349             expect => <<'#15...........',
 350 # recombine '= [' here:
 351 $retarray =
 352   [ &{ $sth->{'xbase_parsed_sql'}{'selectfn'} }
 353       ( $xbase, $values, $sth->{'xbase_bind_values'} ) ]
 354   if defined $values;
 355 #15...........
 356         },
 357
 358         'recombine2.def' => {
 359             source => "recombine2",
 360             params => "def",
 361             expect => <<'#16...........',
 362     # recombine = unless old break there
 363     $a = [ length( $self->{fb}[-1] ), $#{ $self->{fb} } ]
 364       ;    # set cursor at end of buffer and print this cursor
 365 #16...........
 366         },
 367
 368         'recombine3.def' => {
 369             source => "recombine3",
 370             params => "def",
 371             expect => <<'#17...........',
 372         # recombine final line
 373         $command = (
 374             ( $catpage =~ m:\.gz: )
 375             ? $ZCAT
 376             : $CAT
 377         ) . " < $catpage";
 378 #17...........
 379         },
 380
 381         'recombine4.def' => {
 382             source => "recombine4",
 383             params => "def",
 384             expect => <<'#18...........',
 385     # do not recombine into two lines after a comma if
 386     # the term is complex (has parens) or changes level
 387     $delta_time = sprintf "%.4f",
 388       ( ( $done[0] + ( $done[1] / 1e6 ) ) -
 389           ( $start[0] + ( $start[1] / 1e6 ) ) );
 390 #18...........
 391         },
 392
 393         'rt101547.def' => {
 394             source => "rt101547",
 395             params => "def",
 396             expect => <<'#19...........',
 397 { source_host => MM::Config->instance->host // q{}, }
 398 #19...........
 399         },
 400
 401         'rt102371.def' => {
 402             source => "rt102371",
 403             params => "def",
 404             expect => <<'#20...........',
 405 state $b //= ccc();
 406 #20...........
 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         if ($err) {
 437             print STDERR
 438 "This error received calling Perl::Tidy with '$sname' + '$pname'\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             print STDERR
 446 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 447             ok( !$stderr_string );
 448         }
 449         if ($errorfile_string) {
 450             print STDERR "---------------------\n";
 451             print STDERR "<<.ERR file>>\n$errorfile_string\n";
 452             print STDERR "---------------------\n";
 453             print STDERR
 454 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 455             ok( !$errorfile_string );
 456         }
 457     }
 458     else {
 459         ok( $output, $expect );
 460     }
 461 }