ext/Devel/PPPort/t/ppphtest.t

   1 ################################################################################
   2 #
   3 #            !!!!!   Do NOT edit this file directly!   !!!!!
   4 #
   5 #            Edit mktests.PL and/or parts/inc/ppphtest instead.
   6 #
   7 ################################################################################
   8
   9 BEGIN {
  10   if ($ENV{'PERL_CORE'}) {
  11     chdir 't' if -d 't';
  12     @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext';
  13     require Config; import Config;
  14     use vars '%Config';
  15     if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) {
  16       print "1..0 # Skip -- Perl configured without Devel::PPPort module\n";
  17       exit 0;
  18     }
  19   }
  20   else {
  21     unshift @INC, 't';
  22   }
  23
  24   eval "use Test";
  25   if ($@) {
  26     require 'testutil.pl';
  27     print "1..134\n";
  28   }
  29   else {
  30     plan(tests => 134);
  31   }
  32 }
  33
  34 use Devel::PPPort;
  35 use strict;
  36 $^W = 1;
  37
  38 use File::Path qw/rmtree mkpath/;
  39 use Config;
  40
  41 my $tmp = 'ppptmp';
  42 my $inc = '';
  43 my $perl = find_perl();
  44
  45 rmtree($tmp) if -d $tmp;
  46 mkpath($tmp) or die "mkpath $tmp: $!\n";
  47 chdir($tmp) or die "chdir $tmp: $!\n";
  48
  49 if ($ENV{'PERL_CORE'}) {
  50   if (-d '../../lib') {
  51     $inc = $^O eq 'VMS' ? '-"I../../lib"' : '-I../../lib';
  52     unshift @INC, '../../lib';
  53   }
  54 }
  55 if ($perl =~ m!^\./!) {
  56   $perl = ".$perl";
  57 }
  58
  59 END {
  60   chdir('..') if !-d $tmp && -d "../$tmp";
  61   rmtree($tmp) if -d $tmp;
  62 }
  63
  64 ok(&Devel::PPPort::WriteFile("ppport.h"));
  65
  66 sub ppport
  67 {
  68   my @args = @_;
  69   print "# *** running $perl $inc ppport.h @args ***\n";
  70   my $out = join '', `$perl $inc ppport.h @args`;
  71   my $copy = $out;
  72   $copy =~ s/^/# | /mg;
  73   print "$copy\n";
  74   return $out;
  75 }
  76
  77 sub matches
  78 {
  79   my($str, $re, $mod) = @_;
  80   my @n;
  81   eval "\@n = \$str =~ /$re/g$mod;";
  82   if ($@) {
  83     my $err = $@;
  84     $err =~ s/^/# *** /mg;
  85     print "# *** ERROR ***\n$err\n";
  86   }
  87   return $@ ? -42 : scalar @n;
  88 }
  89
  90 sub eq_files
  91 {
  92   my($f1, $f2) = @_;
  93   return 0 unless -e $f1 && -e $f2;
  94   local *F;
  95   for ($f1, $f2) {
  96     print "# File: $_\n";
  97     unless (open F, $_) {
  98       print "# couldn't open $_: $!\n";
  99       return 0;
 100     }
 101     $_ = do { local $/; <F> };
 102     close F;
 103     my $copy = $_;
 104     $copy =~ s/^/# | /mg;
 105     print "$copy\n";
 106   }
 107   return $f1 eq $f2;
 108 }
 109
 110 my @tests;
 111
 112 for (split /\s*={70,}\s*/, do { local $/; <DATA> }) {
 113   s/^\s+//; s/\s+$//;
 114   my($c, %f);
 115   ($c, @f{m/-{20,}\s+(\S+)\s+-{20,}/g}) = split /\s*-{20,}\s+\S+\s+-{20,}\s*/;
 116   push @tests, { code => $c, files => \%f };
 117 }
 118
 119 my $t;
 120 for $t (@tests) {
 121   my $f;
 122   for $f (keys %{$t->{files}}) {
 123     my @f = split /\//, $f;
 124     if (@f > 1) {
 125       pop @f;
 126       my $path = join '/', @f;
 127       mkpath($path) or die "mkpath('$path'): $!\n";
 128     }
 129     my $txt = $t->{files}{$f};
 130     local *F;
 131     open F, ">$f" or die "open $f: $!\n";
 132     print F "$txt\n";
 133     close F;
 134     $txt =~ s/^/# | /mg;
 135     print "# *** writing $f ***\n$txt\n";
 136   }
 137
 138   eval $t->{code};
 139   if ($@) {
 140     my $err = $@;
 141     $err =~ s/^/# *** /mg;
 142     print "# *** ERROR ***\n$err\n";
 143   }
 144   ok($@, '');
 145
 146   for (keys %{$t->{files}}) {
 147     unlink $_ or die "unlink('$_'): $!\n";
 148   }
 149 }
 150
 151 sub find_perl
 152 {
 153   my $perl = $^X;
 154
 155   return $perl if $^O eq 'VMS';
 156
 157   my $exe = $Config{'_exe'} || '';
 158
 159   if ($perl =~ /^perl\Q$exe\E$/i) {
 160     $perl = "perl$exe";
 161     eval "require File::Spec";
 162     if ($@) {
 163       $perl = "./$perl";
 164     } else {
 165       $perl = File::Spec->catfile(File::Spec->curdir(), $perl);
 166     }
 167   }
 168
 169   if ($perl !~ /\Q$exe\E$/i) {
 170     $perl .= $exe;
 171   }
 172
 173   warn "find_perl: cannot find $perl from $^X" unless -f $perl;
 174
 175   return $perl;
 176 }
 177
 178 __DATA__
 179
 180 my $o = ppport(qw(--help));
 181 ok($o =~ /^Usage:.*ppport\.h/m);
 182 ok($o =~ /--help/m);
 183
 184 $o = ppport(qw(--nochanges));
 185 ok($o =~ /^scanning.*test\.xs/mi);
 186 ok($o =~ /analyzing.*test\.xs/mi);
 187 ok(matches($o, '^scanning', 'mi'), 1);
 188 ok(matches($o, 'analyzing', 'mi'), 1);
 189 ok($o =~ /Uses Perl_newSViv instead of newSViv/);
 190
 191 $o = ppport(qw(--quiet --nochanges));
 192 ok($o =~ /^\s*$/);
 193
 194 ---------------------------- test.xs ------------------------------------------
 195
 196 Perl_newSViv();
 197
 198 ===============================================================================
 199
 200 # check if C and C++ comments are filtered correctly
 201
 202 my $o = ppport(qw(--copy=a));
 203 ok($o =~ /^scanning.*MyExt\.xs/mi);
 204 ok($o =~ /analyzing.*MyExt\.xs/mi);
 205 ok(matches($o, '^scanning', 'mi'), 1);
 206 ok($o =~ /^Needs to include.*ppport\.h/m);
 207 ok($o !~ /^Uses grok_bin/m);
 208 ok($o !~ /^Uses newSVpv/m);
 209 ok($o =~ /Uses 1 C\+\+ style comment/m);
 210 ok(eq_files('MyExt.xsa', 'MyExt.ra'));
 211
 212 # check if C++ are left untouched with --cplusplus
 213
 214 $o = ppport(qw(--copy=b --cplusplus));
 215 ok($o =~ /^scanning.*MyExt\.xs/mi);
 216 ok($o =~ /analyzing.*MyExt\.xs/mi);
 217 ok(matches($o, '^scanning', 'mi'), 1);
 218 ok($o =~ /^Needs to include.*ppport\.h/m);
 219 ok($o !~ /^Uses grok_bin/m);
 220 ok($o !~ /^Uses newSVpv/m);
 221 ok($o !~ /Uses \d+ C\+\+ style comment/m);
 222 ok(eq_files('MyExt.xsb', 'MyExt.rb'));
 223
 224 unlink qw(MyExt.xsa MyExt.xsb);
 225
 226 ---------------------------- MyExt.xs -----------------------------------------
 227
 228 newSVuv();
 229     // newSVpv();
 230   XPUSHs(foo);
 231 /* grok_bin(); */
 232
 233 ---------------------------- MyExt.ra -----------------------------------------
 234
 235 #include "ppport.h"
 236 newSVuv();
 237     /* newSVpv(); */
 238   XPUSHs(foo);
 239 /* grok_bin(); */
 240
 241 ---------------------------- MyExt.rb -----------------------------------------
 242
 243 #include "ppport.h"
 244 newSVuv();
 245     // newSVpv();
 246   XPUSHs(foo);
 247 /* grok_bin(); */
 248
 249 ===============================================================================
 250
 251 my $o = ppport(qw(--nochanges file1.xs));
 252 ok($o =~ /^scanning.*file1\.xs/mi);
 253 ok($o =~ /analyzing.*file1\.xs/mi);
 254 ok($o !~ /^scanning.*file2\.xs/mi);
 255 ok($o =~ /^Uses newCONSTSUB/m);
 256 ok($o =~ /^Uses SvPV_nolen.*depends.*sv_2pv_nolen/m);
 257 ok($o =~ /hint for newCONSTSUB/m);
 258 ok($o !~ /hint for sv_2pv_nolen/m);
 259 ok($o =~ /^Looks good/m);
 260
 261 $o = ppport(qw(--nochanges --nohints file1.xs));
 262 ok($o =~ /^scanning.*file1\.xs/mi);
 263 ok($o =~ /analyzing.*file1\.xs/mi);
 264 ok($o !~ /^scanning.*file2\.xs/mi);
 265 ok($o =~ /^Uses newCONSTSUB/m);
 266 ok($o =~ /^Uses SvPV_nolen.*depends.*sv_2pv_nolen/m);
 267 ok($o !~ /hint for newCONSTSUB/m);
 268 ok($o !~ /hint for sv_2pv_nolen/m);
 269 ok($o =~ /^Looks good/m);
 270
 271 $o = ppport(qw(--nochanges --nohints --nodiag file1.xs));
 272 ok($o =~ /^scanning.*file1\.xs/mi);
 273 ok($o =~ /analyzing.*file1\.xs/mi);
 274 ok($o !~ /^scanning.*file2\.xs/mi);
 275 ok($o !~ /^Uses newCONSTSUB/m);
 276 ok($o !~ /^Uses SvPV_nolen/m);
 277 ok($o !~ /hint for newCONSTSUB/m);
 278 ok($o !~ /hint for sv_2pv_nolen/m);
 279 ok($o =~ /^Looks good/m);
 280
 281 $o = ppport(qw(--nochanges --quiet file1.xs));
 282 ok($o =~ /^\s*$/);
 283
 284 $o = ppport(qw(--nochanges file2.xs));
 285 ok($o =~ /^scanning.*file2\.xs/mi);
 286 ok($o =~ /analyzing.*file2\.xs/mi);
 287 ok($o !~ /^scanning.*file1\.xs/mi);
 288 ok($o =~ /^Uses mXPUSHp/m);
 289 ok($o =~ /^Needs to include.*ppport\.h/m);
 290 ok($o !~ /^Looks good/m);
 291 ok($o =~ /^1 potentially required change detected/m);
 292
 293 $o = ppport(qw(--nochanges --nohints file2.xs));
 294 ok($o =~ /^scanning.*file2\.xs/mi);
 295 ok($o =~ /analyzing.*file2\.xs/mi);
 296 ok($o !~ /^scanning.*file1\.xs/mi);
 297 ok($o =~ /^Uses mXPUSHp/m);
 298 ok($o =~ /^Needs to include.*ppport\.h/m);
 299 ok($o !~ /^Looks good/m);
 300 ok($o =~ /^1 potentially required change detected/m);
 301
 302 $o = ppport(qw(--nochanges --nohints --nodiag file2.xs));
 303 ok($o =~ /^scanning.*file2\.xs/mi);
 304 ok($o =~ /analyzing.*file2\.xs/mi);
 305 ok($o !~ /^scanning.*file1\.xs/mi);
 306 ok($o !~ /^Uses mXPUSHp/m);
 307 ok($o !~ /^Needs to include.*ppport\.h/m);
 308 ok($o !~ /^Looks good/m);
 309 ok($o =~ /^1 potentially required change detected/m);
 310
 311 $o = ppport(qw(--nochanges --quiet file2.xs));
 312 ok($o =~ /^\s*$/);
 313
 314 ---------------------------- file1.xs -----------------------------------------
 315
 316 #define NEED_newCONSTSUB
 317 #define NEED_sv_2pv_nolen
 318 #include "ppport.h"
 319
 320 newCONSTSUB();
 321 SvPV_nolen();
 322
 323 ---------------------------- file2.xs -----------------------------------------
 324
 325 mXPUSHp(foo);
 326
 327 ===============================================================================
 328
 329 my $o = ppport(qw(--nochanges));
 330 ok($o =~ /^scanning.*FooBar\.xs/mi);
 331 ok($o =~ /analyzing.*FooBar\.xs/mi);
 332 ok(matches($o, '^scanning', 'mi'), 1);
 333 ok($o !~ /^Looks good/m);
 334 ok($o =~ /^Uses grok_bin/m);
 335
 336 ---------------------------- FooBar.xs ----------------------------------------
 337
 338 newSViv();
 339 XPUSHs(foo);
 340 grok_bin();
 341
 342 ===============================================================================
 343
 344 my $o = ppport(qw(--nochanges));
 345 ok($o =~ /^scanning.*First\.xs/mi);
 346 ok($o =~ /analyzing.*First\.xs/mi);
 347 ok($o =~ /^scanning.*second\.h/mi);
 348 ok($o =~ /analyzing.*second\.h/mi);
 349 ok($o =~ /^scanning.*sub.*third\.c/mi);
 350 ok($o =~ /analyzing.*sub.*third\.c/mi);
 351 ok($o !~ /^scanning.*foobar/mi);
 352 ok(matches($o, '^scanning', 'mi'), 3);
 353
 354 ---------------------------- First.xs -----------------------------------------
 355
 356 one
 357
 358 ---------------------------- foobar.xyz ---------------------------------------
 359
 360 two
 361
 362 ---------------------------- second.h -----------------------------------------
 363
 364 three
 365
 366 ---------------------------- sub/third.c --------------------------------------
 367
 368 four
 369
 370 ===============================================================================
 371
 372 my $o = ppport(qw(--nochanges));
 373 ok($o =~ /Possibly wrong #define NEED_foobar in.*test.xs/i);
 374
 375 ---------------------------- test.xs ------------------------------------------
 376
 377 #define NEED_foobar
 378
 379 ===============================================================================
 380
 381 # And now some complex "real-world" example
 382
 383 my $o = ppport(qw(--copy=f));
 384 for (qw(main.xs mod1.c mod2.c mod3.c mod4.c mod5.c)) {
 385   ok($o =~ /^scanning.*\Q$_\E/mi);
 386   ok($o =~ /analyzing.*\Q$_\E/i);
 387 }
 388 ok(matches($o, '^scanning', 'mi'), 6);
 389
 390 ok(matches($o, '^Writing copy of', 'mi'), 5);
 391 ok(!-e "mod5.cf");
 392
 393 for (qw(main.xs mod1.c mod2.c mod3.c mod4.c)) {
 394   ok($o =~ /^Writing copy of.*\Q$_\E.*with changes/mi);
 395   ok(-e "${_}f");
 396   ok(eq_files("${_}f", "${_}r"));
 397   unlink "${_}f";
 398 }
 399
 400 ---------------------------- main.xs ------------------------------------------
 401
 402 #include "EXTERN.h"
 403 #include "perl.h"
 404 #include "XSUB.h"
 405
 406 #define NEED_newCONSTSUB
 407 #define NEED_grok_hex_GLOBAL
 408 #include "ppport.h"
 409
 410 newCONSTSUB();
 411 grok_hex();
 412 Perl_grok_bin(aTHX_ foo, bar);
 413
 414 /* some comment */
 415
 416 perl_eval_pv();
 417 grok_bin();
 418 Perl_grok_bin(bar, sv_no);
 419
 420 ---------------------------- mod1.c -------------------------------------------
 421
 422 #include "EXTERN.h"
 423 #include "perl.h"
 424 #include "XSUB.h"
 425
 426 #define NEED_grok_bin_GLOBAL
 427 #define NEED_newCONSTSUB
 428 #include "ppport.h"
 429
 430 newCONSTSUB();
 431 grok_bin();
 432 {
 433   Perl_croak ("foo");
 434   Perl_sv_catpvf();  /* I know it's wrong ;-) */
 435 }
 436
 437 ---------------------------- mod2.c -------------------------------------------
 438
 439 #include "EXTERN.h"
 440 #include "perl.h"
 441 #include "XSUB.h"
 442
 443 #define NEED_eval_pv
 444 #include "ppport.h"
 445
 446 newSViv();
 447
 448 /*
 449    eval_pv();
 450 */
 451
 452 ---------------------------- mod3.c -------------------------------------------
 453
 454 #include "EXTERN.h"
 455 #include "perl.h"
 456 #include "XSUB.h"
 457
 458 grok_oct();
 459 eval_pv();
 460
 461 ---------------------------- mod4.c -------------------------------------------
 462
 463 #include "EXTERN.h"
 464 #include "perl.h"
 465 #include "XSUB.h"
 466
 467 START_MY_CXT;
 468
 469 ---------------------------- mod5.c -------------------------------------------
 470
 471 #include "EXTERN.h"
 472 #include "perl.h"
 473 #include "XSUB.h"
 474
 475 #include "ppport.h"
 476 call_pv();
 477
 478 ---------------------------- main.xsr -----------------------------------------
 479
 480 #include "EXTERN.h"
 481 #include "perl.h"
 482 #include "XSUB.h"
 483
 484 #define NEED_eval_pv_GLOBAL
 485 #define NEED_grok_hex
 486 #define NEED_newCONSTSUB_GLOBAL
 487 #include "ppport.h"
 488
 489 newCONSTSUB();
 490 grok_hex();
 491 grok_bin(foo, bar);
 492
 493 /* some comment */
 494
 495 eval_pv();
 496 grok_bin();
 497 grok_bin(bar, PL_sv_no);
 498
 499 ---------------------------- mod1.cr ------------------------------------------
 500
 501 #include "EXTERN.h"
 502 #include "perl.h"
 503 #include "XSUB.h"
 504
 505 #define NEED_grok_bin_GLOBAL
 506 #include "ppport.h"
 507
 508 newCONSTSUB();
 509 grok_bin();
 510 {
 511   Perl_croak (aTHX_ "foo");
 512   Perl_sv_catpvf(aTHX);  /* I know it's wrong ;-) */
 513 }
 514
 515 ---------------------------- mod2.cr ------------------------------------------
 516
 517 #include "EXTERN.h"
 518 #include "perl.h"
 519 #include "XSUB.h"
 520
 521
 522 newSViv();
 523
 524 /*
 525    eval_pv();
 526 */
 527
 528 ---------------------------- mod3.cr ------------------------------------------
 529
 530 #include "EXTERN.h"
 531 #include "perl.h"
 532 #include "XSUB.h"
 533 #define NEED_grok_oct
 534 #include "ppport.h"
 535
 536 grok_oct();
 537 eval_pv();
 538
 539 ---------------------------- mod4.cr ------------------------------------------
 540
 541 #include "EXTERN.h"
 542 #include "perl.h"
 543 #include "XSUB.h"
 544 #include "ppport.h"
 545
 546 START_MY_CXT;
 547
 548 ===============================================================================
 549
 550 my $o = ppport(qw(--nochanges));
 551 ok($o =~ /Uses grok_hex/m);
 552 ok($o !~ /Looks good/m);
 553
 554 $o = ppport(qw(--nochanges --compat-version=5.8.0));
 555 ok($o !~ /Uses grok_hex/m);
 556 ok($o =~ /Looks good/m);
 557
 558 ---------------------------- FooBar.xs ----------------------------------------
 559
 560 grok_hex();
 561
 562 ===============================================================================
 563
 564 my $o = ppport(qw(--nochanges));
 565 ok($o =~ /Uses SvPVutf8_force, which may not be portable/m);
 566
 567 $o = ppport(qw(--nochanges --compat-version=5.6.0));
 568 ok($o !~ /Uses SvPVutf8_force/m);
 569
 570 ---------------------------- FooBar.xs ----------------------------------------
 571
 572 SvPVutf8_force();
 573
 574 ===============================================================================
 575
 576 my $o = ppport(qw(--nochanges));
 577 ok($o !~ /potentially required change/);
 578 ok(matches($o, '^Looks good', 'mi'), 2);
 579
 580 ---------------------------- FooBar.xs ----------------------------------------
 581
 582 #define NEED_grok_numeric_radix
 583 #define NEED_grok_number
 584 #include "ppport.h"
 585
 586 GROK_NUMERIC_RADIX();
 587 grok_number();
 588
 589 ---------------------------- foo.c --------------------------------------------
 590
 591 #include "ppport.h"
 592
 593 call_pv();
 594