ext/Devel/PPPort/parts/inc/ppphtest

   1 ################################################################################
   2 ##
   3 ##  $Revision: 46 $
   4 ##  $Author: mhx $
   5 ##  $Date: 2009/01/23 18:28:00 +0100 $
   6 ##
   7 ################################################################################
   8 ##
   9 ##  Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz.
  10 ##  Version 2.x, Copyright (C) 2001, Paul Marquess.
  11 ##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
  12 ##
  13 ##  This program is free software; you can redistribute it and/or
  14 ##  modify it under the same terms as Perl itself.
  15 ##
  16 ################################################################################
  17
  18 =tests plan => 235
  19
  20 BEGIN {
  21   if ($ENV{'SKIP_SLOW_TESTS'}) {
  22     for (1 .. 235) {
  23       skip("skip: SKIP_SLOW_TESTS", 0);
  24     }
  25     exit 0;
  26   }
  27 }
  28
  29 use File::Path qw/rmtree mkpath/;
  30 use Config;
  31
  32 my $tmp = 'ppptmp';
  33 my $inc = '';
  34 my $isVMS = $^O eq 'VMS';
  35 my $isMAC = $^O eq 'MacOS';
  36 my $perl = find_perl();
  37
  38 rmtree($tmp) if -d $tmp;
  39 mkpath($tmp) or die "mkpath $tmp: $!\n";
  40 chdir($tmp) or die "chdir $tmp: $!\n";
  41
  42 if ($ENV{'PERL_CORE'}) {
  43   if (-d '../../lib') {
  44     if ($isVMS) {
  45       $inc = '"-I../../lib"';
  46     }
  47     elsif ($isMAC) {
  48       $inc = '-I:::lib';
  49     }
  50     else {
  51       $inc = '-I../../lib';
  52     }
  53     unshift @INC, '../../lib';
  54   }
  55 }
  56 if ($perl =~ m!^\./!) {
  57   $perl = ".$perl";
  58 }
  59
  60 END {
  61   chdir('..') if !-d $tmp && -d "../$tmp";
  62   rmtree($tmp) if -d $tmp;
  63 }
  64
  65 ok(&Devel::PPPort::WriteFile("ppport.h"));
  66
  67 sub comment
  68 {
  69   my $c = shift;
  70   $c =~ s/^/# | /mg;
  71   $c .= "\n" unless $c =~ /[\r\n]$/;
  72   print $c;
  73 }
  74
  75 sub ppport
  76 {
  77   my @args = ('ppport.h', @_);
  78   unshift @args, $inc if $inc;
  79   my $run = $perl =~ m/\s/ ? qq("$perl") : $perl;
  80   $run .= ' -MMac::err=unix' if $isMAC;
  81   for (@args) {
  82     $_ = qq("$_") if $isVMS && /^[^"]/;
  83     $run .= " $_";
  84   }
  85   print "# *** running $run ***\n";
  86   $run .= ' 2>&1' unless $isMAC;
  87   my @out = `$run`;
  88   my $out = join '', @out;
  89   comment($out);
  90   return wantarray ? @out : $out;
  91 }
  92
  93 sub matches
  94 {
  95   my($str, $re, $mod) = @_;
  96   my @n;
  97   eval "\@n = \$str =~ /$re/g$mod;";
  98   if ($@) {
  99     my $err = $@;
 100     $err =~ s/^/# *** /mg;
 101     print "# *** ERROR ***\n$err\n";
 102   }
 103   return $@ ? -42 : scalar @n;
 104 }
 105
 106 sub eq_files
 107 {
 108   my($f1, $f2) = @_;
 109   return 0 unless -e $f1 && -e $f2;
 110   local *F;
 111   for ($f1, $f2) {
 112     print "# File: $_\n";
 113     unless (open F, $_) {
 114       print "# couldn't open $_: $!\n";
 115       return 0;
 116     }
 117     $_ = do { local $/; <F> };
 118     close F;
 119     comment($_);
 120   }
 121   return $f1 eq $f2;
 122 }
 123
 124 my @tests;
 125
 126 for (split /\s*={70,}\s*/, do { local $/; <DATA> }) {
 127   s/^\s+//; s/\s+$//;
 128   my($c, %f);
 129   ($c, @f{m/-{20,}\s+(\S+)\s+-{20,}/g}) = split /\s*-{20,}\s+\S+\s+-{20,}\s*/;
 130   push @tests, { code => $c, files => \%f };
 131 }
 132
 133 my $t;
 134 for $t (@tests) {
 135   print "#\n", ('# ', '-'x70, "\n")x3, "#\n";
 136   my $f;
 137   for $f (keys %{$t->{files}}) {
 138     my @f = split /\//, $f;
 139     if (@f > 1) {
 140       pop @f;
 141       my $path = join '/', @f;
 142       mkpath($path) or die "mkpath('$path'): $!\n";
 143     }
 144     my $txt = $t->{files}{$f};
 145     local *F;
 146     open F, ">$f" or die "open $f: $!\n";
 147     print F "$txt\n";
 148     close F;
 149     $txt =~ s/^/# | /mg;
 150     print "# *** writing $f ***\n$txt\n";
 151   }
 152
 153   my $code = $t->{code};
 154   $code =~ s/^/# | /mg;
 155
 156   print "# *** evaluating test code ***\n$code\n";
 157
 158   eval $t->{code};
 159   if ($@) {
 160     my $err = $@;
 161     $err =~ s/^/# *** /mg;
 162     print "# *** ERROR ***\n$err\n";
 163   }
 164   ok($@, '');
 165
 166   for (keys %{$t->{files}}) {
 167     unlink $_ or die "unlink('$_'): $!\n";
 168   }
 169 }
 170
 171 sub find_perl
 172 {
 173   my $perl = $^X;
 174
 175   return $perl if $isVMS;
 176
 177   my $exe = $Config{'_exe'} || '';
 178
 179   if ($perl =~ /^perl\Q$exe\E$/i) {
 180     $perl = "perl$exe";
 181     eval "require File::Spec";
 182     if ($@) {
 183       $perl = "./$perl";
 184     } else {
 185       $perl = File::Spec->catfile(File::Spec->curdir(), $perl);
 186     }
 187   }
 188
 189   if ($perl !~ /\Q$exe\E$/i) {
 190     $perl .= $exe;
 191   }
 192
 193   warn "find_perl: cannot find $perl from $^X" unless -f $perl;
 194
 195   return $perl;
 196 }
 197
 198 __DATA__
 199
 200 my $o = ppport(qw(--help));
 201 ok($o =~ /^Usage:.*ppport\.h/m);
 202 ok($o =~ /--help/m);
 203
 204 $o = ppport(qw(--version));
 205 ok($o =~ /^This is.*ppport.*\d+\.\d+(?:_?\d+)?\.$/);
 206
 207 $o = ppport(qw(--nochanges));
 208 ok($o =~ /^Scanning.*test\.xs/mi);
 209 ok($o =~ /Analyzing.*test\.xs/mi);
 210 ok(matches($o, '^Scanning', 'm'), 1);
 211 ok(matches($o, 'Analyzing', 'm'), 1);
 212 ok($o =~ /Uses Perl_newSViv instead of newSViv/);
 213
 214 $o = ppport(qw(--quiet --nochanges));
 215 ok($o =~ /^\s*$/);
 216
 217 ---------------------------- test.xs ------------------------------------------
 218
 219 Perl_newSViv();
 220
 221 ===============================================================================
 222
 223 # check if C and C++ comments are filtered correctly
 224
 225 my $o = ppport(qw(--copy=a));
 226 ok($o =~ /^Scanning.*MyExt\.xs/mi);
 227 ok($o =~ /Analyzing.*MyExt\.xs/mi);
 228 ok(matches($o, '^Scanning', 'm'), 1);
 229 ok($o =~ /^Needs to include.*ppport\.h/m);
 230 ok($o !~ /^Uses grok_bin/m);
 231 ok($o !~ /^Uses newSVpv/m);
 232 ok($o =~ /Uses 1 C\+\+ style comment/m);
 233 ok(eq_files('MyExt.xsa', 'MyExt.ra'));
 234
 235 # check if C++ are left untouched with --cplusplus
 236
 237 $o = ppport(qw(--copy=b --cplusplus));
 238 ok($o =~ /^Scanning.*MyExt\.xs/mi);
 239 ok($o =~ /Analyzing.*MyExt\.xs/mi);
 240 ok(matches($o, '^Scanning', 'm'), 1);
 241 ok($o =~ /^Needs to include.*ppport\.h/m);
 242 ok($o !~ /^Uses grok_bin/m);
 243 ok($o !~ /^Uses newSVpv/m);
 244 ok($o !~ /Uses \d+ C\+\+ style comment/m);
 245 ok(eq_files('MyExt.xsb', 'MyExt.rb'));
 246
 247 unlink qw(MyExt.xsa MyExt.xsb);
 248
 249 ---------------------------- MyExt.xs -----------------------------------------
 250
 251 newSVuv();
 252     // newSVpv();
 253   XPUSHs(foo);
 254 /* grok_bin(); */
 255
 256 ---------------------------- MyExt.ra -----------------------------------------
 257
 258 #include "ppport.h"
 259 newSVuv();
 260     /* newSVpv(); */
 261   XPUSHs(foo);
 262 /* grok_bin(); */
 263
 264 ---------------------------- MyExt.rb -----------------------------------------
 265
 266 #include "ppport.h"
 267 newSVuv();
 268     // newSVpv();
 269   XPUSHs(foo);
 270 /* grok_bin(); */
 271
 272 ===============================================================================
 273
 274 my $o = ppport(qw(--nochanges file1.xs));
 275 ok($o =~ /^Scanning.*file1\.xs/mi);
 276 ok($o =~ /Analyzing.*file1\.xs/mi);
 277 ok($o !~ /^Scanning.*file2\.xs/mi);
 278 ok($o =~ /^Uses newCONSTSUB/m);
 279 ok($o =~ /^Uses PL_expect/m);
 280 ok($o =~ /^Uses SvPV_nolen.*depends.*sv_2pv_flags/m);
 281 ok($o =~ /WARNING: PL_expect/m);
 282 ok($o =~ /hint for newCONSTSUB/m);
 283 ok($o =~ /^Analysis completed \(1 warning\)/m);
 284 ok($o =~ /^Looks good/m);
 285
 286 $o = ppport(qw(--nochanges --nohints file1.xs));
 287 ok($o =~ /^Scanning.*file1\.xs/mi);
 288 ok($o =~ /Analyzing.*file1\.xs/mi);
 289 ok($o !~ /^Scanning.*file2\.xs/mi);
 290 ok($o =~ /^Uses newCONSTSUB/m);
 291 ok($o =~ /^Uses PL_expect/m);
 292 ok($o =~ /^Uses SvPV_nolen.*depends.*sv_2pv_flags/m);
 293 ok($o =~ /WARNING: PL_expect/m);
 294 ok($o !~ /hint for newCONSTSUB/m);
 295 ok($o =~ /^Analysis completed \(1 warning\)/m);
 296 ok($o =~ /^Looks good/m);
 297
 298 $o = ppport(qw(--nochanges --nohints --nodiag file1.xs));
 299 ok($o =~ /^Scanning.*file1\.xs/mi);
 300 ok($o =~ /Analyzing.*file1\.xs/mi);
 301 ok($o !~ /^Scanning.*file2\.xs/mi);
 302 ok($o !~ /^Uses newCONSTSUB/m);
 303 ok($o !~ /^Uses PL_expect/m);
 304 ok($o !~ /^Uses SvPV_nolen/m);
 305 ok($o =~ /WARNING: PL_expect/m);
 306 ok($o !~ /hint for newCONSTSUB/m);
 307 ok($o =~ /^Analysis completed \(1 warning\)/m);
 308 ok($o =~ /^Looks good/m);
 309
 310 $o = ppport(qw(--nochanges --quiet file1.xs));
 311 ok($o =~ /^\s*$/);
 312
 313 $o = ppport(qw(--nochanges file2.xs));
 314 ok($o =~ /^Scanning.*file2\.xs/mi);
 315 ok($o =~ /Analyzing.*file2\.xs/mi);
 316 ok($o !~ /^Scanning.*file1\.xs/mi);
 317 ok($o =~ /^Uses mXPUSHp/m);
 318 ok($o =~ /^Needs to include.*ppport\.h/m);
 319 ok($o !~ /^Looks good/m);
 320 ok($o =~ /^1 potentially required change detected/m);
 321
 322 $o = ppport(qw(--nochanges --nohints file2.xs));
 323 ok($o =~ /^Scanning.*file2\.xs/mi);
 324 ok($o =~ /Analyzing.*file2\.xs/mi);
 325 ok($o !~ /^Scanning.*file1\.xs/mi);
 326 ok($o =~ /^Uses mXPUSHp/m);
 327 ok($o =~ /^Needs to include.*ppport\.h/m);
 328 ok($o !~ /^Looks good/m);
 329 ok($o =~ /^1 potentially required change detected/m);
 330
 331 $o = ppport(qw(--nochanges --nohints --nodiag file2.xs));
 332 ok($o =~ /^Scanning.*file2\.xs/mi);
 333 ok($o =~ /Analyzing.*file2\.xs/mi);
 334 ok($o !~ /^Scanning.*file1\.xs/mi);
 335 ok($o !~ /^Uses mXPUSHp/m);
 336 ok($o !~ /^Needs to include.*ppport\.h/m);
 337 ok($o !~ /^Looks good/m);
 338 ok($o =~ /^1 potentially required change detected/m);
 339
 340 $o = ppport(qw(--nochanges --quiet file2.xs));
 341 ok($o =~ /^\s*$/);
 342
 343 ---------------------------- file1.xs -----------------------------------------
 344
 345 #define NEED_newCONSTSUB
 346 #define NEED_sv_2pv_flags
 347 #define NEED_PL_parser
 348 #include "ppport.h"
 349
 350 newCONSTSUB();
 351 SvPV_nolen();
 352 PL_expect = 0;
 353
 354 ---------------------------- file2.xs -----------------------------------------
 355
 356 mXPUSHp(foo);
 357
 358 ===============================================================================
 359
 360 my $o = ppport(qw(--nochanges));
 361 ok($o =~ /^Scanning.*FooBar\.xs/mi);
 362 ok($o =~ /Analyzing.*FooBar\.xs/mi);
 363 ok(matches($o, '^Scanning', 'm'), 1);
 364 ok($o !~ /^Looks good/m);
 365 ok($o =~ /^Uses grok_bin/m);
 366
 367 ---------------------------- FooBar.xs ----------------------------------------
 368
 369 newSViv();
 370 XPUSHs(foo);
 371 grok_bin();
 372
 373 ===============================================================================
 374
 375 my $o = ppport(qw(--nochanges));
 376 ok($o =~ /^Scanning.*First\.xs/mi);
 377 ok($o =~ /Analyzing.*First\.xs/mi);
 378 ok($o =~ /^Scanning.*second\.h/mi);
 379 ok($o =~ /Analyzing.*second\.h/mi);
 380 ok($o =~ /^Scanning.*sub.*third\.c/mi);
 381 ok($o =~ /Analyzing.*sub.*third\.c/mi);
 382 ok($o !~ /^Scanning.*foobar/mi);
 383 ok(matches($o, '^Scanning', 'm'), 3);
 384
 385 ---------------------------- First.xs -----------------------------------------
 386
 387 one
 388
 389 ---------------------------- foobar.xyz ---------------------------------------
 390
 391 two
 392
 393 ---------------------------- second.h -----------------------------------------
 394
 395 three
 396
 397 ---------------------------- sub/third.c --------------------------------------
 398
 399 four
 400
 401 ===============================================================================
 402
 403 my $o = ppport(qw(--nochanges));
 404 ok($o =~ /Possibly wrong #define NEED_foobar in.*test.xs/i);
 405
 406 ---------------------------- test.xs ------------------------------------------
 407
 408 #define NEED_foobar
 409
 410 ===============================================================================
 411
 412 # And now some complex "real-world" example
 413
 414 my $o = ppport(qw(--copy=f));
 415 for (qw(main.xs mod1.c mod2.c mod3.c mod4.c mod5.c)) {
 416   ok($o =~ /^Scanning.*\Q$_\E/mi);
 417   ok($o =~ /Analyzing.*\Q$_\E/i);
 418 }
 419 ok(matches($o, '^Scanning', 'm'), 6);
 420
 421 ok(matches($o, '^Writing copy of', 'm'), 5);
 422 ok(!-e "mod5.cf");
 423
 424 for (qw(main.xs mod1.c mod2.c mod3.c mod4.c)) {
 425   ok($o =~ /^Writing copy of.*\Q$_\E.*with changes/mi);
 426   ok(-e "${_}f");
 427   ok(eq_files("${_}f", "${_}r"));
 428   unlink "${_}f";
 429 }
 430
 431 ---------------------------- main.xs ------------------------------------------
 432
 433 #include "EXTERN.h"
 434 #include "perl.h"
 435 #include "XSUB.h"
 436
 437 #define NEED_newCONSTSUB
 438 #define NEED_grok_hex_GLOBAL
 439 #include "ppport.h"
 440
 441 newCONSTSUB();
 442 grok_hex();
 443 Perl_grok_bin(aTHX_ foo, bar);
 444
 445 /* some comment */
 446
 447 perl_eval_pv();
 448 grok_bin();
 449 Perl_grok_bin(bar, sv_no);
 450
 451 ---------------------------- mod1.c -------------------------------------------
 452
 453 #include "EXTERN.h"
 454 #include "perl.h"
 455 #include "XSUB.h"
 456
 457 #define NEED_grok_bin_GLOBAL
 458 #define NEED_newCONSTSUB
 459 #include "ppport.h"
 460
 461 newCONSTSUB();
 462 grok_bin();
 463 {
 464   Perl_croak ("foo");
 465   Perl_sv_catpvf();  /* I know it's wrong ;-) */
 466 }
 467
 468 ---------------------------- mod2.c -------------------------------------------
 469
 470 #include "EXTERN.h"
 471 #include "perl.h"
 472 #include "XSUB.h"
 473
 474 #define NEED_eval_pv
 475 #include "ppport.h"
 476
 477 newSViv();
 478
 479 /*
 480    eval_pv();
 481 */
 482
 483 ---------------------------- mod3.c -------------------------------------------
 484
 485 #include "EXTERN.h"
 486 #include "perl.h"
 487 #include "XSUB.h"
 488
 489 grok_oct();
 490 eval_pv();
 491
 492 ---------------------------- mod4.c -------------------------------------------
 493
 494 #include "EXTERN.h"
 495 #include "perl.h"
 496 #include "XSUB.h"
 497
 498 START_MY_CXT;
 499
 500 ---------------------------- mod5.c -------------------------------------------
 501
 502 #include "EXTERN.h"
 503 #include "perl.h"
 504 #include "XSUB.h"
 505
 506 #include "ppport.h"
 507 call_pv();
 508
 509 ---------------------------- main.xsr -----------------------------------------
 510
 511 #include "EXTERN.h"
 512 #include "perl.h"
 513 #include "XSUB.h"
 514
 515 #define NEED_eval_pv_GLOBAL
 516 #define NEED_grok_hex
 517 #define NEED_newCONSTSUB_GLOBAL
 518 #include "ppport.h"
 519
 520 newCONSTSUB();
 521 grok_hex();
 522 grok_bin(foo, bar);
 523
 524 /* some comment */
 525
 526 eval_pv();
 527 grok_bin();
 528 grok_bin(bar, PL_sv_no);
 529
 530 ---------------------------- mod1.cr ------------------------------------------
 531
 532 #include "EXTERN.h"
 533 #include "perl.h"
 534 #include "XSUB.h"
 535
 536 #define NEED_grok_bin_GLOBAL
 537 #include "ppport.h"
 538
 539 newCONSTSUB();
 540 grok_bin();
 541 {
 542   Perl_croak (aTHX_ "foo");
 543   Perl_sv_catpvf(aTHX);  /* I know it's wrong ;-) */
 544 }
 545
 546 ---------------------------- mod2.cr ------------------------------------------
 547
 548 #include "EXTERN.h"
 549 #include "perl.h"
 550 #include "XSUB.h"
 551
 552
 553 newSViv();
 554
 555 /*
 556    eval_pv();
 557 */
 558
 559 ---------------------------- mod3.cr ------------------------------------------
 560
 561 #include "EXTERN.h"
 562 #include "perl.h"
 563 #include "XSUB.h"
 564 #define NEED_grok_oct
 565 #include "ppport.h"
 566
 567 grok_oct();
 568 eval_pv();
 569
 570 ---------------------------- mod4.cr ------------------------------------------
 571
 572 #include "EXTERN.h"
 573 #include "perl.h"
 574 #include "XSUB.h"
 575 #include "ppport.h"
 576
 577 START_MY_CXT;
 578
 579 ===============================================================================
 580
 581 my $o = ppport(qw(--nochanges));
 582 ok($o =~ /Uses grok_hex/m);
 583 ok($o !~ /Looks good/m);
 584
 585 $o = ppport(qw(--nochanges --compat-version=5.8.0));
 586 ok($o !~ /Uses grok_hex/m);
 587 ok($o =~ /Looks good/m);
 588
 589 ---------------------------- FooBar.xs ----------------------------------------
 590
 591 grok_hex();
 592
 593 ===============================================================================
 594
 595 my $o = ppport(qw(--nochanges));
 596 ok($o =~ /Uses SvPVutf8_force, which may not be portable/m);
 597
 598 $o = ppport(qw(--nochanges --compat-version=5.5.3));
 599 ok($o =~ /Uses SvPVutf8_force, which may not be portable/m);
 600
 601 $o = ppport(qw(--nochanges --compat-version=5.005_03));
 602 ok($o =~ /Uses SvPVutf8_force, which may not be portable/m);
 603
 604 $o = ppport(qw(--nochanges --compat-version=5.6.0));
 605 ok($o !~ /Uses SvPVutf8_force/m);
 606
 607 $o = ppport(qw(--nochanges --compat-version=5.006));
 608 ok($o !~ /Uses SvPVutf8_force/m);
 609
 610 $o = ppport(qw(--nochanges --compat-version=5.999.999));
 611 ok($o !~ /Uses SvPVutf8_force/m);
 612
 613 $o = ppport(qw(--nochanges --compat-version=6.0.0));
 614 ok($o =~ /Only Perl 5 is supported/m);
 615
 616 $o = ppport(qw(--nochanges --compat-version=5.1000.999));
 617 ok($o =~ /Invalid version number: 5.1000.999/m);
 618
 619 $o = ppport(qw(--nochanges --compat-version=5.999.1000));
 620 ok($o =~ /Invalid version number: 5.999.1000/m);
 621
 622 ---------------------------- FooBar.xs ----------------------------------------
 623
 624 SvPVutf8_force();
 625
 626 ===============================================================================
 627
 628 my $o = ppport(qw(--nochanges));
 629 ok($o !~ /potentially required change/);
 630 ok(matches($o, '^Looks good', 'm'), 2);
 631
 632 ---------------------------- FooBar.xs ----------------------------------------
 633
 634 #define NEED_grok_numeric_radix
 635 #define NEED_grok_number
 636 #include "ppport.h"
 637
 638 GROK_NUMERIC_RADIX();
 639 grok_number();
 640
 641 ---------------------------- foo.c --------------------------------------------
 642
 643 #include "ppport.h"
 644
 645 call_pv();
 646
 647 ===============================================================================
 648
 649 # check --api-info option
 650
 651 my $o = ppport(qw(--api-info=INT2PTR));
 652 my %found = map {($_ => 1)} $o =~ /^===\s+(\w+)\s+===/mg;
 653 ok(scalar keys %found, 1);
 654 ok(exists $found{INT2PTR});
 655 ok(matches($o, '^Supported at least starting from perl-5\.6\.0\.', 'm'), 1);
 656 ok(matches($o, '^Support by .*ppport.* provided back to perl-5\.003\.', 'm'), 1);
 657
 658 $o = ppport(qw(--api-info=Zero));
 659 %found = map {($_ => 1)} $o =~ /^===\s+(\w+)\s+===/mg;
 660 ok(scalar keys %found, 1);
 661 ok(exists $found{Zero});
 662 ok(matches($o, '^No portability information available\.', 'm'), 1);
 663
 664 $o = ppport(qw(--api-info=/Zero/));
 665 %found = map {($_ => 1)} $o =~ /^===\s+(\w+)\s+===/mg;
 666 ok(scalar keys %found, 2);
 667 ok(exists $found{Zero});
 668 ok(exists $found{ZeroD});
 669
 670 ===============================================================================
 671
 672 # check --list-provided option
 673
 674 my @o = ppport(qw(--list-provided));
 675 my %p;
 676 my $fail = 0;
 677 for (@o) {
 678   my($name, $flags) = /^(\w+)(?:\s+\[(\w+(?:,\s+\w+)*)\])?$/ or $fail++;
 679   exists $p{$name} and $fail++;
 680   $p{$name} = defined $flags ? { map { ($_ => 1) } $flags =~ /(\w+)/g } : '';
 681 }
 682 ok(@o > 100);
 683 ok($fail, 0);
 684
 685 ok(exists $p{call_pv});
 686 ok(not ref $p{call_pv});
 687
 688 ok(exists $p{grok_bin});
 689 ok(ref $p{grok_bin}, 'HASH');
 690 ok(scalar keys %{$p{grok_bin}}, 2);
 691 ok($p{grok_bin}{explicit});
 692 ok($p{grok_bin}{depend});
 693
 694 ok(exists $p{gv_stashpvn});
 695 ok(ref $p{gv_stashpvn}, 'HASH');
 696 ok(scalar keys %{$p{gv_stashpvn}}, 2);
 697 ok($p{gv_stashpvn}{depend});
 698 ok($p{gv_stashpvn}{hint});
 699
 700 ok(exists $p{sv_catpvf_mg});
 701 ok(ref $p{sv_catpvf_mg}, 'HASH');
 702 ok(scalar keys %{$p{sv_catpvf_mg}}, 2);
 703 ok($p{sv_catpvf_mg}{explicit});
 704 ok($p{sv_catpvf_mg}{depend});
 705
 706 ok(exists $p{PL_signals});
 707 ok(ref $p{PL_signals}, 'HASH');
 708 ok(scalar keys %{$p{PL_signals}}, 1);
 709 ok($p{PL_signals}{explicit});
 710
 711 ===============================================================================
 712
 713 # check --list-unsupported option
 714
 715 my @o = ppport(qw(--list-unsupported));
 716 my %p;
 717 my $fail = 0;
 718 for (@o) {
 719   my($name, $ver) = /^(\w+)\s*\.+\s*([\d._]+)$/ or $fail++;
 720   exists $p{$name} and $fail++;
 721   $p{$name} = $ver;
 722 }
 723 ok(@o > 100);
 724 ok($fail, 0);
 725
 726 ok(exists $p{utf8_distance});
 727 ok($p{utf8_distance}, '5.6.0');
 728
 729 ok(exists $p{save_generic_svref});
 730 ok($p{save_generic_svref}, '5.005_03');
 731
 732 ===============================================================================
 733
 734 # check --nofilter option
 735
 736 my $o = ppport(qw(--nochanges));
 737 ok($o =~ /^Scanning.*foo\.cpp/mi);
 738 ok($o =~ /Analyzing.*foo\.cpp/mi);
 739 ok(matches($o, '^Scanning', 'm'), 1);
 740 ok(matches($o, 'Analyzing', 'm'), 1);
 741
 742 $o = ppport(qw(--nochanges foo.cpp foo.o Makefile.PL));
 743 ok($o =~ /Skipping the following files \(use --nofilter to avoid this\):/m);
 744 ok(matches($o, '^\|\s+foo\.o', 'mi'), 1);
 745 ok(matches($o, '^\|\s+Makefile\.PL', 'mi'), 1);
 746 ok($o =~ /^Scanning.*foo\.cpp/mi);
 747 ok($o =~ /Analyzing.*foo\.cpp/mi);
 748 ok(matches($o, '^Scanning', 'm'), 1);
 749 ok(matches($o, 'Analyzing', 'm'), 1);
 750
 751 $o = ppport(qw(--nochanges --nofilter foo.cpp foo.o Makefile.PL));
 752 ok($o =~ /^Scanning.*foo\.cpp/mi);
 753 ok($o =~ /Analyzing.*foo\.cpp/mi);
 754 ok($o =~ /^Scanning.*foo\.o/mi);
 755 ok($o =~ /Analyzing.*foo\.o/mi);
 756 ok($o =~ /^Scanning.*Makefile/mi);
 757 ok($o =~ /Analyzing.*Makefile/mi);
 758 ok(matches($o, '^Scanning', 'm'), 3);
 759 ok(matches($o, 'Analyzing', 'm'), 3);
 760
 761 ---------------------------- foo.cpp ------------------------------------------
 762
 763 newSViv();
 764
 765 ---------------------------- foo.o --------------------------------------------
 766
 767 newSViv();
 768
 769 ---------------------------- Makefile.PL --------------------------------------
 770
 771 newSViv();
 772
 773 ===============================================================================
 774
 775 # check if explicit variables are handled propery
 776
 777 my $o = ppport(qw(--copy=a));
 778 ok($o =~ /^Needs to include.*ppport\.h/m);
 779 ok($o =~ /^Uses PL_signals/m);
 780 ok($o =~ /^File needs PL_signals, adding static request/m);
 781 ok(eq_files('MyExt.xsa', 'MyExt.ra'));
 782
 783 unlink qw(MyExt.xsa);
 784
 785 ---------------------------- MyExt.xs -----------------------------------------
 786
 787 PL_signals = 123;
 788 if (PL_signals == 42)
 789   foo();
 790
 791 ---------------------------- MyExt.ra -----------------------------------------
 792
 793 #define NEED_PL_signals
 794 #include "ppport.h"
 795 PL_signals = 123;
 796 if (PL_signals == 42)
 797   foo();
 798
 799 ===============================================================================
 800
 801 my $o = ppport(qw(--nochanges file.xs));
 802 ok($o =~ /^Uses PL_copline/m);
 803 ok($o =~ /WARNING: PL_copline/m);
 804 ok($o =~ /^Uses SvUOK/m);
 805 ok($o =~ /WARNING: Uses SvUOK, which may not be portable/m);
 806 ok($o =~ /^Analysis completed \(2 warnings\)/m);
 807 ok($o =~ /^Looks good/m);
 808
 809 $o = ppport(qw(--nochanges --compat-version=5.8.0 file.xs));
 810 ok($o =~ /^Uses PL_copline/m);
 811 ok($o =~ /WARNING: PL_copline/m);
 812 ok($o !~ /WARNING: Uses SvUOK, which may not be portable/m);
 813 ok($o =~ /^Analysis completed \(1 warning\)/m);
 814 ok($o =~ /^Looks good/m);
 815
 816 ---------------------------- file.xs -----------------------------------------
 817
 818 #define NEED_PL_parser
 819 #include "ppport.h"
 820 SvUOK
 821 PL_copline
 822
 823 ===============================================================================
 824
 825 my $o = ppport(qw(--copy=f));
 826
 827 for (qw(file.xs)) {
 828   ok($o =~ /^Writing copy of.*\Q$_\E.*with changes/mi);
 829   ok(-e "${_}f");
 830   ok(eq_files("${_}f", "${_}r"));
 831   unlink "${_}f";
 832 }
 833
 834 ---------------------------- file.xs -----------------------------------------
 835
 836 a_string = "sv_undef"
 837 a_char = 'sv_yes'
 838 #define SOMETHING defgv
 839 /* C-comment: sv_tainted */
 840 #
 841 # This is just a big XS comment using sv_no
 842 #
 843 /* The following, is NOT an XS comment! */
 844 #  define SOMETHING_ELSE defgv + \
 845                          sv_undef
 846
 847 ---------------------------- file.xsr -----------------------------------------
 848
 849 #include "ppport.h"
 850 a_string = "sv_undef"
 851 a_char = 'sv_yes'
 852 #define SOMETHING PL_defgv
 853 /* C-comment: sv_tainted */
 854 #
 855 # This is just a big XS comment using sv_no
 856 #
 857 /* The following, is NOT an XS comment! */
 858 #  define SOMETHING_ELSE PL_defgv + \
 859                          PL_sv_undef
 860
 861 ===============================================================================
 862
 863 my $o = ppport(qw(--copy=f));
 864
 865 for (qw(file.xs)) {
 866   ok($o =~ /^Writing copy of.*\Q$_\E.*with changes/mi);
 867   ok(-e "${_}f");
 868   ok(eq_files("${_}f", "${_}r"));
 869   unlink "${_}f";
 870 }
 871
 872 ---------------------------- file.xs -----------------------------------------
 873
 874 #define NEED_sv_2pv_flags
 875 #define NEED_vnewSVpvf
 876 #define NEED_warner
 877 #include "ppport.h"
 878 Perl_croak_nocontext("foo");
 879 Perl_croak("bar");
 880 croak("foo");
 881 croak_nocontext("foo");
 882 Perl_warner_nocontext("foo");
 883 Perl_warner("foo");
 884 warner_nocontext("foo");
 885 warner("foo");
 886
 887 ---------------------------- file.xsr -----------------------------------------
 888
 889 #define NEED_sv_2pv_flags
 890 #define NEED_vnewSVpvf
 891 #define NEED_warner
 892 #include "ppport.h"
 893 Perl_croak_nocontext("foo");
 894 Perl_croak(aTHX_ "bar");
 895 croak("foo");
 896 croak_nocontext("foo");
 897 Perl_warner_nocontext("foo");
 898 Perl_warner(aTHX_ "foo");
 899 warner_nocontext("foo");
 900 warner("foo");
 901