ext/Devel/PPPort/parts/inc/ppphtest

   1 ################################################################################
   2 ##
   3 ##  $Revision: 42 $
   4 ##  $Author: mhx $
   5 ##  $Date: 2008/01/04 10:47:42 +0100 $
   6 ##
   7 ################################################################################
   8 ##
   9 ##  Version 3.x, Copyright (C) 2004-2008, 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 => 229
  19
  20 BEGIN {
  21   if ($ENV{'SKIP_SLOW_TESTS'}) {
  22     for (1 .. 229) {
  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 SvPV_nolen.*depends.*sv_2pv_flags/m);
 280 ok($o =~ /WARNING: PL_expect/m);
 281 ok($o =~ /hint for newCONSTSUB/m);
 282 ok($o =~ /^Looks good/m);
 283
 284 $o = ppport(qw(--nochanges --nohints file1.xs));
 285 ok($o =~ /^Scanning.*file1\.xs/mi);
 286 ok($o =~ /Analyzing.*file1\.xs/mi);
 287 ok($o !~ /^Scanning.*file2\.xs/mi);
 288 ok($o =~ /^Uses newCONSTSUB/m);
 289 ok($o =~ /^Uses SvPV_nolen.*depends.*sv_2pv_flags/m);
 290 ok($o =~ /WARNING: PL_expect/m);
 291 ok($o !~ /hint for newCONSTSUB/m);
 292 ok($o =~ /^Looks good/m);
 293
 294 $o = ppport(qw(--nochanges --nohints --nodiag file1.xs));
 295 ok($o =~ /^Scanning.*file1\.xs/mi);
 296 ok($o =~ /Analyzing.*file1\.xs/mi);
 297 ok($o !~ /^Scanning.*file2\.xs/mi);
 298 ok($o !~ /^Uses newCONSTSUB/m);
 299 ok($o !~ /^Uses SvPV_nolen/m);
 300 ok($o =~ /WARNING: PL_expect/m);
 301 ok($o !~ /hint for newCONSTSUB/m);
 302 ok($o =~ /^Looks good/m);
 303
 304 $o = ppport(qw(--nochanges --quiet file1.xs));
 305 ok($o =~ /^\s*$/);
 306
 307 $o = ppport(qw(--nochanges file2.xs));
 308 ok($o =~ /^Scanning.*file2\.xs/mi);
 309 ok($o =~ /Analyzing.*file2\.xs/mi);
 310 ok($o !~ /^Scanning.*file1\.xs/mi);
 311 ok($o =~ /^Uses mXPUSHp/m);
 312 ok($o =~ /^Needs to include.*ppport\.h/m);
 313 ok($o !~ /^Looks good/m);
 314 ok($o =~ /^1 potentially required change detected/m);
 315
 316 $o = ppport(qw(--nochanges --nohints file2.xs));
 317 ok($o =~ /^Scanning.*file2\.xs/mi);
 318 ok($o =~ /Analyzing.*file2\.xs/mi);
 319 ok($o !~ /^Scanning.*file1\.xs/mi);
 320 ok($o =~ /^Uses mXPUSHp/m);
 321 ok($o =~ /^Needs to include.*ppport\.h/m);
 322 ok($o !~ /^Looks good/m);
 323 ok($o =~ /^1 potentially required change detected/m);
 324
 325 $o = ppport(qw(--nochanges --nohints --nodiag file2.xs));
 326 ok($o =~ /^Scanning.*file2\.xs/mi);
 327 ok($o =~ /Analyzing.*file2\.xs/mi);
 328 ok($o !~ /^Scanning.*file1\.xs/mi);
 329 ok($o !~ /^Uses mXPUSHp/m);
 330 ok($o !~ /^Needs to include.*ppport\.h/m);
 331 ok($o !~ /^Looks good/m);
 332 ok($o =~ /^1 potentially required change detected/m);
 333
 334 $o = ppport(qw(--nochanges --quiet file2.xs));
 335 ok($o =~ /^\s*$/);
 336
 337 ---------------------------- file1.xs -----------------------------------------
 338
 339 #define NEED_newCONSTSUB
 340 #define NEED_sv_2pv_flags
 341 #include "ppport.h"
 342
 343 newCONSTSUB();
 344 SvPV_nolen();
 345 PL_expect = 0;
 346
 347 ---------------------------- file2.xs -----------------------------------------
 348
 349 mXPUSHp(foo);
 350
 351 ===============================================================================
 352
 353 my $o = ppport(qw(--nochanges));
 354 ok($o =~ /^Scanning.*FooBar\.xs/mi);
 355 ok($o =~ /Analyzing.*FooBar\.xs/mi);
 356 ok(matches($o, '^Scanning', 'm'), 1);
 357 ok($o !~ /^Looks good/m);
 358 ok($o =~ /^Uses grok_bin/m);
 359
 360 ---------------------------- FooBar.xs ----------------------------------------
 361
 362 newSViv();
 363 XPUSHs(foo);
 364 grok_bin();
 365
 366 ===============================================================================
 367
 368 my $o = ppport(qw(--nochanges));
 369 ok($o =~ /^Scanning.*First\.xs/mi);
 370 ok($o =~ /Analyzing.*First\.xs/mi);
 371 ok($o =~ /^Scanning.*second\.h/mi);
 372 ok($o =~ /Analyzing.*second\.h/mi);
 373 ok($o =~ /^Scanning.*sub.*third\.c/mi);
 374 ok($o =~ /Analyzing.*sub.*third\.c/mi);
 375 ok($o !~ /^Scanning.*foobar/mi);
 376 ok(matches($o, '^Scanning', 'm'), 3);
 377
 378 ---------------------------- First.xs -----------------------------------------
 379
 380 one
 381
 382 ---------------------------- foobar.xyz ---------------------------------------
 383
 384 two
 385
 386 ---------------------------- second.h -----------------------------------------
 387
 388 three
 389
 390 ---------------------------- sub/third.c --------------------------------------
 391
 392 four
 393
 394 ===============================================================================
 395
 396 my $o = ppport(qw(--nochanges));
 397 ok($o =~ /Possibly wrong #define NEED_foobar in.*test.xs/i);
 398
 399 ---------------------------- test.xs ------------------------------------------
 400
 401 #define NEED_foobar
 402
 403 ===============================================================================
 404
 405 # And now some complex "real-world" example
 406
 407 my $o = ppport(qw(--copy=f));
 408 for (qw(main.xs mod1.c mod2.c mod3.c mod4.c mod5.c)) {
 409   ok($o =~ /^Scanning.*\Q$_\E/mi);
 410   ok($o =~ /Analyzing.*\Q$_\E/i);
 411 }
 412 ok(matches($o, '^Scanning', 'm'), 6);
 413
 414 ok(matches($o, '^Writing copy of', 'm'), 5);
 415 ok(!-e "mod5.cf");
 416
 417 for (qw(main.xs mod1.c mod2.c mod3.c mod4.c)) {
 418   ok($o =~ /^Writing copy of.*\Q$_\E.*with changes/mi);
 419   ok(-e "${_}f");
 420   ok(eq_files("${_}f", "${_}r"));
 421   unlink "${_}f";
 422 }
 423
 424 ---------------------------- main.xs ------------------------------------------
 425
 426 #include "EXTERN.h"
 427 #include "perl.h"
 428 #include "XSUB.h"
 429
 430 #define NEED_newCONSTSUB
 431 #define NEED_grok_hex_GLOBAL
 432 #include "ppport.h"
 433
 434 newCONSTSUB();
 435 grok_hex();
 436 Perl_grok_bin(aTHX_ foo, bar);
 437
 438 /* some comment */
 439
 440 perl_eval_pv();
 441 grok_bin();
 442 Perl_grok_bin(bar, sv_no);
 443
 444 ---------------------------- mod1.c -------------------------------------------
 445
 446 #include "EXTERN.h"
 447 #include "perl.h"
 448 #include "XSUB.h"
 449
 450 #define NEED_grok_bin_GLOBAL
 451 #define NEED_newCONSTSUB
 452 #include "ppport.h"
 453
 454 newCONSTSUB();
 455 grok_bin();
 456 {
 457   Perl_croak ("foo");
 458   Perl_sv_catpvf();  /* I know it's wrong ;-) */
 459 }
 460
 461 ---------------------------- mod2.c -------------------------------------------
 462
 463 #include "EXTERN.h"
 464 #include "perl.h"
 465 #include "XSUB.h"
 466
 467 #define NEED_eval_pv
 468 #include "ppport.h"
 469
 470 newSViv();
 471
 472 /*
 473    eval_pv();
 474 */
 475
 476 ---------------------------- mod3.c -------------------------------------------
 477
 478 #include "EXTERN.h"
 479 #include "perl.h"
 480 #include "XSUB.h"
 481
 482 grok_oct();
 483 eval_pv();
 484
 485 ---------------------------- mod4.c -------------------------------------------
 486
 487 #include "EXTERN.h"
 488 #include "perl.h"
 489 #include "XSUB.h"
 490
 491 START_MY_CXT;
 492
 493 ---------------------------- mod5.c -------------------------------------------
 494
 495 #include "EXTERN.h"
 496 #include "perl.h"
 497 #include "XSUB.h"
 498
 499 #include "ppport.h"
 500 call_pv();
 501
 502 ---------------------------- main.xsr -----------------------------------------
 503
 504 #include "EXTERN.h"
 505 #include "perl.h"
 506 #include "XSUB.h"
 507
 508 #define NEED_eval_pv_GLOBAL
 509 #define NEED_grok_hex
 510 #define NEED_newCONSTSUB_GLOBAL
 511 #include "ppport.h"
 512
 513 newCONSTSUB();
 514 grok_hex();
 515 grok_bin(foo, bar);
 516
 517 /* some comment */
 518
 519 eval_pv();
 520 grok_bin();
 521 grok_bin(bar, PL_sv_no);
 522
 523 ---------------------------- mod1.cr ------------------------------------------
 524
 525 #include "EXTERN.h"
 526 #include "perl.h"
 527 #include "XSUB.h"
 528
 529 #define NEED_grok_bin_GLOBAL
 530 #include "ppport.h"
 531
 532 newCONSTSUB();
 533 grok_bin();
 534 {
 535   Perl_croak (aTHX_ "foo");
 536   Perl_sv_catpvf(aTHX);  /* I know it's wrong ;-) */
 537 }
 538
 539 ---------------------------- mod2.cr ------------------------------------------
 540
 541 #include "EXTERN.h"
 542 #include "perl.h"
 543 #include "XSUB.h"
 544
 545
 546 newSViv();
 547
 548 /*
 549    eval_pv();
 550 */
 551
 552 ---------------------------- mod3.cr ------------------------------------------
 553
 554 #include "EXTERN.h"
 555 #include "perl.h"
 556 #include "XSUB.h"
 557 #define NEED_grok_oct
 558 #include "ppport.h"
 559
 560 grok_oct();
 561 eval_pv();
 562
 563 ---------------------------- mod4.cr ------------------------------------------
 564
 565 #include "EXTERN.h"
 566 #include "perl.h"
 567 #include "XSUB.h"
 568 #include "ppport.h"
 569
 570 START_MY_CXT;
 571
 572 ===============================================================================
 573
 574 my $o = ppport(qw(--nochanges));
 575 ok($o =~ /Uses grok_hex/m);
 576 ok($o !~ /Looks good/m);
 577
 578 $o = ppport(qw(--nochanges --compat-version=5.8.0));
 579 ok($o !~ /Uses grok_hex/m);
 580 ok($o =~ /Looks good/m);
 581
 582 ---------------------------- FooBar.xs ----------------------------------------
 583
 584 grok_hex();
 585
 586 ===============================================================================
 587
 588 my $o = ppport(qw(--nochanges));
 589 ok($o =~ /Uses SvPVutf8_force, which may not be portable/m);
 590
 591 $o = ppport(qw(--nochanges --compat-version=5.5.3));
 592 ok($o =~ /Uses SvPVutf8_force, which may not be portable/m);
 593
 594 $o = ppport(qw(--nochanges --compat-version=5.005_03));
 595 ok($o =~ /Uses SvPVutf8_force, which may not be portable/m);
 596
 597 $o = ppport(qw(--nochanges --compat-version=5.6.0));
 598 ok($o !~ /Uses SvPVutf8_force/m);
 599
 600 $o = ppport(qw(--nochanges --compat-version=5.006));
 601 ok($o !~ /Uses SvPVutf8_force/m);
 602
 603 $o = ppport(qw(--nochanges --compat-version=5.999.999));
 604 ok($o !~ /Uses SvPVutf8_force/m);
 605
 606 $o = ppport(qw(--nochanges --compat-version=6.0.0));
 607 ok($o =~ /Only Perl 5 is supported/m);
 608
 609 $o = ppport(qw(--nochanges --compat-version=5.1000.999));
 610 ok($o =~ /Invalid version number: 5.1000.999/m);
 611
 612 $o = ppport(qw(--nochanges --compat-version=5.999.1000));
 613 ok($o =~ /Invalid version number: 5.999.1000/m);
 614
 615 ---------------------------- FooBar.xs ----------------------------------------
 616
 617 SvPVutf8_force();
 618
 619 ===============================================================================
 620
 621 my $o = ppport(qw(--nochanges));
 622 ok($o !~ /potentially required change/);
 623 ok(matches($o, '^Looks good', 'm'), 2);
 624
 625 ---------------------------- FooBar.xs ----------------------------------------
 626
 627 #define NEED_grok_numeric_radix
 628 #define NEED_grok_number
 629 #include "ppport.h"
 630
 631 GROK_NUMERIC_RADIX();
 632 grok_number();
 633
 634 ---------------------------- foo.c --------------------------------------------
 635
 636 #include "ppport.h"
 637
 638 call_pv();
 639
 640 ===============================================================================
 641
 642 # check --api-info option
 643
 644 my $o = ppport(qw(--api-info=INT2PTR));
 645 my %found = map {($_ => 1)} $o =~ /^===\s+(\w+)\s+===/mg;
 646 ok(scalar keys %found, 1);
 647 ok(exists $found{INT2PTR});
 648 ok(matches($o, '^Supported at least starting from perl-5\.6\.0\.', 'm'), 1);
 649 ok(matches($o, '^Support by .*ppport.* provided back to perl-5\.003\.', 'm'), 1);
 650
 651 $o = ppport(qw(--api-info=Zero));
 652 %found = map {($_ => 1)} $o =~ /^===\s+(\w+)\s+===/mg;
 653 ok(scalar keys %found, 1);
 654 ok(exists $found{Zero});
 655 ok(matches($o, '^No portability information available\.', 'm'), 1);
 656
 657 $o = ppport(qw(--api-info=/Zero/));
 658 %found = map {($_ => 1)} $o =~ /^===\s+(\w+)\s+===/mg;
 659 ok(scalar keys %found, 2);
 660 ok(exists $found{Zero});
 661 ok(exists $found{ZeroD});
 662
 663 ===============================================================================
 664
 665 # check --list-provided option
 666
 667 my @o = ppport(qw(--list-provided));
 668 my %p;
 669 my $fail = 0;
 670 for (@o) {
 671   my($name, $flags) = /^(\w+)(?:\s+\[(\w+(?:,\s+\w+)*)\])?$/ or $fail++;
 672   exists $p{$name} and $fail++;
 673   $p{$name} = defined $flags ? { map { ($_ => 1) } $flags =~ /(\w+)/g } : '';
 674 }
 675 ok(@o > 100);
 676 ok($fail, 0);
 677
 678 ok(exists $p{call_sv});
 679 ok(not ref $p{call_sv});
 680
 681 ok(exists $p{grok_bin});
 682 ok(ref $p{grok_bin}, 'HASH');
 683 ok(scalar keys %{$p{grok_bin}}, 2);
 684 ok($p{grok_bin}{explicit});
 685 ok($p{grok_bin}{depend});
 686
 687 ok(exists $p{gv_stashpvn});
 688 ok(ref $p{gv_stashpvn}, 'HASH');
 689 ok(scalar keys %{$p{gv_stashpvn}}, 2);
 690 ok($p{gv_stashpvn}{depend});
 691 ok($p{gv_stashpvn}{hint});
 692
 693 ok(exists $p{sv_catpvf_mg});
 694 ok(ref $p{sv_catpvf_mg}, 'HASH');
 695 ok(scalar keys %{$p{sv_catpvf_mg}}, 2);
 696 ok($p{sv_catpvf_mg}{explicit});
 697 ok($p{sv_catpvf_mg}{depend});
 698
 699 ok(exists $p{PL_signals});
 700 ok(ref $p{PL_signals}, 'HASH');
 701 ok(scalar keys %{$p{PL_signals}}, 1);
 702 ok($p{PL_signals}{explicit});
 703
 704 ===============================================================================
 705
 706 # check --list-unsupported option
 707
 708 my @o = ppport(qw(--list-unsupported));
 709 my %p;
 710 my $fail = 0;
 711 for (@o) {
 712   my($name, $ver) = /^(\w+)\s*\.+\s*([\d._]+)$/ or $fail++;
 713   exists $p{$name} and $fail++;
 714   $p{$name} = $ver;
 715 }
 716 ok(@o > 100);
 717 ok($fail, 0);
 718
 719 ok(exists $p{utf8_distance});
 720 ok($p{utf8_distance}, '5.6.0');
 721
 722 ok(exists $p{save_generic_svref});
 723 ok($p{save_generic_svref}, '5.005_03');
 724
 725 ===============================================================================
 726
 727 # check --nofilter option
 728
 729 my $o = ppport(qw(--nochanges));
 730 ok($o =~ /^Scanning.*foo\.cpp/mi);
 731 ok($o =~ /Analyzing.*foo\.cpp/mi);
 732 ok(matches($o, '^Scanning', 'm'), 1);
 733 ok(matches($o, 'Analyzing', 'm'), 1);
 734
 735 $o = ppport(qw(--nochanges foo.cpp foo.o Makefile.PL));
 736 ok($o =~ /Skipping the following files \(use --nofilter to avoid this\):/m);
 737 ok(matches($o, '^\|\s+foo\.o', 'mi'), 1);
 738 ok(matches($o, '^\|\s+Makefile\.PL', 'mi'), 1);
 739 ok($o =~ /^Scanning.*foo\.cpp/mi);
 740 ok($o =~ /Analyzing.*foo\.cpp/mi);
 741 ok(matches($o, '^Scanning', 'm'), 1);
 742 ok(matches($o, 'Analyzing', 'm'), 1);
 743
 744 $o = ppport(qw(--nochanges --nofilter foo.cpp foo.o Makefile.PL));
 745 ok($o =~ /^Scanning.*foo\.cpp/mi);
 746 ok($o =~ /Analyzing.*foo\.cpp/mi);
 747 ok($o =~ /^Scanning.*foo\.o/mi);
 748 ok($o =~ /Analyzing.*foo\.o/mi);
 749 ok($o =~ /^Scanning.*Makefile/mi);
 750 ok($o =~ /Analyzing.*Makefile/mi);
 751 ok(matches($o, '^Scanning', 'm'), 3);
 752 ok(matches($o, 'Analyzing', 'm'), 3);
 753
 754 ---------------------------- foo.cpp ------------------------------------------
 755
 756 newSViv();
 757
 758 ---------------------------- foo.o --------------------------------------------
 759
 760 newSViv();
 761
 762 ---------------------------- Makefile.PL --------------------------------------
 763
 764 newSViv();
 765
 766 ===============================================================================
 767
 768 # check if explicit variables are handled propery
 769
 770 my $o = ppport(qw(--copy=a));
 771 ok($o =~ /^Needs to include.*ppport\.h/m);
 772 ok($o =~ /^Uses PL_signals/m);
 773 ok($o =~ /^File needs PL_signals, adding static request/m);
 774 ok(eq_files('MyExt.xsa', 'MyExt.ra'));
 775
 776 unlink qw(MyExt.xsa);
 777
 778 ---------------------------- MyExt.xs -----------------------------------------
 779
 780 PL_signals = 123;
 781 if (PL_signals == 42)
 782   foo();
 783
 784 ---------------------------- MyExt.ra -----------------------------------------
 785
 786 #define NEED_PL_signals
 787 #include "ppport.h"
 788 PL_signals = 123;
 789 if (PL_signals == 42)
 790   foo();
 791
 792 ===============================================================================
 793
 794 my $o = ppport(qw(--nochanges file.xs));
 795 ok($o =~ /^Uses PL_copline/m);
 796 ok($o =~ /WARNING: PL_copline/m);
 797 ok($o =~ /^Uses SvUOK/m);
 798 ok($o =~ /WARNING: Uses SvUOK, which may not be portable/m);
 799 ok($o =~ /^Analysis completed \(2 warnings\)/m);
 800 ok($o =~ /^Looks good/m);
 801
 802 $o = ppport(qw(--nochanges --compat-version=5.8.0 file.xs));
 803 ok($o =~ /^Uses PL_copline/m);
 804 ok($o =~ /WARNING: PL_copline/m);
 805 ok($o !~ /WARNING: Uses SvUOK, which may not be portable/m);
 806 ok($o =~ /^Analysis completed \(1 warning\)/m);
 807 ok($o =~ /^Looks good/m);
 808
 809 ---------------------------- file.xs -----------------------------------------
 810
 811 #include "ppport.h"
 812 SvUOK
 813 PL_copline
 814
 815 ===============================================================================
 816
 817 my $o = ppport(qw(--copy=f));
 818
 819 for (qw(file.xs)) {
 820   ok($o =~ /^Writing copy of.*\Q$_\E.*with changes/mi);
 821   ok(-e "${_}f");
 822   ok(eq_files("${_}f", "${_}r"));
 823   unlink "${_}f";
 824 }
 825
 826 ---------------------------- file.xs -----------------------------------------
 827
 828 a_string = "sv_undef"
 829 a_char = 'sv_yes'
 830 #define SOMETHING defgv
 831 /* C-comment: sv_tainted */
 832 #
 833 # This is just a big XS comment using sv_no
 834 #
 835 /* The following, is NOT an XS comment! */
 836 #  define SOMETHING_ELSE defgv + \
 837                          sv_undef
 838
 839 ---------------------------- file.xsr -----------------------------------------
 840
 841 #include "ppport.h"
 842 a_string = "sv_undef"
 843 a_char = 'sv_yes'
 844 #define SOMETHING PL_defgv
 845 /* C-comment: sv_tainted */
 846 #
 847 # This is just a big XS comment using sv_no
 848 #
 849 /* The following, is NOT an XS comment! */
 850 #  define SOMETHING_ELSE PL_defgv + \
 851                          PL_sv_undef
 852
 853 ===============================================================================
 854
 855 my $o = ppport(qw(--copy=f));
 856
 857 for (qw(file.xs)) {
 858   ok($o =~ /^Writing copy of.*\Q$_\E.*with changes/mi);
 859   ok(-e "${_}f");
 860   ok(eq_files("${_}f", "${_}r"));
 861   unlink "${_}f";
 862 }
 863
 864 ---------------------------- file.xs -----------------------------------------
 865
 866 #define NEED_sv_2pv_flags
 867 #define NEED_vnewSVpvf
 868 #define NEED_warner
 869 #include "ppport.h"
 870 Perl_croak_nocontext("foo");
 871 Perl_croak("bar");
 872 croak("foo");
 873 croak_nocontext("foo");
 874 Perl_warner_nocontext("foo");
 875 Perl_warner("foo");
 876 warner_nocontext("foo");
 877 warner("foo");
 878
 879 ---------------------------- file.xsr -----------------------------------------
 880
 881 #define NEED_sv_2pv_flags
 882 #define NEED_vnewSVpvf
 883 #define NEED_warner
 884 #include "ppport.h"
 885 Perl_croak_nocontext("foo");
 886 Perl_croak(aTHX_ "bar");
 887 croak("foo");
 888 croak_nocontext("foo");
 889 Perl_warner_nocontext("foo");
 890 Perl_warner(aTHX_ "foo");
 891 warner_nocontext("foo");
 892 warner("foo");
 893