t/snippets1.t

   1 # Created with: ./make_t.pl
   2
   3 # Contents:
   4 #1 105484.def
   5 #2 align1.def
   6 #3 align2.def
   7 #4 align3.def
   8 #5 align4.def
   9 #6 align5.def
  10 #7 align6.def
  11 #8 align7.def
  12 #9 align8.def
  13 #10 align9.def
  14 #11 andor1.def
  15 #12 andor10.def
  16 #13 andor2.def
  17 #14 andor3.def
  18 #15 andor4.def
  19 #16 andor5.def
  20 #17 andor6.def
  21 #18 andor7.def
  22 #19 andor8.def
  23 #20 andor9.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 = { 'def' => "", };
  41
  42     ############################
  43     # BEGIN SECTION 2: Sources #
  44     ############################
  45     $rsources = {
  46
  47         '105484' => <<'----------',
  48 switch (1) {
  49     case x { 2 } else { }
  50 }
  51 ----------
  52
  53         'align1' => <<'----------',
  54 return ( $fetch_key eq $fk
  55       && $store_key eq $sk
  56       && $fetch_value eq $fv
  57       && $store_value eq $sv
  58       && $_ eq 'original' );
  59 ----------
  60
  61         'align2' => <<'----------',
  62 same =
  63   (      ( $aP eq $bP )
  64       && ( $aS eq $bS )
  65       && ( $aT eq $bT )
  66       && ( $a->{'title'} eq $b->{'title'} )
  67       && ( $a->{'href'} eq $b->{'href'} ) );
  68 ----------
  69
  70         'align3' => <<'----------',
  71 # This greatly improved after dropping 'ne' and 'eq':
  72 if (
  73     $dir eq $updir           and    # if we have an updir
  74     @collapsed               and    # and something to collapse
  75     length $collapsed[-1]    and    # and its not the rootdir
  76     $collapsed[-1] ne $updir and    # nor another updir
  77     $collapsed[-1] ne $curdir       # nor the curdir
  78   ) { $bla}
  79 ----------
  80
  81         'align4' => <<'----------',
  82 # removed 'eq' and '=~' from alignment tokens to get alignment of '?'s
  83 my $salute =
  84     $name eq $EMPTY_STR                      ? 'Customer'
  85   : $name =~ m/\A((?:Sir|Dame) \s+ \S+) /xms ? $1
  86   : $name =~ m/(.*), \s+ Ph[.]?D \z     /xms ? "Dr $1"
  87   :                                            $name;
  88 ----------
  89
  90         'align5' => <<'----------',
  91 # some lists
  92 printline( "Broadcast", &bintodq($b),    ( $b,    $mask, $bcolor, 0 ) );
  93 printline( "HostMin",   &bintodq($hmin), ( $hmin, $mask, $bcolor, 0 ) );
  94 printline( "HostMax",   &bintodq($hmax), ( $hmax, $mask, $bcolor, 0 ) );
  95 ----------
  96
  97         'align6' => <<'----------',
  98 # align opening parens
  99 if ( ( index( $msg_line_lc, $nick1 ) != -1 ) ||
 100      ( index( $msg_line_lc, $nick2 ) != -1 ) ||
 101      ( index( $msg_line_lc, $nick3 ) != -1 ) ) {
 102     do_something();
 103 }
 104 ----------
 105
 106         'align7' => <<'----------',
 107 # Alignment with two fat commas in second line
 108 my $ct = Courriel::Header::ContentType->new(
 109     mime_type  => 'multipart/alternative',
 110     attributes => { boundary => unique_boundary },
 111 );
 112 ----------
 113
 114         'align8' => <<'----------',
 115 # aligning '=' and padding 'if'
 116 if    ( $tag == 263 ) { $bbi->{"Info.Thresholding"}   = $value }
 117 elsif ( $tag == 264 ) { $bbi->{"Info.CellWidth"}      = $value }
 118 elsif ( $tag == 265 ) { $bbi->{"Info.CellLength"}     = $value }
 119 ----------
 120
 121         'align9' => <<'----------',
 122 # test of aligning ||
 123 my $os =
 124   ( $ExtUtils::MM_Unix::Is_OS2   || 0 ) +
 125   ( $ExtUtils::MM_Unix::Is_Mac   || 0 ) +
 126   ( $ExtUtils::MM_Unix::Is_Win32 || 0 ) +
 127   ( $ExtUtils::MM_Unix::Is_Dos   || 0 ) +
 128   ( $ExtUtils::MM_Unix::Is_VMS   || 0 );
 129 ----------
 130
 131         'andor1' => <<'----------',
 132 return 1 if $det_a < 0 and $det_b > 0 or
 133             $det_a > 0 and $det_b < 0;
 134 ----------
 135
 136         'andor10' => <<'----------',
 137 if ( (       ($a) and ( $b == 13 ) and ( $c - 24 = 0 ) and ("test")
 138          and ( $rudolph eq "reindeer" or $rudolph eq "red nosed" )
 139          and $test
 140      ) or ( $nobody and ( $noone or $none ) )
 141   )
 142 { $i++; }
 143 ----------
 144
 145         'andor2' => <<'----------',
 146 # breaks at = or at && but not both
 147 my $success = ( system("$Config{cc} -o $te $tc $libs $HIDE") == 0 ) && -e $te ? 1 : 0;
 148 ----------
 149
 150         'andor3' => <<'----------',
 151 ok(       ( $obj->name() eq $obj2->name() )
 152       and ( $obj->version() eq $obj2->version() )
 153       and ( $obj->help()    eq $obj2->help() ) );
 154 ----------
 155
 156         'andor4' => <<'----------',
 157     if ( !$verbose_error && ( !$options->{'log'}
 158           && ( ( $options->{'verbose'} & 8 ) || ( $options->{'verbose'} & 16 )
 159               || ( $options->{'verbose'} & 32 )
 160               || ( $options->{'verbose'} & 64 ) ) ) )
 161 ----------
 162
 163         'andor5' => <<'----------',
 164     # two levels of && with side comments
 165     if (
 166         defined &syscopy
 167         && \&syscopy != \&copy
 168         && !$to_a_handle
 169         && !( $from_a_handle && $^O eq 'os2' )      # OS/2 cannot handle
 170         && !( $from_a_handle && $^O eq 'mpeix' )    # and neither can MPE/iX.
 171       )
 172     {
 173         return syscopy( $from, $to );
 174     }
 175 ----------
 176
 177         'andor6' => <<'----------',
 178 # Example of nested ands and ors
 179 sub is_miniwhile {    # check for one-line loop (`foo() while $y--')
 180     my $op = shift;
 181     return (
 182               !null($op) and null( $op->sibling )
 183           and $op->ppaddr eq "pp_null"
 184           and class($op) eq "UNOP"
 185           and (
 186             (
 187                     $op->first->ppaddr =~ /^pp_(and|or)$/
 188                 and $op->first->first->sibling->ppaddr eq "pp_lineseq"
 189             )
 190             or (    $op->first->ppaddr eq "pp_lineseq"
 191                 and not null $op->first->first->sibling
 192                 and $op->first->first->sibling->ppaddr eq "pp_unstack" )
 193           )
 194     );
 195 }
 196 ----------
 197
 198         'andor7' => <<'----------',
 199         # original is single line:
 200         $a = 1 if $l and !$r or !$l and $r;
 201 ----------
 202
 203         'andor8' => <<'----------',
 204         # original is broken:
 205         $a = 1
 206         if $l and !$r or !$l and $r;
 207 ----------
 208
 209         'andor9' => <<'----------',
 210 if ( (      ( $old_new and $old_new eq 'changed' )
 211         and ( $db_new and $db_new eq 'changed' )
 212         and ( not defined $old_db )
 213      ) or ( ( $old_new and $old_new eq 'changed' )
 214         and ( $db_new and $db_new eq 'new' )
 215         and ( $old_db and $old_db eq 'new' )
 216      ) or ( ( $old_new and $old_new eq 'new' )
 217         and ( $db_new and $db_new eq 'new' )
 218         and ( not defined $old_db )
 219    ) )
 220 {
 221     return "update";
 222 }
 223 ----------
 224     };
 225
 226     ####################################
 227     # BEGIN SECTION 3: Expected output #
 228     ####################################
 229     $rtests = {
 230
 231         '105484.def' => {
 232             source => "105484",
 233             params => "def",
 234             expect => <<'#1...........',
 235 switch (1) {
 236     case x { 2 } else { }
 237 }
 238 #1...........
 239         },
 240
 241         'align1.def' => {
 242             source => "align1",
 243             params => "def",
 244             expect => <<'#2...........',
 245 return ( $fetch_key eq $fk
 246       && $store_key eq $sk
 247       && $fetch_value eq $fv
 248       && $store_value eq $sv
 249       && $_ eq 'original' );
 250 #2...........
 251         },
 252
 253         'align2.def' => {
 254             source => "align2",
 255             params => "def",
 256             expect => <<'#3...........',
 257 same =
 258   (      ( $aP eq $bP )
 259       && ( $aS eq $bS )
 260       && ( $aT eq $bT )
 261       && ( $a->{'title'} eq $b->{'title'} )
 262       && ( $a->{'href'} eq $b->{'href'} ) );
 263 #3...........
 264         },
 265
 266         'align3.def' => {
 267             source => "align3",
 268             params => "def",
 269             expect => <<'#4...........',
 270 # This greatly improved after dropping 'ne' and 'eq':
 271 if (
 272     $dir eq $updir           and    # if we have an updir
 273     @collapsed               and    # and something to collapse
 274     length $collapsed[-1]    and    # and its not the rootdir
 275     $collapsed[-1] ne $updir and    # nor another updir
 276     $collapsed[-1] ne $curdir       # nor the curdir
 277   )
 278 {
 279     $bla;
 280 }
 281 #4...........
 282         },
 283
 284         'align4.def' => {
 285             source => "align4",
 286             params => "def",
 287             expect => <<'#5...........',
 288 # removed 'eq' and '=~' from alignment tokens to get alignment of '?'s
 289 my $salute =
 290     $name eq $EMPTY_STR                      ? 'Customer'
 291   : $name =~ m/\A((?:Sir|Dame) \s+ \S+) /xms ? $1
 292   : $name =~ m/(.*), \s+ Ph[.]?D \z     /xms ? "Dr $1"
 293   :                                            $name;
 294 #5...........
 295         },
 296
 297         'align5.def' => {
 298             source => "align5",
 299             params => "def",
 300             expect => <<'#6...........',
 301 # some lists
 302 printline( "Broadcast", &bintodq($b),    ( $b,    $mask, $bcolor, 0 ) );
 303 printline( "HostMin",   &bintodq($hmin), ( $hmin, $mask, $bcolor, 0 ) );
 304 printline( "HostMax",   &bintodq($hmax), ( $hmax, $mask, $bcolor, 0 ) );
 305 #6...........
 306         },
 307
 308         'align6.def' => {
 309             source => "align6",
 310             params => "def",
 311             expect => <<'#7...........',
 312 # align opening parens
 313 if (   ( index( $msg_line_lc, $nick1 ) != -1 )
 314     || ( index( $msg_line_lc, $nick2 ) != -1 )
 315     || ( index( $msg_line_lc, $nick3 ) != -1 ) )
 316 {
 317     do_something();
 318 }
 319 #7...........
 320         },
 321
 322         'align7.def' => {
 323             source => "align7",
 324             params => "def",
 325             expect => <<'#8...........',
 326 # Alignment with two fat commas in second line
 327 my $ct = Courriel::Header::ContentType->new(
 328     mime_type  => 'multipart/alternative',
 329     attributes => { boundary => unique_boundary },
 330 );
 331 #8...........
 332         },
 333
 334         'align8.def' => {
 335             source => "align8",
 336             params => "def",
 337             expect => <<'#9...........',
 338 # aligning '=' and padding 'if'
 339 if    ( $tag == 263 ) { $bbi->{"Info.Thresholding"} = $value }
 340 elsif ( $tag == 264 ) { $bbi->{"Info.CellWidth"}    = $value }
 341 elsif ( $tag == 265 ) { $bbi->{"Info.CellLength"}   = $value }
 342 #9...........
 343         },
 344
 345         'align9.def' => {
 346             source => "align9",
 347             params => "def",
 348             expect => <<'#10...........',
 349 # test of aligning ||
 350 my $os =
 351   ( $ExtUtils::MM_Unix::Is_OS2   || 0 ) +
 352   ( $ExtUtils::MM_Unix::Is_Mac   || 0 ) +
 353   ( $ExtUtils::MM_Unix::Is_Win32 || 0 ) +
 354   ( $ExtUtils::MM_Unix::Is_Dos   || 0 ) +
 355   ( $ExtUtils::MM_Unix::Is_VMS   || 0 );
 356 #10...........
 357         },
 358
 359         'andor1.def' => {
 360             source => "andor1",
 361             params => "def",
 362             expect => <<'#11...........',
 363 return 1
 364   if $det_a < 0 and $det_b > 0
 365   or $det_a > 0 and $det_b < 0;
 366 #11...........
 367         },
 368
 369         'andor10.def' => {
 370             source => "andor10",
 371             params => "def",
 372             expect => <<'#12...........',
 373 if (
 374     (
 375             ($a)
 376         and ( $b == 13 )
 377         and ( $c - 24 = 0 )
 378         and ("test")
 379         and ( $rudolph eq "reindeer" or $rudolph eq "red nosed" )
 380         and $test
 381     )
 382     or ( $nobody and ( $noone or $none ) )
 383   )
 384 {
 385     $i++;
 386 }
 387 #12...........
 388         },
 389
 390         'andor2.def' => {
 391             source => "andor2",
 392             params => "def",
 393             expect => <<'#13...........',
 394 # breaks at = or at && but not both
 395 my $success =
 396   ( system("$Config{cc} -o $te $tc $libs $HIDE") == 0 ) && -e $te ? 1 : 0;
 397 #13...........
 398         },
 399
 400         'andor3.def' => {
 401             source => "andor3",
 402             params => "def",
 403             expect => <<'#14...........',
 404 ok(       ( $obj->name() eq $obj2->name() )
 405       and ( $obj->version() eq $obj2->version() )
 406       and ( $obj->help() eq $obj2->help() ) );
 407 #14...........
 408         },
 409
 410         'andor4.def' => {
 411             source => "andor4",
 412             params => "def",
 413             expect => <<'#15...........',
 414     if (
 415         !$verbose_error
 416         && (
 417             !$options->{'log'}
 418             && (   ( $options->{'verbose'} & 8 )
 419                 || ( $options->{'verbose'} & 16 )
 420                 || ( $options->{'verbose'} & 32 )
 421                 || ( $options->{'verbose'} & 64 ) )
 422         )
 423       )
 424 #15...........
 425         },
 426
 427         'andor5.def' => {
 428             source => "andor5",
 429             params => "def",
 430             expect => <<'#16...........',
 431     # two levels of && with side comments
 432     if (
 433            defined &syscopy
 434         && \&syscopy != \&copy
 435         && !$to_a_handle
 436         && !( $from_a_handle && $^O eq 'os2' )      # OS/2 cannot handle
 437         && !( $from_a_handle && $^O eq 'mpeix' )    # and neither can MPE/iX.
 438       )
 439     {
 440         return syscopy( $from, $to );
 441     }
 442 #16...........
 443         },
 444
 445         'andor6.def' => {
 446             source => "andor6",
 447             params => "def",
 448             expect => <<'#17...........',
 449 # Example of nested ands and ors
 450 sub is_miniwhile {    # check for one-line loop (`foo() while $y--')
 451     my $op = shift;
 452     return (
 453               !null($op) and null( $op->sibling )
 454           and $op->ppaddr eq "pp_null"
 455           and class($op) eq "UNOP"
 456           and (
 457             (
 458                     $op->first->ppaddr =~ /^pp_(and|or)$/
 459                 and $op->first->first->sibling->ppaddr eq "pp_lineseq"
 460             )
 461             or (    $op->first->ppaddr eq "pp_lineseq"
 462                 and not null $op->first->first->sibling
 463                 and $op->first->first->sibling->ppaddr eq "pp_unstack" )
 464           )
 465     );
 466 }
 467 #17...........
 468         },
 469
 470         'andor7.def' => {
 471             source => "andor7",
 472             params => "def",
 473             expect => <<'#18...........',
 474         # original is single line:
 475         $a = 1 if $l and !$r or !$l and $r;
 476 #18...........
 477         },
 478
 479         'andor8.def' => {
 480             source => "andor8",
 481             params => "def",
 482             expect => <<'#19...........',
 483         # original is broken:
 484         $a = 1
 485           if $l  and !$r
 486           or !$l and $r;
 487 #19...........
 488         },
 489
 490         'andor9.def' => {
 491             source => "andor9",
 492             params => "def",
 493             expect => <<'#20...........',
 494 if (
 495     (
 496             ( $old_new and $old_new eq 'changed' )
 497         and ( $db_new  and $db_new eq 'changed' )
 498         and ( not defined $old_db )
 499     )
 500     or (    ( $old_new and $old_new eq 'changed' )
 501         and ( $db_new and $db_new eq 'new' )
 502         and ( $old_db and $old_db eq 'new' ) )
 503     or (    ( $old_new and $old_new eq 'new' )
 504         and ( $db_new and $db_new eq 'new' )
 505         and ( not defined $old_db ) )
 506   )
 507 {
 508     return "update";
 509 }
 510 #20...........
 511         },
 512     };
 513
 514     my $ntests = 0 + keys %{$rtests};
 515     plan tests => $ntests;
 516 }
 517
 518 ###############
 519 # EXECUTE TESTS
 520 ###############
 521
 522 foreach my $key ( sort keys %{$rtests} ) {
 523     my $output;
 524     my $sname  = $rtests->{$key}->{source};
 525     my $expect = $rtests->{$key}->{expect};
 526     my $pname  = $rtests->{$key}->{params};
 527     my $source = $rsources->{$sname};
 528     my $params = defined($pname) ? $rparams->{$pname} : "";
 529     my $stderr_string;
 530     my $errorfile_string;
 531     my $err = Perl::Tidy::perltidy(
 532         source      => \$source,
 533         destination => \$output,
 534         perltidyrc  => \$params,
 535         argv        => '',             # for safety; hide any ARGV from perltidy
 536         stderr      => \$stderr_string,
 537         errorfile => \$errorfile_string,    # not used when -se flag is set
 538     );
 539     if ( $err || $stderr_string || $errorfile_string ) {
 540         if ($err) {
 541             print STDERR
 542 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 543             ok( !$err );
 544         }
 545         if ($stderr_string) {
 546             print STDERR "---------------------\n";
 547             print STDERR "<<STDERR>>\n$stderr_string\n";
 548             print STDERR "---------------------\n";
 549             print STDERR
 550 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 551             ok( !$stderr_string );
 552         }
 553         if ($errorfile_string) {
 554             print STDERR "---------------------\n";
 555             print STDERR "<<.ERR file>>\n$errorfile_string\n";
 556             print STDERR "---------------------\n";
 557             print STDERR
 558 "This error received calling Perl::Tidy with '$sname' + '$pname'\n";
 559             ok( !$errorfile_string );
 560         }
 561     }
 562     else {
 563         ok( $output, $expect );
 564     }
 565 }