[p5sagit/p5-mst-13.2.git] / ext / Devel / PPPort / parts / inc / ppphtest

################################################################################
##
##  $Revision: 22 $
##  $Author: mhx $
##  $Date: 2004/10/14 20:16:03 +0200 $
##
################################################################################
##
##  Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz.
##  Version 2.x, Copyright (C) 2001, Paul Marquess.
##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
##
##  This program is free software; you can redistribute it and/or
##  modify it under the same terms as Perl itself.
##
################################################################################

=tests plan => 134

use File::Path qw/rmtree mkpath/;
use Config;

my $tmp = 'ppptmp';
my $inc = '';
my $perl = find_perl();

rmtree($tmp) if -d $tmp;
mkpath($tmp) or die "mkpath $tmp: $!\n";
chdir($tmp) or die "chdir $tmp: $!\n";

if ($ENV{'PERL_CORE'}) {
  if (-d '../../lib') {
    $inc = $^O eq 'VMS' ? '-"I../../lib"' : '-I../../lib';
    unshift @INC, '../../lib';
  }
}
if ($perl =~ m!^\./!) {
  $perl = ".$perl";
}

END {
  chdir('..') if !-d $tmp && -d "../$tmp";
  rmtree($tmp) if -d $tmp;
}

ok(&Devel::PPPort::WriteFile("ppport.h"));

sub ppport
{
  my @args = @_;
  print "# *** running $perl $inc ppport.h @args ***\n";
  my $out = join '', `$perl $inc ppport.h @args`;
  my $copy = $out;
  $copy =~ s/^/# | /mg;
  print "$copy\n";
  return $out;
}

sub matches
{
  my($str, $re, $mod) = @_;
  my @n;
  eval "\@n = \$str =~ /$re/g$mod;";
  if ($@) {
    my $err = $@;
    $err =~ s/^/# *** /mg;
    print "# *** ERROR ***\n$err\n";
  }
  return $@ ? -42 : scalar @n;
}

sub eq_files
{
  my($f1, $f2) = @_;
  return 0 unless -e $f1 && -e $f2;
  local *F;
  for ($f1, $f2) {
    print "# File: $_\n";
    unless (open F, $_) {
      print "# couldn't open $_: $!\n";
      return 0;
    }
    $_ = do { local $/; <F> };
    close F;
    my $copy = $_;
    $copy =~ s/^/# | /mg;
    print "$copy\n";
  }
  return $f1 eq $f2;
}

my @tests;

for (split /\s*={70,}\s*/, do { local $/; <DATA> }) {
  s/^\s+//; s/\s+$//;
  my($c, %f);
  ($c, @f{m/-{20,}\s+(\S+)\s+-{20,}/g}) = split /\s*-{20,}\s+\S+\s+-{20,}\s*/;
  push @tests, { code => $c, files => \%f };
}

my $t;
for $t (@tests) {
  my $f;
  for $f (keys %{$t->{files}}) {
    my @f = split /\//, $f;
    if (@f > 1) {
      pop @f;
      my $path = join '/', @f;
      mkpath($path) or die "mkpath('$path'): $!\n";
    }
    my $txt = $t->{files}{$f};
    local *F;
    open F, ">$f" or die "open $f: $!\n";
    print F "$txt\n";
    close F;
    $txt =~ s/^/# | /mg;
    print "# *** writing $f ***\n$txt\n";
  }

  eval $t->{code};
  if ($@) {
    my $err = $@;
    $err =~ s/^/# *** /mg;
    print "# *** ERROR ***\n$err\n";
  }
  ok($@, '');

  for (keys %{$t->{files}}) {
    unlink $_ or die "unlink('$_'): $!\n";
  }
}

sub find_perl
{
  my $perl = $^X;
  
  return $perl if $^O eq 'VMS';
  
  my $exe = $Config{'_exe'} || '';
  
  if ($perl =~ /^perl\Q$exe\E$/i) {
    $perl = "perl$exe";
    eval "require File::Spec";
    if ($@) {
      $perl = "./$perl";
    } else {
      $perl = File::Spec->catfile(File::Spec->curdir(), $perl);
    }
  }
  
  if ($perl !~ /\Q$exe\E$/i) {
    $perl .= $exe;
  }
  
  warn "find_perl: cannot find $perl from $^X" unless -f $perl;
  
  return $perl;
}

__DATA__

my $o = ppport(qw(--help));
ok($o =~ /^Usage:.*ppport\.h/m);
ok($o =~ /--help/m);

