t/snippets21.t

   1 # Created with: ./make_t.pl
   2
   3 # Contents:
   4 #1 lop.lop
   5 #2 switch_plain.def
   6 #3 switch_plain.switch_plain
   7 #4 sot.def
   8 #5 sot.sot
   9 #6 prune.def
  10 #7 align33.def
  11 #8 gnu7.def
  12 #9 gnu7.gnu
  13 #10 git33.def
  14 #11 git33.git33
  15 #12 rt133130.def
  16 #13 rt133130.rt133130
  17 #14 nib.def
  18 #15 nib.nib1
  19 #16 nib.nib2
  20 #17 scbb-csc.def
  21 #18 scbb-csc.scbb-csc
  22 #19 here_long.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         'git33' => <<'----------',
  42 -wls='->' -wrs='->'
  43
  44 ----------
  45         'gnu'  => "-gnu",
  46         'lop'  => "-nlop",
  47         'nib1' => "-nnib",
  48         'nib2' => <<'----------',
  49 -nib -nibp='#\+\+'
  50 ----------
  51         'rt133130' => <<'----------',
  52 # only the method should get a csc:
  53 -csc -cscl=sub -sal=method
  54 ----------
  55         'scbb-csc'     => "-scbb -csc",
  56         'sot'          => "-sot -sct",
  57         'switch_plain' => "-nola",
  58     };
  59
  60     ############################
  61     # BEGIN SECTION 2: Sources #
  62     ############################
  63     $rsources = {
  64
  65         'align33' => <<'----------',
  66 $wl  = int( $wl * $f + .5 );
  67 $wr  = int( $wr * $f + .5 );
  68 $pag = int( $pageh * $f + .5 );
  69 $fe  = $opt_F ? "t" : "f";
  70 $cf  = $opt_U ? "t" : "f";
  71 $tp  = $opt_t ? "t" : "f";
  72 $rm  = $numbstyle ? "t" : "f";
  73 $pa = $showurl   ? "t" : "f";
  74 $nh = $seq_number ? "t" : "f";
  75 ----------
  76
  77         'git33' => <<'----------',
  78 # test -wls='->' -wrs='->'
  79 use Net::Ping;
  80 my ($ping) = Net::Ping->new();
  81 $ping->ping($host);
  82
  83 ----------
  84
  85         'gnu7' => <<'----------',
  86 # hanging side comments
  87 if ( $seen == 1 ) {    # We're the first word so far to have
  88     # this abbreviation.
  89     $hashref->{$abbrev} = $word;
  90 }
  91 elsif ( $seen == 2 ) {    # We're the second word to have this
  92     # abbreviation, so we can't use it.
  93     delete $hashref->{$abbrev};
  94 }
  95 else {                    # We're the third word to have this
  96     # abbreviation, so skip to the next word.
  97     next WORD;
  98 }
  99 ----------
 100
 101         'here_long' => <<'----------',
 102 # must not break after here target regardless of maximum-line-length
 103 $sth= $dbh->prepare (<<"END_OF_SELECT") or die "Couldn't prepare SQL" ;
 104     SELECT COUNT(duration),SUM(duration)
 105     FROM logins WHERE username='$user'
 106 END_OF_SELECT
 107
 108 ----------
 109
 110         'lop' => <<'----------',
 111 # logical padding examples
 112 $same =
 113   (      ( $aP eq $bP )
 114       && ( $aS eq $bS )
 115       && ( $aT eq $bT )
 116       && ( $a->{'title'} eq $b->{'title'} )
 117       && ( $a->{'href'} eq $b->{'href'} ) );
 118
 119 $bits =
 120     $top > 0xffff ? 32
 121   : $top > 0xff   ? 16
 122   : $top > 1      ? 8
 123   :                 1;
 124
 125 lc( $self->mime_attr('content-type')
 126         || $self->{MIH_DefaultType}
 127         || 'text/plain' );
 128
 129 # Padding can also remove spaces; here the space after the '(' is lost:
 130 elsif ( $statement_type =~ /^sub\b/
 131     || $paren_type[$paren_depth] =~ /^sub\b/ )
 132 ----------
 133
 134         'nib' => <<'----------',
 135 {    #<<<
 136 {    #<<<
 137 {    #++
 138     print "hello world\n";
 139 }
 140 }
 141 }
 142
 143 {    #++
 144     {    #++
 145         {    #<<<
 146         print "hello world\n";
 147         }
 148     }
 149 }
 150
 151 ----------
 152
 153         'prune' => <<'----------',
 154 # some tests for 'sub prune_alignment_tree'
 155
 156 $request->header( 'User-Agent' => $agent )              if $agent;
 157 $request->header( 'From'       => $from )               if $from;
 158 $request->header( 'Range'      => "bytes=0-$max_size" ) if $max_size;
 159
 160 for (
 161     [ 'CONSTANT', sub { join "foo", "bar" },         0, "bar" ],
 162     [ 'CONSTANT', sub { join "foo", "bar", 3 },      1, "barfoo3" ],
 163     [ '$var',     sub { join $_, "bar" },            0, "bar" ],
 164     [ '$myvar',   sub { my $var; join $var, "bar" }, 0, "bar" ],
 165 );
 166
 167 [
 168     [ [NewXSHdr],     [ NewXSName, NewXSArgs ],            "XSHdr" ],
 169     [ [NewXSCHdrs],   [ NewXSName, NewXSArgs, GlobalNew ], "XSCHdrs" ],
 170     [ [DefSyms],      [StructName],                        "MkDefSyms" ],
 171     [ [NewXSSymTab],  [ DefSyms, NewXSArgs ],              "AddArgsyms" ],
 172     [ [NewXSLocals],  [NewXSSymTab],                       "Sym2Loc" ],
 173     [ [IsAffineFlag], [],                                  sub { return "0" } ],
 174 ];
 175
 176 @degen_nums[ 1, 2, 4, 8 ]         = ( 'a', 'c', 'g', 't' );
 177 @degen_nums[ 5, 10, 9, 6, 3, 12 ] = ( 'r', 'y', 'w', 's', 'm', 'k' );
 178 @degen_nums[ 14, 13, 11, 7, 15 ]  = ( 'b', 'd', 'h', 'v', 'n' );
 179
 180 $_CreateFile   = ff( "k32", "CreateFile",   [ P, N, N, N, N, N, N ], N );
 181 $_CloseHandle  = ff( "k32", "CloseHandle",  [N],                     N );
 182 $_GetCommState = ff( "k32", "GetCommState", [ N, P ],                I );
 183 $_SetCommState = ff( "k32", "SetCommState", [ N, P ],                I );
 184 $_SetupComm    = ff( "k32", "SetupComm",    [ N, N, N ],             I );
 185 $_PurgeComm    = ff( "k32", "PurgeComm",    [ N, N ],                I );
 186 $_CreateEvent  = ff( "k32", "CreateEvent",  [ P, I, I, P ],          N );
 187
 188
 189 is_deeply \@t, [
 190
 191  [3],  [0],  [1],  [0],
 192  3,   [1],  3,   [1],
 193  2,   [0],  [1],  [0],
 194  [1],  [1],  [1],  2,
 195  3,   [1],  2,   [3],
 196  4,   [ 7, 8 ],  9,   ["a"],
 197  "b",  3,   2,   5,
 198  3,   2,   5,   3,
 199   [2],    5,      4,      5,
 200   [ 3, 2, 1 ],  1,      2,      3,
 201   [ -1, -2, -3 ], [ -1, -2, -3 ], [ -1, -2, -3 ], [ -1, -2 ],
 202   3,      [ -1, -2 ],   3,      [ -1, -2, -3 ],
 203   [ !1 ],   [ 8, 7, 6 ],  [ 8, 7, 6 ],  [4],
 204   !!0,
 205 ];
 206 ----------
 207
 208         'rt133130' => <<'----------',
 209 method sum_radlinks {
 210     my ( $global_radiation_matrix, $local_radiation_matrix, $rngg ) = @_;
 211     my ( $i, $j, $n1, $n2, $num );
 212     my $rggij;
 213     $num = @$rngg;
 214     for ( $i = 0 ; $i < $num ; $i++ ) {
 215         $n1 = $rngg->[$i];
 216         for ( $j = 0 ; $j < $num ; $j++ ) {
 217             $n2    = $rngg->[$j];
 218             $rggij = $local_radiation_matrix->[$i][$j];
 219             if ( $rggij && ( $n1 != $n2 ) ) {
 220                 $global_radiation_matrix->[$n1][$n2] += $rggij;
 221             }
 222         }
 223     }
 224 }
 225 ----------
 226
 227         'scbb-csc' => <<'----------',
 228 sub perlmod_install_advice
 229 {
 230 my(@mod) = @_;
 231 if ($auto_install_cpan) {
 232 require AutoInstall::Tk;
 233 my $r = AutoInstall::Tk::do_autoinstall_tk(@mod);
 234 if ($r > 0) {
 235 for my $mod (@mod) {
 236 warn "Re-require $mod...\n";
 237 eval "require $mod";
 238 die __LINE__ . ": $@" if $@;
 239 }}
 240 }
 241 else {
 242 my $shell = ($os eq 'win' ? M"Eingabeaufforderung" : M"Shell");
 243 status_message
 244 (
 245 Mfmt(
 246 (
 247 @mod > 1
 248 ? "Die fehlenden Perl-Module können aus der %s mit dem Kommando\n"
 249 : "Das fehlende Perl-Modul kann aus der %s mit dem Kommando\n"
 250 ),
 251 $shell
 252 )
 253 .
 254 "    perl -MCPAN -e \"install " . join(", ", @mod) . "\"\n" .
 255 "aus dem Internet geholt und installiert werden.\n",
 256 "err"
 257 );
 258 }
 259 }
 260
 261 ----------
 262
 263         'sot' => <<'----------',
 264 $opt_c = Text::CSV_XS->new(
 265 {
 266     binary       => 1, sep_char     => $opt_c, always_quote => 1,
 267 }
 268 );
 269
 270 $c->Tk::bind(
 271 '<Control-f>' => sub {
 272 my ($c) = @_;
 273 my $e = $c->XEvent;
 274 itemsUnderArea $c;
 275 } );
 276
 277 __PACKAGE__->load_components( qw(
 278 PK::Auto
 279 Core
 280 ) );
 281 ----------
 282
 283         'switch_plain' => <<'----------',
 284 # run with -nola to keep default from outdenting
 285 use Switch::Plain;
 286 my $r = 'fail';
 287 my $x = int rand 100_000;
 288 nswitch (1 + $x * 2) {
 289     case $x: {}
 290     default: {
 291         $r = 'ok';
 292     }
 293 }
 294
 295 my @words = qw(cinnamon ginger nutmeg cloves);
 296 my $test = 1;
 297 $r = $test
 298   ? do {
 299     sswitch( $words[ rand @words ] ) {
 300         case $words[0]:
 301         case $words[1]:
 302         case $words[2]:
 303         case $words[3]: { 'ok' }
 304       default: { 'default case' }
 305     }
 306   }
 307   : 'not ok';
 308 ----------
 309     };
 310
 311     ####################################
 312     # BEGIN SECTION 3: Expected output #
 313     ####################################
 314     $rtests = {
 315
 316         'lop.lop' => {
 317             source => "lop",
 318             params => "lop",
 319             expect => <<'#1...........',
 320 # logical padding examples
 321 $same =
 322   ( ( $aP eq $bP )
 323       && ( $aS eq $bS )
 324       && ( $aT eq $bT )
 325       && ( $a->{'title'} eq $b->{'title'} )
 326       && ( $a->{'href'} eq $b->{'href'} ) );
 327
 328 $bits =
 329   $top > 0xffff ? 32
 330   : $top > 0xff ? 16
 331   : $top > 1    ? 8
 332   :               1;
 333
 334 lc( $self->mime_attr('content-type')
 335       || $self->{MIH_DefaultType}
 336       || 'text/plain' );
 337
 338 # Padding can also remove spaces; here the space after the '(' is lost:
 339 elsif ( $statement_type =~ /^sub\b/
 340     || $paren_type[$paren_depth] =~ /^sub\b/ )
 341 #1...........
 342         },
 343
 344         'switch_plain.def' => {
 345             source => "switch_plain",
 346             params => "def",
 347             expect => <<'#2...........',
 348 # run with -nola to keep default from outdenting
 349 use Switch::Plain;
 350 my $r = 'fail';
 351 my $x = int rand 100_000;
 352 nswitch( 1 + $x * 2 ) {
 353     case $x: { }
 354   default: {
 355         $r = 'ok';
 356     }
 357 }
 358
 359 my @words = qw(cinnamon ginger nutmeg cloves);
 360 my $test  = 1;
 361 $r = $test
 362   ? do {
 363     sswitch( $words[ rand @words ] ) {
 364         case $words[0]:
 365         case $words[1]:
 366         case $words[2]:
 367         case $words[3]: { 'ok' }
 368       default: { 'default case' }
 369     }
 370   }
 371   : 'not ok';
 372 #2...........
 373         },
 374
 375         'switch_plain.switch_plain' => {
 376             source => "switch_plain",
 377             params => "switch_plain",
 378             expect => <<'#3...........',
 379 # run with -nola to keep default from outdenting
 380 use Switch::Plain;
 381 my $r = 'fail';
 382 my $x = int rand 100_000;
 383 nswitch( 1 + $x * 2 ) {
 384     case $x: { }
 385     default: {
 386         $r = 'ok';
 387     }
 388 }
 389
 390 my @words = qw(cinnamon ginger nutmeg cloves);
 391 my $test  = 1;
 392 $r = $test
 393   ? do {
 394     sswitch( $words[ rand @words ] ) {
 395         case $words[0]:
 396         case $words[1]:
 397         case $words[2]:
 398         case $words[3]: { 'ok' }
 399         default: { 'default case' }
 400     }
 401   }
 402   : 'not ok';
 403 #3...........
 404         },
 405
 406         'sot.def' => {
 407             source => "sot",
 408             params => "def",
 409             expect => <<'#4...........',
 410 $opt_c = Text::CSV_XS->new(
 411     {
 412         binary       => 1,
 413         sep_char     => $opt_c,
 414         always_quote => 1,
 415     }
 416 );
 417
 418 $c->Tk::bind(
 419     '<Control-f>' => sub {
 420         my ($c) = @_;
 421         my $e = $c->XEvent;
 422         itemsUnderArea $c;
 423     }
 424 );
 425
 426 __PACKAGE__->load_components(
 427     qw(
 428       PK::Auto
 429       Core
 430     )
 431 );
 432 #4...........
 433         },
 434
 435         'sot.sot' => {
 436             source => "sot",
 437             params => "sot",
 438             expect => <<'#5...........',
 439 $opt_c = Text::CSV_XS->new( {
 440     binary       => 1,
 441     sep_char     => $opt_c,
 442     always_quote => 1,
 443 } );
 444
 445 $c->Tk::bind(
 446     '<Control-f>' => sub {
 447         my ($c) = @_;
 448         my $e = $c->XEvent;
 449         itemsUnderArea $c;
 450     } );
 451
 452 __PACKAGE__->load_components( qw(
 453       PK::Auto
 454       Core
 455 ) );
 456 #5...........
 457         },
 458
 459         'prune.def' => {
 460             source => "prune",
 461             params => "def",
 462             expect => <<'#6...........',
 463 # some tests for 'sub prune_alignment_tree'
 464
 465 $request->header( 'User-Agent' => $agent )              if $agent;
 466 $request->header( 'From'       => $from )               if $from;
 467 $request->header( 'Range'      => "bytes=0-$max_size" ) if $max_size;
 468
 469 for (
 470     [ 'CONSTANT', sub { join "foo", "bar" },         0, "bar" ],
 471     [ 'CONSTANT', sub { join "foo", "bar", 3 },      1, "barfoo3" ],
 472     [ '$var',     sub { join $_, "bar" },            0, "bar" ],
 473     [ '$myvar',   sub { my $var; join $var, "bar" }, 0, "bar" ],
 474 );
 475
 476 [
 477     [ [NewXSHdr],     [ NewXSName, NewXSArgs ],            "XSHdr" ],
 478     [ [NewXSCHdrs],   [ NewXSName, NewXSArgs, GlobalNew ], "XSCHdrs" ],
 479     [ [DefSyms],      [StructName],                        "MkDefSyms" ],
 480     [ [NewXSSymTab],  [ DefSyms, NewXSArgs ],              "AddArgsyms" ],
 481     [ [NewXSLocals],  [NewXSSymTab],                       "Sym2Loc" ],
 482     [ [IsAffineFlag], [],                                  sub { return "0" } ],
 483 ];
 484
 485 @degen_nums[ 1, 2, 4, 8 ]         = ( 'a', 'c', 'g', 't' );
 486 @degen_nums[ 5, 10, 9, 6, 3, 12 ] = ( 'r', 'y', 'w', 's', 'm', 'k' );
 487 @degen_nums[ 14, 13, 11, 7, 15 ]  = ( 'b', 'd', 'h', 'v', 'n' );
 488
 489 $_CreateFile   = ff( "k32", "CreateFile",   [ P, N, N, N, N, N, N ], N );
 490 $_CloseHandle  = ff( "k32", "CloseHandle",  [N],                     N );
 491 $_GetCommState = ff( "k32", "GetCommState", [ N, P ],                I );
 492 $_SetCommState = ff( "k32", "SetCommState", [ N, P ],                I );
 493 $_SetupComm    = ff( "k32", "SetupComm",    [ N, N, N ],             I );
 494 $_PurgeComm    = ff( "k32", "PurgeComm",    [ N, N ],                I );
 495 $_CreateEvent  = ff( "k32", "CreateEvent",  [ P, I, I, P ],          N );
 496
 497 is_deeply \@t, [
 498
 499     [3],            [0],            [1],            [0],
 500     3,              [1],            3,              [1],
 501     2,              [0],            [1],            [0],
 502     [1],            [1],            [1],            2,
 503     3,              [1],            2,              [3],
 504     4,              [ 7, 8 ],       9,              ["a"],
 505     "b",            3,              2,              5,
 506     3,              2,              5,              3,
 507     [2],            5,              4,              5,
 508     [ 3, 2, 1 ],    1,              2,              3,
 509     [ -1, -2, -3 ], [ -1, -2, -3 ], [ -1, -2, -3 ], [ -1, -2 ],
 510     3,              [ -1, -2 ],     3,              [ -1, -2, -3 ],
 511     [ !1 ],         [ 8, 7, 6 ],    [ 8, 7, 6 ],    [4],
 512     !!0,
 513 ];
 514 #6...........
 515         },
 516
 517         'align33.def' => {
 518             source => "align33",
 519             params => "def",
 520             expect => <<'#7...........',
 521 $wl  = int( $wl * $f + .5 );
 522 $wr  = int( $wr * $f + .5 );
 523 $pag = int( $pageh * $f + .5 );
 524 $fe  = $opt_F      ? "t" : "f";
 525 $cf  = $opt_U      ? "t" : "f";
 526 $tp  = $opt_t      ? "t" : "f";
 527 $rm  = $numbstyle  ? "t" : "f";
 528 $pa  = $showurl    ? "t" : "f";
 529 $nh  = $seq_number ? "t" : "f";
 530 #7...........
 531         },
 532
 533         'gnu7.def' => {
 534             source => "gnu7",
 535             params => "def",
 536             expect => <<'#8...........',
 537 # hanging side comments
 538 if ( $seen == 1 ) {    # We're the first word so far to have
 539                        # this abbreviation.
 540     $hashref->{$abbrev} = $word;
 541 }
 542 elsif ( $seen == 2 ) {    # We're the second word to have this
 543                           # abbreviation, so we can't use it.
 544     delete $hashref->{$abbrev};
 545 }
 546 else {    # We're the third word to have this
 547           # abbreviation, so skip to the next word.
 548     next WORD;
 549 }
 550 #8...........
 551         },
 552
 553         'gnu7.gnu' => {
 554             source => "gnu7",
 555             params => "gnu",
 556             expect => <<'#9...........',
 557 # hanging side comments
 558 if ($seen == 1)
 559 {    # We're the first word so far to have
 560      # this abbreviation.
 561     $hashref->{$abbrev} = $word;
 562 }
 563 elsif ($seen == 2)
 564 {    # We're the second word to have this
 565      # abbreviation, so we can't use it.
 566     delete $hashref->{$abbrev};
 567 }
 568 else
 569 {    # We're the third word to have this
 570      # abbreviation, so skip to the next word.
 571     next WORD;
 572 }
 573 #9...........
 574         },
 575
 576         'git33.def' => {
 577             source => "git33",
 578             params => "def",
 579             expect => <<'#10...........',
 580 # test -wls='->' -wrs='->'
 581 use Net::Ping;
 582 my ($ping) = Net::Ping->new();
 583 $ping->ping($host);
 584
 585 #10...........
 586         },
 587
 588         'git33.git33' => {
 589             source => "git33",
 590             params => "git33",
 591             expect => <<'#11...........',
 592 # test -wls='->' -wrs='->'
 593 use Net::Ping;
 594 my ($ping) = Net::Ping -> new();
 595 $ping -> ping($host);
 596
 597 #11...........
 598         },
 599
 600         'rt133130.def' => {
 601             source => "rt133130",
 602             params => "def",
 603             expect => <<'#12...........',
 604 method sum_radlinks {
 605     my ( $global_radiation_matrix, $local_radiation_matrix, $rngg ) = @_;
 606     my ( $i, $j, $n1, $n2, $num );
 607     my $rggij;
 608     $num = @$rngg;
 609     for ( $i = 0 ; $i < $num ; $i++ ) {
 610         $n1 = $rngg->[$i];
 611         for ( $j = 0 ; $j < $num ; $j++ ) {
 612             $n2    = $rngg->[$j];
 613             $rggij = $local_radiation_matrix->[$i][$j];
 614             if ( $rggij && ( $n1 != $n2 ) ) {
 615                 $global_radiation_matrix->[$n1][$n2] += $rggij;
 616             }
 617         }
 618     }
 619 }
 620 #12...........
 621         },
 622
 623         'rt133130.rt133130' => {
 624             source => "rt133130",
 625             params => "rt133130",
 626             expect => <<'#13...........',
 627 method sum_radlinks {
 628     my ( $global_radiation_matrix, $local_radiation_matrix, $rngg ) = @_;
 629     my ( $i, $j, $n1, $n2, $num );
 630     my $rggij;
 631     $num = @$rngg;
 632     for ( $i = 0 ; $i < $num ; $i++ ) {
 633         $n1 = $rngg->[$i];
 634         for ( $j = 0 ; $j < $num ; $j++ ) {
 635             $n2    = $rngg->[$j];
 636             $rggij = $local_radiation_matrix->[$i][$j];
 637             if ( $rggij && ( $n1 != $n2 ) ) {
 638                 $global_radiation_matrix->[$n1][$n2] += $rggij;
 639             }
 640         }
 641     }
 642 } ## end sub sum_radlinks
 643 #13...........
 644         },
 645
 646         'nib.def' => {
 647             source => "nib",
 648             params => "def",
 649             expect => <<'#14...........',
 650 { #<<<
 651 { #<<<
 652 {    #++
 653     print "hello world\n";
 654 }
 655 }
 656 }
 657
 658 {    #++
 659     {    #++
 660         { #<<<
 661         print "hello world\n";
 662         }
 663     }
 664 }
 665
 666 #14...........
 667         },
 668
 669         'nib.nib1' => {
 670             source => "nib",
 671             params => "nib1",
 672             expect => <<'#15...........',
 673 {    #<<<
 674     {    #<<<
 675         {    #++
 676             print "hello world\n";
 677         }
 678     }
 679 }
 680
 681 {    #++
 682     {    #++
 683         {    #<<<
 684             print "hello world\n";
 685         }
 686     }
 687 }
 688
 689 #15...........
 690         },
 691
 692         'nib.nib2' => {
 693             source => "nib",
 694             params => "nib2",
 695             expect => <<'#16...........',
 696 {    #<<<
 697     {    #<<<
 698         { #++
 699         print "hello world\n";
 700         }
 701     }
 702 }
 703
 704 { #++
 705 { #++
 706 {    #<<<
 707     print "hello world\n";
 708 }
 709 }
 710 }
 711
 712 #16...........
 713         },
 714
 715         'scbb-csc.def' => {
 716             source => "scbb-csc",
 717             params => "def",
 718             expect => <<'#17...........',
 719 sub perlmod_install_advice {
 720     my (@mod) = @_;
 721     if ($auto_install_cpan) {
 722         require AutoInstall::Tk;
 723         my $r = AutoInstall::Tk::do_autoinstall_tk(@mod);
 724         if ( $r > 0 ) {
 725             for my $mod (@mod) {
 726                 warn "Re-require $mod...\n";
 727                 eval "require $mod";
 728                 die __LINE__ . ": $@" if $@;
 729             }
 730         }
 731     }
 732     else {
 733         my $shell = ( $os eq 'win' ? M "Eingabeaufforderung" : M "Shell" );
 734         status_message(
 735             Mfmt(
 736                 (
 737                     @mod > 1
 738                     ? "Die fehlenden Perl-Module können aus der %s mit dem Kommando\n"
 739                     : "Das fehlende Perl-Modul kann aus der %s mit dem Kommando\n"
 740                 ),
 741                 $shell
 742               )
 743               . "    perl -MCPAN -e \"install "
 744               . join( ", ", @mod ) . "\"\n"
 745               . "aus dem Internet geholt und installiert werden.\n",
 746             "err"
 747         );
 748     }
 749 }
 750
 751 #17...........
 752         },
 753
 754         'scbb-csc.scbb-csc' => {
 755             source => "scbb-csc",
 756             params => "scbb-csc",
 757             expect => <<'#18...........',
 758 sub perlmod_install_advice {
 759     my (@mod) = @_;
 760     if ($auto_install_cpan) {
 761         require AutoInstall::Tk;
 762         my $r = AutoInstall::Tk::do_autoinstall_tk(@mod);
 763         if ( $r > 0 ) {
 764             for my $mod (@mod) {
 765                 warn "Re-require $mod...\n";
 766                 eval "require $mod";
 767                 die __LINE__ . ": $@" if $@;
 768             }
 769         } ## end if ( $r > 0 )
 770     } ## end if ($auto_install_cpan)
 771     else {
 772         my $shell = ( $os eq 'win' ? M "Eingabeaufforderung" : M "Shell" );
 773         status_message(
 774             Mfmt(
 775                 (
 776                     @mod > 1
 777                     ? "Die fehlenden Perl-Module können aus der %s mit dem Kommando\n"
 778                     : "Das fehlende Perl-Modul kann aus der %s mit dem Kommando\n"
 779                 ),
 780                 $shell
 781               )
 782               . "    perl -MCPAN -e \"install "
 783               . join( ", ", @mod ) . "\"\n"
 784               . "aus dem Internet geholt und installiert werden.\n",
 785             "err"
 786         );
 787     } ## end else [ if ($auto_install_cpan)]
 788 } ## end sub perlmod_install_advice
 789
 790 #18...........
 791         },
 792
 793         'here_long.def' => {
 794             source => "here_long",
 795             params => "def",
 796             expect => <<'#19...........',
 797 # must not break after here target regardless of maximum-line-length
 798 $sth = $dbh->prepare(<<"END_OF_SELECT") or die "Couldn't prepare SQL";
 799     SELECT COUNT(duration),SUM(duration)
 800     FROM logins WHERE username='$user'
 801 END_OF_SELECT
 802
 803 #19...........
 804         },
 805     };
 806
 807     my $ntests = 0 + keys %{$rtests};
 808     plan tests => $ntests;
 809 }
 810
 811 ###############
 812 # EXECUTE TESTS
 813 ###############
 814
 815 foreach my $key ( sort keys %{$rtests} ) {
 816     my $output;
 817     my $sname  = $rtests->{$key}->{source};
 818     my $expect = $rtests->{$key}->{expect};
 819     my $pname  = $rtests->{$key}->{params};
 820     my $source = $rsources->{$sname};
 821     my $params = defined($pname) ? $rparams->{$pname} : "";
 822     my $stderr_string;
 823     my $errorfile_string;
 824     my $err = Perl::Tidy::perltidy(
 825         source      => \$source,
 826         destination => \$output,
 827         perltidyrc  => \$params,
 828         argv        => '',             # for safety; hide any ARGV from perltidy
 829         stderr      => \$stderr_string,
 830         errorfile   => \$errorfile_string,    # not used when -se flag is set
 831     );
 832     if ( $err || $stderr_string || $errorfile_string ) {
 833         print STDERR "Error output received for test '$key'\n";
 834         if ($err) {
 835             print STDERR "An error flag '$err' was returned\n";
 836             ok( !$err );
 837         }
 838         if ($stderr_string) {
 839             print STDERR "---------------------\n";
 840             print STDERR "<<STDERR>>\n$stderr_string\n";
 841             print STDERR "---------------------\n";
 842             ok( !$stderr_string );
 843         }
 844         if ($errorfile_string) {
 845             print STDERR "---------------------\n";
 846             print STDERR "<<.ERR file>>\n$errorfile_string\n";
 847             print STDERR "---------------------\n";
 848             ok( !$errorfile_string );
 849         }
 850     }
 851     else {
 852         if ( !is( $output, $expect, $key ) ) {
 853             my $leno = length($output);
 854             my $lene = length($expect);
 855             if ( $leno == $lene ) {
 856                 print STDERR
 857 "#> Test '$key' gave unexpected output.  Strings differ but both have length $leno\n";
 858             }
 859             else {
 860                 print STDERR
 861 "#> Test '$key' gave unexpected output.  String lengths differ: output=$leno, expected=$lene\n";
 862             }
 863         }
 864     }
 865 }