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