$o = ppport(qw(--nochanges));
ok($o =~ /^scanning.*test\.xs/mi);
ok($o =~ /analyzing.*test\.xs/mi);
ok(matches($o, '^scanning', 'mi'), 1);
ok(matches($o, 'analyzing', 'mi'), 1);
ok($o =~ /Uses Perl_newSViv instead of newSViv/);

$o = ppport(qw(--quiet --nochanges));
ok($o =~ /^\s*$/);

---------------------------- test.xs ------------------------------------------

Perl_newSViv();

===============================================================================

# check if C and C++ comments are filtered correctly

my $o = ppport(qw(--copy=a));
ok($o =~ /^scanning.*MyExt\.xs/mi);
ok($o =~ /analyzing.*MyExt\.xs/mi);
ok(matches($o, '^scanning', 'mi'), 1);
ok($o =~ /^Needs to include.*ppport\.h/m);
ok($o !~ /^Uses grok_bin/m);
ok($o !~ /^Uses newSVpv/m);
ok($o =~ /Uses 1 C\+\+ style comment/m);
ok(eq_files('MyExt.xsa', 'MyExt.ra'));

# check if C++ are left untouched with --cplusplus

$o = ppport(qw(--copy=b --cplusplus));
ok($o =~ /^scanning.*MyExt\.xs/mi);
ok($o =~ /analyzing.*MyExt\.xs/mi);
ok(matches($o, '^scanning', 'mi'), 1);
ok($o =~ /^Needs to include.*ppport\.h/m);
ok($o !~ /^Uses grok_bin/m);
ok($o !~ /^Uses newSVpv/m);
ok($o !~ /Uses \d+ C\+\+ style comment/m);
ok(eq_files('MyExt.xsb', 'MyExt.rb'));

unlink qw(MyExt.xsa MyExt.xsb);

---------------------------- MyExt.xs -----------------------------------------
  
newSVuv();
    // newSVpv();
  XPUSHs(foo);
/* grok_bin(); */

---------------------------- MyExt.ra -----------------------------------------
  
#include "ppport.h"
newSVuv();
    /* newSVpv(); */
  XPUSHs(foo);
/* grok_bin(); */

---------------------------- MyExt.rb -----------------------------------------
  
#include "ppport.h"
newSVuv();
    // newSVpv();
  XPUSHs(foo);
/* grok_bin(); */

===============================================================================

my $o = ppport(qw(--nochanges file1.xs));
ok($o =~ /^scanning.*file1\.xs/mi);
ok($o =~ /analyzing.*file1\.xs/mi);
ok($o !~ /^scanning.*file2\.xs/mi);
ok($o =~ /^Uses newCONSTSUB/m);
ok($o =~ /^Uses SvPV_nolen.*depends.*sv_2pv_nolen/m);
ok($o =~ /hint for newCONSTSUB/m);
ok($o !~ /hint for sv_2pv_nolen/m);
ok($o =~ /^Looks good/m);

$o = ppport(qw(--nochanges --nohints file1.xs));
ok($o =~ /^scanning.*file1\.xs/mi);
ok($o =~ /analyzing.*file1\.xs/mi);
ok($o !~ /^scanning.*file2\.xs/mi);
ok($o =~ /^Uses newCONSTSUB/m);
ok($o =~ /^Uses SvPV_nolen.*depends.*sv_2pv_nolen/m);
ok($o !~ /hint for newCONSTSUB/m);
ok($o !~ /hint for sv_2pv_nolen/m);
ok($o =~ /^Looks good/m);

$o = ppport(qw(--nochanges --nohints --nodiag file1.xs));
ok($o =~ /^scanning.*file1\.xs/mi);
ok($o =~ /analyzing.*file1\.xs/mi);
ok($o !~ /^scanning.*file2\.xs/mi);
ok($o !~ /^Uses newCONSTSUB/m);
ok($o !~ /^Uses SvPV_nolen/m);
ok($o !~ /hint for newCONSTSUB/m);
ok($o !~ /hint for sv_2pv_nolen/m);
ok($o =~ /^Looks good/m);

$o = ppport(qw(--nochanges --quiet file1.xs));
ok($o =~ /^\s*$/);

$o = ppport(qw(--nochanges file2.xs));
ok($o =~ /^scanning.*file2\.xs/mi);
ok($o =~ /analyzing.*file2\.xs/mi);
ok($o !~ /^scanning.*file1\.xs/mi);
ok($o =~ /^Uses mXPUSHp/m);
ok($o =~ /^Needs to include.*ppport\.h/m);
ok($o !~ /^Looks good/m);
ok($o =~ /^1 potentially required change detected/m);

