ext/Devel/PPPort/parts/inc/ppphtest

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