1 ################################################################################
3 # !!!!! Do NOT edit this file directly! !!!!!
5 # Edit mktests.PL and/or parts/inc/ppphtest instead.
7 ################################################################################
10 if ($ENV{'PERL_CORE'}) {
12 @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext';
13 require Config; import Config;
15 if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) {
16 print "1..0 # Skip -- Perl configured without Devel::PPPort module\n";
26 require 'testutil.pl' if $@;
39 package Devel::PPPort;
42 @ISA = qw(DynaLoader);
43 bootstrap Devel::PPPort;
48 if ($ENV{'SKIP_SLOW_TESTS'}) {
50 skip("skip: SKIP_SLOW_TESTS", 0);
56 use File::Path qw/rmtree mkpath/;
61 my $isVMS = $^O eq 'VMS';
62 my $isMAC = $^O eq 'MacOS';
63 my $perl = find_perl();
65 rmtree($tmp) if -d $tmp;
66 mkpath($tmp) or die "mkpath $tmp: $!\n";
67 chdir($tmp) or die "chdir $tmp: $!\n";
69 if ($ENV{'PERL_CORE'}) {
72 $inc = '"-I../../lib"';
80 unshift @INC, '../../lib';
83 if ($perl =~ m!^\./!) {
88 chdir('..') if !-d $tmp && -d "../$tmp";
89 rmtree($tmp) if -d $tmp;
92 ok(&Devel::PPPort::WriteFile("ppport.h"));
98 $c .= "\n" unless $c =~ /[\r\n]$/;
104 my @args = ('ppport.h', @_);
105 unshift @args, $inc if $inc;
106 my $run = $perl =~ m/\s/ ? qq("$perl") : $perl;
107 $run .= ' -MMac::err=unix' if $isMAC;
109 $_ = qq("$_") if $isVMS && /^[^"]/;
112 print "# *** running $run ***\n";
113 $run .= ' 2>&1' unless $isMAC;
115 my $out = join '', @out;
117 return wantarray ? @out : $out;
122 my($str, $re, $mod) = @_;
124 eval "\@n = \$str =~ /$re/g$mod;";
127 $err =~ s/^/# *** /mg;
128 print "# *** ERROR ***\n$err\n";
130 return $@ ? -42 : scalar @n;
136 return 0 unless -e $f1 && -e $f2;
139 print "# File: $_\n";
140 unless (open F, $_) {
141 print "# couldn't open $_: $!\n";
144 $_ = do { local $/; <F> };
153 for (split /\s*={70,}\s*/, do { local $/; <DATA> }) {
156 ($c, @f{m/-{20,}\s+(\S+)\s+-{20,}/g}) = split /\s*-{20,}\s+\S+\s+-{20,}\s*/;
157 push @tests, { code => $c, files => \%f };
163 for $f (keys %{$t->{files}}) {
164 my @f = split /\//, $f;
167 my $path = join '/', @f;
168 mkpath($path) or die "mkpath('$path'): $!\n";
170 my $txt = $t->{files}{$f};
172 open F, ">$f" or die "open $f: $!\n";
176 print "# *** writing $f ***\n$txt\n";
182 $err =~ s/^/# *** /mg;
183 print "# *** ERROR ***\n$err\n";
187 for (keys %{$t->{files}}) {
188 unlink $_ or die "unlink('$_'): $!\n";
196 return $perl if $isVMS;
198 my $exe = $Config{'_exe'} || '';
200 if ($perl =~ /^perl\Q$exe\E$/i) {
202 eval "require File::Spec";
206 $perl = File::Spec->catfile(File::Spec->curdir(), $perl);
210 if ($perl !~ /\Q$exe\E$/i) {
214 warn "find_perl: cannot find $perl from $^X" unless -f $perl;
221 my $o = ppport(qw(--help));
222 ok($o =~ /^Usage:.*ppport\.h/m);
225 $o = ppport(qw(--version));
226 ok($o =~ /^This is.*ppport.*\d+\.\d+(?:_?\d+)?\.$/);
228 $o = ppport(qw(--nochanges));
229 ok($o =~ /^Scanning.*test\.xs/mi);
230 ok($o =~ /Analyzing.*test\.xs/mi);
231 ok(matches($o, '^Scanning', 'm'), 1);
232 ok(matches($o, 'Analyzing', 'm'), 1);
233 ok($o =~ /Uses Perl_newSViv instead of newSViv/);
235 $o = ppport(qw(--quiet --nochanges));
238 ---------------------------- test.xs ------------------------------------------
242 ===============================================================================
244 # check if C and C++ comments are filtered correctly
246 my $o = ppport(qw(--copy=a));
247 ok($o =~ /^Scanning.*MyExt\.xs/mi);
248 ok($o =~ /Analyzing.*MyExt\.xs/mi);
249 ok(matches($o, '^Scanning', 'm'), 1);
250 ok($o =~ /^Needs to include.*ppport\.h/m);
251 ok($o !~ /^Uses grok_bin/m);
252 ok($o !~ /^Uses newSVpv/m);
253 ok($o =~ /Uses 1 C\+\+ style comment/m);
254 ok(eq_files('MyExt.xsa', 'MyExt.ra'));
256 # check if C++ are left untouched with --cplusplus
258 $o = ppport(qw(--copy=b --cplusplus));
259 ok($o =~ /^Scanning.*MyExt\.xs/mi);
260 ok($o =~ /Analyzing.*MyExt\.xs/mi);
261 ok(matches($o, '^Scanning', 'm'), 1);
262 ok($o =~ /^Needs to include.*ppport\.h/m);
263 ok($o !~ /^Uses grok_bin/m);
264 ok($o !~ /^Uses newSVpv/m);
265 ok($o !~ /Uses \d+ C\+\+ style comment/m);
266 ok(eq_files('MyExt.xsb', 'MyExt.rb'));
268 unlink qw(MyExt.xsa MyExt.xsb);
270 ---------------------------- MyExt.xs -----------------------------------------
277 ---------------------------- MyExt.ra -----------------------------------------
285 ---------------------------- MyExt.rb -----------------------------------------
293 ===============================================================================
295 my $o = ppport(qw(--nochanges file1.xs));
296 ok($o =~ /^Scanning.*file1\.xs/mi);
297 ok($o =~ /Analyzing.*file1\.xs/mi);
298 ok($o !~ /^Scanning.*file2\.xs/mi);
299 ok($o =~ /^Uses newCONSTSUB/m);
300 ok($o =~ /^Uses SvPV_nolen.*depends.*sv_2pv_nolen/m);
301 ok($o =~ /hint for newCONSTSUB/m);
302 ok($o !~ /hint for sv_2pv_nolen/m);
303 ok($o =~ /^Looks good/m);
305 $o = ppport(qw(--nochanges --nohints file1.xs));
306 ok($o =~ /^Scanning.*file1\.xs/mi);
307 ok($o =~ /Analyzing.*file1\.xs/mi);
308 ok($o !~ /^Scanning.*file2\.xs/mi);
309 ok($o =~ /^Uses newCONSTSUB/m);
310 ok($o =~ /^Uses SvPV_nolen.*depends.*sv_2pv_nolen/m);
311 ok($o !~ /hint for newCONSTSUB/m);
312 ok($o !~ /hint for sv_2pv_nolen/m);
313 ok($o =~ /^Looks good/m);
315 $o = ppport(qw(--nochanges --nohints --nodiag file1.xs));
316 ok($o =~ /^Scanning.*file1\.xs/mi);
317 ok($o =~ /Analyzing.*file1\.xs/mi);
318 ok($o !~ /^Scanning.*file2\.xs/mi);
319 ok($o !~ /^Uses newCONSTSUB/m);
320 ok($o !~ /^Uses SvPV_nolen/m);
321 ok($o !~ /hint for newCONSTSUB/m);
322 ok($o !~ /hint for sv_2pv_nolen/m);
323 ok($o =~ /^Looks good/m);
325 $o = ppport(qw(--nochanges --quiet file1.xs));
328 $o = ppport(qw(--nochanges file2.xs));
329 ok($o =~ /^Scanning.*file2\.xs/mi);
330 ok($o =~ /Analyzing.*file2\.xs/mi);
331 ok($o !~ /^Scanning.*file1\.xs/mi);
332 ok($o =~ /^Uses mXPUSHp/m);
333 ok($o =~ /^Needs to include.*ppport\.h/m);
334 ok($o !~ /^Looks good/m);
335 ok($o =~ /^1 potentially required change detected/m);
337 $o = ppport(qw(--nochanges --nohints file2.xs));
338 ok($o =~ /^Scanning.*file2\.xs/mi);
339 ok($o =~ /Analyzing.*file2\.xs/mi);
340 ok($o !~ /^Scanning.*file1\.xs/mi);
341 ok($o =~ /^Uses mXPUSHp/m);
342 ok($o =~ /^Needs to include.*ppport\.h/m);
343 ok($o !~ /^Looks good/m);
344 ok($o =~ /^1 potentially required change detected/m);
346 $o = ppport(qw(--nochanges --nohints --nodiag file2.xs));
347 ok($o =~ /^Scanning.*file2\.xs/mi);
348 ok($o =~ /Analyzing.*file2\.xs/mi);
349 ok($o !~ /^Scanning.*file1\.xs/mi);
350 ok($o !~ /^Uses mXPUSHp/m);
351 ok($o !~ /^Needs to include.*ppport\.h/m);
352 ok($o !~ /^Looks good/m);
353 ok($o =~ /^1 potentially required change detected/m);
355 $o = ppport(qw(--nochanges --quiet file2.xs));
358 ---------------------------- file1.xs -----------------------------------------
360 #define NEED_newCONSTSUB
361 #define NEED_sv_2pv_nolen
367 ---------------------------- file2.xs -----------------------------------------
371 ===============================================================================
373 my $o = ppport(qw(--nochanges));
374 ok($o =~ /^Scanning.*FooBar\.xs/mi);
375 ok($o =~ /Analyzing.*FooBar\.xs/mi);
376 ok(matches($o, '^Scanning', 'm'), 1);
377 ok($o !~ /^Looks good/m);
378 ok($o =~ /^Uses grok_bin/m);
380 ---------------------------- FooBar.xs ----------------------------------------
386 ===============================================================================
388 my $o = ppport(qw(--nochanges));
389 ok($o =~ /^Scanning.*First\.xs/mi);
390 ok($o =~ /Analyzing.*First\.xs/mi);
391 ok($o =~ /^Scanning.*second\.h/mi);
392 ok($o =~ /Analyzing.*second\.h/mi);
393 ok($o =~ /^Scanning.*sub.*third\.c/mi);
394 ok($o =~ /Analyzing.*sub.*third\.c/mi);
395 ok($o !~ /^Scanning.*foobar/mi);
396 ok(matches($o, '^Scanning', 'm'), 3);
398 ---------------------------- First.xs -----------------------------------------
402 ---------------------------- foobar.xyz ---------------------------------------
406 ---------------------------- second.h -----------------------------------------
410 ---------------------------- sub/third.c --------------------------------------
414 ===============================================================================
416 my $o = ppport(qw(--nochanges));
417 ok($o =~ /Possibly wrong #define NEED_foobar in.*test.xs/i);
419 ---------------------------- test.xs ------------------------------------------
423 ===============================================================================
425 # And now some complex "real-world" example
427 my $o = ppport(qw(--copy=f));
428 for (qw(main.xs mod1.c mod2.c mod3.c mod4.c mod5.c)) {
429 ok($o =~ /^Scanning.*\Q$_\E/mi);
430 ok($o =~ /Analyzing.*\Q$_\E/i);
432 ok(matches($o, '^Scanning', 'm'), 6);
434 ok(matches($o, '^Writing copy of', 'm'), 5);
437 for (qw(main.xs mod1.c mod2.c mod3.c mod4.c)) {
438 ok($o =~ /^Writing copy of.*\Q$_\E.*with changes/mi);
440 ok(eq_files("${_}f", "${_}r"));
444 ---------------------------- main.xs ------------------------------------------
450 #define NEED_newCONSTSUB
451 #define NEED_grok_hex_GLOBAL
456 Perl_grok_bin(aTHX_ foo, bar);
462 Perl_grok_bin(bar, sv_no);
464 ---------------------------- mod1.c -------------------------------------------
470 #define NEED_grok_bin_GLOBAL
471 #define NEED_newCONSTSUB
478 Perl_sv_catpvf(); /* I know it's wrong ;-) */
481 ---------------------------- mod2.c -------------------------------------------
496 ---------------------------- mod3.c -------------------------------------------
505 ---------------------------- mod4.c -------------------------------------------
513 ---------------------------- mod5.c -------------------------------------------
522 ---------------------------- main.xsr -----------------------------------------
528 #define NEED_eval_pv_GLOBAL
529 #define NEED_grok_hex
530 #define NEED_newCONSTSUB_GLOBAL
541 grok_bin(bar, PL_sv_no);
543 ---------------------------- mod1.cr ------------------------------------------
549 #define NEED_grok_bin_GLOBAL
555 Perl_croak (aTHX_ "foo");
556 Perl_sv_catpvf(aTHX); /* I know it's wrong ;-) */
559 ---------------------------- mod2.cr ------------------------------------------
572 ---------------------------- mod3.cr ------------------------------------------
577 #define NEED_grok_oct
583 ---------------------------- mod4.cr ------------------------------------------
592 ===============================================================================
594 my $o = ppport(qw(--nochanges));
595 ok($o =~ /Uses grok_hex/m);
596 ok($o !~ /Looks good/m);
598 $o = ppport(qw(--nochanges --compat-version=5.8.0));
599 ok($o !~ /Uses grok_hex/m);
600 ok($o =~ /Looks good/m);
602 ---------------------------- FooBar.xs ----------------------------------------
606 ===============================================================================
608 my $o = ppport(qw(--nochanges));
609 ok($o =~ /Uses SvPVutf8_force, which may not be portable/m);
611 $o = ppport(qw(--nochanges --compat-version=5.5.3));
612 ok($o =~ /Uses SvPVutf8_force, which may not be portable/m);
614 $o = ppport(qw(--nochanges --compat-version=5.005_03));
615 ok($o =~ /Uses SvPVutf8_force, which may not be portable/m);
617 $o = ppport(qw(--nochanges --compat-version=5.6.0));
618 ok($o !~ /Uses SvPVutf8_force/m);
620 $o = ppport(qw(--nochanges --compat-version=5.006));
621 ok($o !~ /Uses SvPVutf8_force/m);
623 $o = ppport(qw(--nochanges --compat-version=5.999.999));
624 ok($o !~ /Uses SvPVutf8_force/m);
626 $o = ppport(qw(--nochanges --compat-version=6.0.0));
627 ok($o =~ /Only Perl 5 is supported/m);
629 $o = ppport(qw(--nochanges --compat-version=5.1000.999));
630 ok($o =~ /Invalid version number: 5.1000.999/m);
632 $o = ppport(qw(--nochanges --compat-version=5.999.1000));
633 ok($o =~ /Invalid version number: 5.999.1000/m);
635 ---------------------------- FooBar.xs ----------------------------------------
639 ===============================================================================
641 my $o = ppport(qw(--nochanges));
642 ok($o !~ /potentially required change/);
643 ok(matches($o, '^Looks good', 'm'), 2);
645 ---------------------------- FooBar.xs ----------------------------------------
647 #define NEED_grok_numeric_radix
648 #define NEED_grok_number
651 GROK_NUMERIC_RADIX();
654 ---------------------------- foo.c --------------------------------------------
660 ===============================================================================
662 # check --api-info option
664 my $o = ppport(qw(--api-info=INT2PTR));
665 my %found = map {($_ => 1)} $o =~ /^===\s+(\w+)\s+===/mg;
666 ok(scalar keys %found, 1);
667 ok(exists $found{INT2PTR});
668 ok(matches($o, '^Supported at least starting from perl-5\.6\.0\.', 'm'), 1);
669 ok(matches($o, '^Support by .*ppport.* provided back to perl-5\.003\.', 'm'), 1);
671 $o = ppport(qw(--api-info=Zero));
672 %found = map {($_ => 1)} $o =~ /^===\s+(\w+)\s+===/mg;
673 ok(scalar keys %found, 1);
674 ok(exists $found{Zero});
675 ok(matches($o, '^No portability information available\.', 'm'), 1);
677 $o = ppport(qw(--api-info=/Zero/));
678 %found = map {($_ => 1)} $o =~ /^===\s+(\w+)\s+===/mg;
679 ok(scalar keys %found, 2);
680 ok(exists $found{Zero});
681 ok(exists $found{ZeroD});
683 ===============================================================================
685 # check --list-provided option
687 my @o = ppport(qw(--list-provided));
691 my($name, $flags) = /^(\w+)(?:\s+\[(\w+(?:,\s+\w+)*)\])?$/ or $fail++;
692 exists $p{$name} and $fail++;
693 $p{$name} = defined $flags ? { map { ($_ => 1) } $flags =~ /(\w+)/g } : '';
698 ok(exists $p{call_sv});
699 ok(not ref $p{call_sv});
701 ok(exists $p{grok_bin});
702 ok(ref $p{grok_bin}, 'HASH');
703 ok(scalar keys %{$p{grok_bin}}, 1);
704 ok($p{grok_bin}{explicit});
706 ok(exists $p{gv_stashpvn});
707 ok(ref $p{gv_stashpvn}, 'HASH');
708 ok(scalar keys %{$p{gv_stashpvn}}, 1);
709 ok($p{gv_stashpvn}{hint});
711 ok(exists $p{sv_catpvf_mg});
712 ok(ref $p{sv_catpvf_mg}, 'HASH');
713 ok(scalar keys %{$p{sv_catpvf_mg}}, 2);
714 ok($p{sv_catpvf_mg}{explicit});
715 ok($p{sv_catpvf_mg}{depend});
717 ===============================================================================
719 # check --list-unsupported option
721 my @o = ppport(qw(--list-unsupported));
725 my($name, $ver) = /^(\w+)\s*\.+\s*([\d._]+)$/ or $fail++;
726 exists $p{$name} and $fail++;
732 ok(exists $p{utf8_distance});
733 ok($p{utf8_distance}, '5.6.0');
735 ok(exists $p{save_generic_svref});
736 ok($p{save_generic_svref}, '5.005_03');
738 ===============================================================================
740 # check --nofilter option
742 my $o = ppport(qw(--nochanges));
743 ok($o =~ /^Scanning.*foo\.cpp/mi);
744 ok($o =~ /Analyzing.*foo\.cpp/mi);
745 ok(matches($o, '^Scanning', 'm'), 1);
746 ok(matches($o, 'Analyzing', 'm'), 1);
748 $o = ppport(qw(--nochanges foo.cpp foo.o Makefile.PL));
749 ok($o =~ /Skipping the following files \(use --nofilter to avoid this\):/m);
750 ok(matches($o, '^\|\s+foo\.o', 'mi'), 1);
751 ok(matches($o, '^\|\s+Makefile\.PL', 'mi'), 1);
752 ok($o =~ /^Scanning.*foo\.cpp/mi);
753 ok($o =~ /Analyzing.*foo\.cpp/mi);
754 ok(matches($o, '^Scanning', 'm'), 1);
755 ok(matches($o, 'Analyzing', 'm'), 1);
757 $o = ppport(qw(--nochanges --nofilter foo.cpp foo.o Makefile.PL));
758 ok($o =~ /^Scanning.*foo\.cpp/mi);
759 ok($o =~ /Analyzing.*foo\.cpp/mi);
760 ok($o =~ /^Scanning.*foo\.o/mi);
761 ok($o =~ /Analyzing.*foo\.o/mi);
762 ok($o =~ /^Scanning.*Makefile/mi);
763 ok($o =~ /Analyzing.*Makefile/mi);
764 ok(matches($o, '^Scanning', 'm'), 3);
765 ok(matches($o, 'Analyzing', 'm'), 3);
767 ---------------------------- foo.cpp ------------------------------------------
771 ---------------------------- foo.o --------------------------------------------
775 ---------------------------- Makefile.PL --------------------------------------
779 ===============================================================================
781 # check if explicit variables are handled propery
783 my $o = ppport(qw(--copy=a));
784 ok($o =~ /^Needs to include.*ppport\.h/m);
785 ok($o =~ /^Uses PL_signals/m);
786 ok($o =~ /^File needs PL_signals, adding static request/m);
787 ok(eq_files('MyExt.xsa', 'MyExt.ra'));
789 unlink qw(MyExt.xsa);
791 ---------------------------- MyExt.xs -----------------------------------------
794 if (PL_signals == 42)
797 ---------------------------- MyExt.ra -----------------------------------------
799 #define NEED_PL_signals
802 if (PL_signals == 42)