$o = ppport(qw(--nochanges --nohints file2.xs));
ok($o =~ /^scanning.*file2\.xs/mi);
ok($o =~ /analyzing.*file2\.xs/mi);
ok($o !~ /^scanning.*file1\.xs/mi);
ok($o =~ /^Uses mXPUSHp/m);
ok($o =~ /^Needs to include.*ppport\.h/m);
ok($o !~ /^Looks good/m);
ok($o =~ /^1 potentially required change detected/m);

$o = ppport(qw(--nochanges --nohints --nodiag file2.xs));
ok($o =~ /^scanning.*file2\.xs/mi);
ok($o =~ /analyzing.*file2\.xs/mi);
ok($o !~ /^scanning.*file1\.xs/mi);
ok($o !~ /^Uses mXPUSHp/m);
ok($o !~ /^Needs to include.*ppport\.h/m);
ok($o !~ /^Looks good/m);
ok($o =~ /^1 potentially required change detected/m);

$o = ppport(qw(--nochanges --quiet file2.xs));
ok($o =~ /^\s*$/);

---------------------------- file1.xs -----------------------------------------

#define NEED_newCONSTSUB
#define NEED_sv_2pv_nolen
#include "ppport.h"

newCONSTSUB();
SvPV_nolen();

---------------------------- file2.xs -----------------------------------------

mXPUSHp(foo);

===============================================================================

my $o = ppport(qw(--nochanges));
ok($o =~ /^scanning.*FooBar\.xs/mi);
ok($o =~ /analyzing.*FooBar\.xs/mi);
ok(matches($o, '^scanning', 'mi'), 1);
ok($o !~ /^Looks good/m);
ok($o =~ /^Uses grok_bin/m);

---------------------------- FooBar.xs ----------------------------------------

newSViv();
XPUSHs(foo);
grok_bin();

===============================================================================

my $o = ppport(qw(--nochanges));
ok($o =~ /^scanning.*First\.xs/mi);
ok($o =~ /analyzing.*First\.xs/mi);
ok($o =~ /^scanning.*second\.h/mi);
ok($o =~ /analyzing.*second\.h/mi);
ok($o =~ /^scanning.*sub.*third\.c/mi);
ok($o =~ /analyzing.*sub.*third\.c/mi);
ok($o !~ /^scanning.*foobar/mi);
ok(matches($o, '^scanning', 'mi'), 3);

---------------------------- First.xs -----------------------------------------

one

---------------------------- foobar.xyz ---------------------------------------

two

---------------------------- second.h -----------------------------------------

three

---------------------------- sub/third.c --------------------------------------

four

===============================================================================

