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

################################################################################
##
##  $Revision: 19 $
##  $Author: mhx $
##  $Date: 2004/08/17 22:04:17 +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'}) {
  $inc = '-I../../lib' if -d '../../lib';
}
if ($perl =~ m!^\./!) {
  $perl = ".$perl";
}

END {
  chdir("..") if !-d $tmp && -d "../$tmp";
  rmtree($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	##
96ad942f	3	## $Revision: 19 $
adfe19db	4	## $Author: mhx $
96ad942f	5	## $Date: 2004/08/17 22:04:17 +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'}) {
	32	$inc = '-I../../lib' if -d '../../lib';
	33	}
96ad942f	34	if ($perl =~ m!^\./!) {
	35	$perl = ".$perl";
	36	}
adfe19db	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 = @_;
96ad942f	48	print "# * running $perl $inc ppport.h @args *\n";
96ad942f	49	my $out = join '', `$perl $inc ppport.h @args`;
adfe19db	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
96ad942f	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
adfe19db	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
96ad942f	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