ext/Devel/PPPort/parts/inc/ppphtest

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