my $o = ppport(qw(--nochanges));
ok($o =~ /Possibly wrong #define NEED_foobar in.*test.xs/i);

---------------------------- test.xs ------------------------------------------

#define NEED_foobar

===============================================================================

# And now some complex "real-world" example

my $o = ppport(qw(--copy=f));
for (qw(main.xs mod1.c mod2.c mod3.c mod4.c mod5.c)) {
  ok($o =~ /^scanning.*\Q$_\E/mi);
  ok($o =~ /analyzing.*\Q$_\E/i);
}
ok(matches($o, '^scanning', 'mi'), 6);

ok(matches($o, '^Writing copy of', 'mi'), 5);
ok(!-e "mod5.cf");

for (qw(main.xs mod1.c mod2.c mod3.c mod4.c)) {
  ok($o =~ /^Writing copy of.*\Q$_\E.*with changes/mi);
  ok(-e "${_}f");
  ok(eq_files("${_}f", "${_}r"));
  unlink "${_}f";
}

---------------------------- main.xs ------------------------------------------

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#define NEED_newCONSTSUB
#define NEED_grok_hex_GLOBAL
#include "ppport.h"

newCONSTSUB();
grok_hex();
Perl_grok_bin(aTHX_ foo, bar);

/* some comment */

perl_eval_pv();
grok_bin();
Perl_grok_bin(bar, sv_no);

---------------------------- mod1.c -------------------------------------------

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#define NEED_grok_bin_GLOBAL
#define NEED_newCONSTSUB
#include "ppport.h"

newCONSTSUB();
grok_bin();
{
  Perl_croak ("foo");
  Perl_sv_catpvf();  /* I know it's wrong ;-) */
}

---------------------------- mod2.c -------------------------------------------

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#define NEED_eval_pv
#include "ppport.h"

newSViv();

/*
   eval_pv();
*/

---------------------------- mod3.c -------------------------------------------

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

grok_oct();
eval_pv();

---------------------------- mod4.c -------------------------------------------

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

START_MY_CXT;

---------------------------- mod5.c -------------------------------------------

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include "ppport.h"
call_pv();

---------------------------- main.xsr -----------------------------------------

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#define NEED_eval_pv_GLOBAL
#define NEED_grok_hex
#define NEED_newCONSTSUB_GLOBAL
#include "ppport.h"

newCONSTSUB();
grok_hex();
grok_bin(foo, bar);

/* some comment */

eval_pv();
grok_bin();
grok_bin(bar, PL_sv_no);

---------------------------- mod1.cr ------------------------------------------

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#define NEED_grok_bin_GLOBAL
#include "ppport.h"

newCONSTSUB();
grok_bin();
{
  Perl_croak (aTHX_ "foo");
  Perl_sv_catpvf(aTHX);  /* I know it's wrong ;-) */
}

---------------------------- mod2.cr ------------------------------------------

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"


newSViv();

/*
   eval_pv();
*/

---------------------------- mod3.cr ------------------------------------------

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#define NEED_grok_oct
#include "ppport.h"

grok_oct();
eval_pv();

---------------------------- mod4.cr ------------------------------------------

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"

START_MY_CXT;

===============================================================================

my $o = ppport(qw(--nochanges));
ok($o =~ /Uses grok_hex/m);
ok($o !~ /Looks good/m);

$o = ppport(qw(--nochanges --compat-version=5.8.0));
ok($o !~ /Uses grok_hex/m);
ok($o =~ /Looks good/m);

---------------------------- FooBar.xs ----------------------------------------

grok_hex();

===============================================================================

my $o = ppport(qw(--nochanges));
ok($o =~ /Uses SvPVutf8_force, which may not be portable/m);

$o = ppport(qw(--nochanges --compat-version=5.6.0));
ok($o !~ /Uses SvPVutf8_force/m);

---------------------------- FooBar.xs ----------------------------------------

SvPVutf8_force();

===============================================================================

my $o = ppport(qw(--nochanges));
ok($o !~ /potentially required change/);
ok(matches($o, '^Looks good', 'mi'), 2);

---------------------------- FooBar.xs ----------------------------------------

#define NEED_grok_numeric_radix
#define NEED_grok_number
#include "ppport.h"

GROK_NUMERIC_RADIX();
grok_number();

---------------------------- foo.c --------------------------------------------

#include "ppport.h"

call_pv();
Commit	Line	Data
adfe19db	1	################################################################################
adfe19db	2	##
04fc8b94	3	## $Revision: 22 $
adfe19db	4	## $Author: mhx $
04fc8b94	5	## $Date: 2004/10/14 20:16:03 +0200 $
adfe19db	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
96ad942f	18	=tests plan => 134
adfe19db	19
adfe19db	20	use File::Path qw/rmtree mkpath/;
96ad942f	21	use Config;
adfe19db	22
adfe19db	23	my $tmp = 'ppptmp';
96ad942f	24	my $inc = '';
96ad942f	25	my $perl = find_perl();
adfe19db	26
	27	rmtree($tmp) if -d $tmp;
	28	mkpath($tmp) or die "mkpath $tmp: $!\n";
	29	chdir($tmp) or die "chdir $tmp: $!\n";
	30
adfe19db	31	if ($ENV{'PERL_CORE'}) {
87499469	32	if (-d '../../lib') {
d8d9a455	33	$inc = $^O eq 'VMS' ? '-"I../../lib"' : '-I../../lib';
87499469	34	unshift @INC, '../../lib';
87499469	35	}
adfe19db	36	}
96ad942f	37	if ($perl =~ m!^\./!) {
	38	$perl = ".$perl";
	39	}
adfe19db	40
adfe19db	41	END {
cd266515	42	chdir('..') if !-d $tmp && -d "../$tmp";
cd266515	43	rmtree($tmp) if -d $tmp;
adfe19db	44	}
	45
	46	ok(&Devel::PPPort::WriteFile("ppport.h"));
	47
	48	sub ppport
	49	{
	50	my @args = @_;
96ad942f	51	print "# * running $perl $inc ppport.h @args *\n";
96ad942f	52	my $out = join '', `$perl $inc ppport.h @args`;
adfe19db	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
96ad942f	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
adfe19db	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
96ad942f	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