AI-Pathfinding-AStar-Rectangle
view release on metacpan or search on metacpan
Benchmark/perl-vs-xs.pl view on Meta::CPAN
use constant WIDTH_X => 64;
use constant WIDTH_Y => 64;
my @map;
use AI::Pathfinding::AStar::Rectangle;
my $m = AI::Pathfinding::AStar::Rectangle->new({ width => WIDTH_X, heigth => WIDTH_Y });
for my $x (0 .. WIDTH_X - 1 )
{
for my $y (0 .. WIDTH_Y - 1 )
{
$map[$x][$y] = 1;
}
}
$map[5][$_] = 0 for 5 .. WIDTH_Y - 5;
$map[WIDTH_X - 5][$_] = 0 for 5 .. WIDTH_Y - 5;
$map[$_][5] = 0 for 5 .. WIDTH_X - 5;
$map[$_][WIDTH_Y - 5] = 0 for 5 .. WIDTH_X - 10;
$map[$_][10] = 0 for 10 .. WIDTH_X - 10;
$map[WIDTH_X - 10][$_] = 0 for 10 .. WIDTH_Y - 5;
$map[10][$_] = 0 for 10 .. WIDTH_Y - 10;
$map[$_][WIDTH_Y - 10] = 0 for 10 .. WIDTH_X - 15;
$map[WIDTH_X - 15][$_] = 0 for 15 .. WIDTH_Y - 10;
$map[$_][15] = 0 for 15 .. WIDTH_X - 15;
for my $x (0 .. WIDTH_X - 1 )
{
for my $y (0 .. WIDTH_Y - 1 )
{
$m->set_passability($x, $y, $map[$x][$y]) ;
}
}
my ( $x_start, $y_start ) = ( WIDTH_X >> 1, WIDTH_Y >> 1 );
my ( $x_end, $y_end ) = ( 0, 0 );
my $t0 = [gettimeofday];
my $path;
my $r = timethese( -1, {Perl=>sub { astar( $x_start, $y_start, $x_end, $y_end ) },
XS=>sub {$m->astar($x_start, $y_start, $x_end, $y_end);}});
cmpthese($r);
die;
for (0..99) {
$path = &astar( $x_start, $y_start, $x_end, $y_end );
}
print "Elapsed: ".tv_interval ( $t0 )."\n";
print "Path length: ".length($path)."\n";
# start end points
$map[ $x_start ][ $y_start ] = 3;
$map[ $x_end ][ $y_end ] = 4;
# draw path
my %vect = (
# x y
1 => [-1, 1, '|/'],
2 => [ 0, 1, '.|'],
3 => [ 1, 1, '|\\'],
4 => [-1, 0, '|<'],
6 => [ 1, 0, '|>'],
7 => [-1,-1, '|\\'],
8 => [ 0,-1, '\'|'],
9 => [ 1,-1, '|/']
);
my ( $x, $y ) = ( $x_start, $y_start );
for ( split //, $path )
{
$map[$x][$y] = '|o';
$x += $vect{$_}->[0];
$y += $vect{$_}->[1];
$map[$x][$y] = '|o';
}
printf "%02d", $_ for 0 .. WIDTH_X - 1;
print "\n";
for my $y ( 0 .. WIDTH_Y - 1 )
{
for my $x ( 0 .. WIDTH_X - 1 )
{
print $map[$x][$y] eq
'1' ? "|_" : (
$map[$x][$y] eq '0' ? "|#" : (
$map[$x][$y] eq '3' ? "|S" : (
$map[$x][$y] eq '4' ? "|E" : $map[$x][$y] ) ) );
}
print "$y\n";
}
sub astar
{
my ( $xs, $ys, $xe, $ye ) = @_;
my %close;
my ( %open, @g, @h, @r, @open_idx );
for my $x (0 .. WIDTH_X - 1 )
{
for my $y (0 .. WIDTH_Y - 1 )
{
$g[$x][$y] = 0;
$r[$x][$y] = 0;
$h[$x][$y] = 0;
}
}
my %cost = (
"0.-1" => 5, #|.
"1.-1" => 7, #/.
"1.0" => 5, #.-
"1.1" => 7, #`\
"0.1" => 5, #`|
"-1.1" => 7, #
"-1.0" => 5,
"-1.-1" => 7
);
my $it = 0;
my $oindx = 0;
my ( $x, $y ) = ( $xs, $ys );
while ( $x != $xe || $y != $ye )
{
$close{$x}{$y} = 1;
$open{$x}{$y} = 0;
for ( "0.-1", "-1.1", "0.1", "1.1", "-1.0", "1.-1", "1.0", "-1.-1" )
{
my ( $xd, $yd ) = split /\./, $_;
my ( $xn, $yn ) = ( $x + $xd, $y + $yd );
next if $xn == WIDTH_X ||
$xn < 0 ||
$yn == WIDTH_Y ||
$yn < 0 ||
$close{$xn}{$yn} ||
$map[$xn][$yn] == 0;
my $ng = $g[$x][$y] + $cost{$_};
if ( $open{$xn}{$yn} )
{
if ( $ng < $g[$xn][$yn] )
{
$r[$xn][$yn] = [$x,$y];
$g[$xn][$yn] = $ng;
}
}
else
{
$open{$xn}{$yn} = 1;
$g[$xn][$yn] = $ng;
my ( $xa, $ya ) = ( abs( $xn - $xe ), abs( $yn - $ye ) );
$h[$xn][$yn] = #( $xa > $ya ? $xa : $ya ) * 7;
( abs( $xn - $xe ) + abs( $yn - $ye ) ) * 7;
$r[$xn][$yn] = [$x,$y];
push @open_idx, [$xn, $yn, \$g[$xn][$yn], \$h[$xn][$yn]];
}
# deb($x, $y, $xn, $yn, \@g);
}
@open_idx = sort { ${$a->[2]} + ${$a->[3]} <=> ${$b->[2]} + ${$b->[3]} } @open_idx;
( $x, $y ) = @{ shift @open_idx };
$it++;
}
# print "Iterations: $it: $oindx\n";
my $path = "";
my %idx2path =
(
"0.-1" => 8, #|.
"1.-1" => 9, #/.
"1.0" => 6, #.-
"1.1" => 3, #`\
"0.1" => 2, #`|
"-1.1" => 1, #
"-1.0" => 4,
"-1.-1" => 7
);
while ( $x != $xs || $y != $ys )
{
# print "$x:$y\n";
my ($xp, $yp) = @{$r[$x][$y]};
$path = $idx2path{($x-$xp).".".($y-$yp)}.$path;
( $x, $y ) = ( $xp, $yp);
}
# print "Path: $path\n";
return $path;
}
sub calc_obstacle
{
my ( $x1, $y1, $x2, $y2 ) = @_;
my ( $x, $y, $Xend, $obstacle, $pixel);
my $dx = abs($x2 - $x1);
my $dy = abs($y2 - $y1);
my $d = ( $dy << 1 ) - $dx;
my $inc1 = $dy << 1;
my $inc2 = ($dy - $dx) << 1;
if ( $x1 > $x2)
{
$x = $x2;
$y = $y2;
$Xend = $x1;
}
else
{
$x = $x1;
$y = $y1;
$Xend = $x2;
};
$obstacle+=!$map[$x][$y];
$pixel+=5;
while ( $x < $Xend )
{
$x++;
if ($d < 0) {$d += $inc1}
else
{
$y++;
$d += $inc2;
};
$obstacle+=!$map[$x][$y];
$pixel += 5;
};
return ( $obstacle << 3 ) + $pixel;
}
sub deb
{
my ( $x, $y, $xn, $yn, $g) = @_;
for my $j ( 0 .. WIDTH_Y - 1 )
{
for my $i ( 0 .. WIDTH_X - 1 )
{
if ( !$map[$i][$j] )
{
print " ##"
}
else
{
if ( $x == $i && $y == $j)
{
print "c";
}
elsif ( $xn == $i && $yn == $j )
{
print "n";
}
else
{
print " ";
}
printf "%02d", $g->[$i]->[$j]
}
}
print "\n";
}
<>;
}
Revision history for Perl extension AI::Pathfinding::AStar::Rectangle.
0.01 Wed Apr 1 13:54:05 2009
- original version; created by h2xs 1.23 with options
-A -n AI::Pathfinding::AStar::Rectangle
0.02 Wed Apr 1 13:54:05 2009
- Some bugfixes
0.16 September 25 23:34 2010
- foreach_xy foreach_xy_set implemented in PP.
- added clone.
- added test for this functions
0.17 September 26 14:34 2010
- begin_x, end_x, last_x, last_y
- added typemap.
- added test 06 for this functions
- remove some duplicated code
0.18 September 26 15:24 2010
- added clone_rect for selection rectangle
0.19 September 28 05:35 2010
- added test for dastar algorithm
- Some doc fix
0.20 September 28 06:10 2010
- Get rid of some warnings && MSVS compiler staff( inline )
0.21 September 28 06:10 2010
- Some perl 5.8.8 are bad. ( Create own croak_xs_usage )
0.22 October 3 21:10 2010
- Some perl 5.8.8 are still bad. ( next try )
- remove some other warnings
0.23 October 12 21:10 2010
- Makefile.PL && LICENSE
--- #YAML:1.0
name: AI-Pathfinding-AStar-Rectangle
version: 0.23
abstract: AStar algorithm on rectangle map
author:
- A.G. Grishaev <gtoly@cpan.org>
license: perl
distribution_type: module
configure_requires:
ExtUtils::MakeMaker: 0
build_requires:
ExtUtils::MakeMaker: 0
requires:
perl: 5.008001
no_index:
directory:
- t
- inc
generated_by: ExtUtils::MakeMaker version 6.56
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
Makefile.PL view on Meta::CPAN
use ExtUtils::MakeMaker;
use constant { MIN_PERL_VERSION => 5.008001 };
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.
unless ($] >= MIN_PERL_VERSION ){
warn " this perl version not supported $] ";
exit;
}
WriteMakefile(
NAME => 'AI::Pathfinding::AStar::Rectangle',
VERSION_FROM => 'lib/AI/Pathfinding/AStar/Rectangle.pm', # finds $VERSION
PREREQ_PM => {}, # e.g., Module::Name => 1.1
ABSTRACT_FROM => 'lib/AI/Pathfinding/AStar/Rectangle.pm', # retrieve abstract from module
AUTHOR => 'A.G. Grishaev <gtoly@cpan.org>' ,
LIBS => [''], # e.g., '-lm'
DEFINE => '', # e.g., '-DHAVE_SOMETHING'
INC => '-I.', # e.g., '-I. -I/usr/include/other'
$ExtUtils::MakeMaker::VERSION >= 6.48 ? (MIN_PERL_VERSION => MIN_PERL_VERSION) : (),
$ExtUtils::MakeMaker::VERSION >= 6.31 ? ( LICENSE => 'perl') : (),
# Un-comment this if you add C files to link with later:
# OBJECT => '$(O_FILES)', # link all the C files too
);
A README file is required for CPAN modules since CPAN extracts the
README file from a module distribution so that people browsing the
archive can use it get an idea of the modules uses. It is usually a
good idea to provide version information here so that people can
decide whether fixes for the module are worth downloading.
INSTALLATION
To install this module type the following:
perl Makefile.PL
make
make test
make install
DEPENDENCIES
This module requires these other modules and libraries:
blah blah blah
COPYRIGHT AND LICENCE
Put the correct copyright and licence information here.
Copyright (C) 2009 by A.G. Grishaev
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.0 or,
at your option, any later version of Perl 5 you may have available.
Rectangle.xs view on Meta::CPAN
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"
#define cxinc() Perl_cxinc(aTHX)
#define ARRAY_SIZE(x) (sizeof(x)/sizeof(x[0]))
#ifdef _MSC_VER
#define inline
#endif
inline bool is_hash(SV *x){
return SvTYPE(x) == SVt_PVHV;
}
struct map_item{
int g;
int h;
int k;
char prev;
char open;
char closed;
char reserved[1];
};
struct map_like{
unsigned int width;
unsigned int height;
signed int start_x;
signed int start_y;
signed int current_x;
signed int current_y;
unsigned char map[];
};
#ifndef PERL_UNUSED_VAR
# define PERL_UNUSED_VAR(var) if (0) var = var
#endif
#ifndef croak_xs_usage
#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
/* prototype to pass -Wmissing-prototypes */
STATIC void
M_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
STATIC void
M_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
{
const GV *const gv = CvGV(cv);
PERL_ARGS_ASSERT_CROAK_XS_USAGE;
if (gv) {
const char *const gvname = GvNAME(gv);
const HV *const stash = GvSTASH(gv);
const char *const hvname = stash ? HvNAME(stash) : NULL;
if (hvname)
Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
else
Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
} else {
/* Pants. I don't think that it should be possible to get here. */
Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
}
}
#endif
#ifdef PERL_IMPLICIT_CONTEXT
#define croak_xs_usage(a,b) M_croak_xs_usage(aTHX_ a,b)
#else
#define croak_xs_usage M_croak_xs_usage
#endif
#endif
Rectangle.xs view on Meta::CPAN
#ifdef XMULTICALL
void
foreach_xy(self, block)
SV * self;
SV * block;
PROTOTYPE: $&
CODE:
{
dVAR; dMULTICALL;
pmap newmap;
int x,y;
GV *agv,*bgv,*gv;
HV *stash;
I32 gimme = G_VOID;
SV **args = &PL_stack_base[ax];
SV *x1, *y1, *value;
AV *argv;
CV *cv;
if (!sv_isobject(self))
croak("Need object");
newmap = (pmap) SvPV_nolen(SvRV(self));
cv = sv_2cv(block, &stash, &gv, 0);
agv = gv_fetchpv("a", TRUE, SVt_PV);
bgv = gv_fetchpv("b", TRUE, SVt_PV);
SAVESPTR(GvSV(agv));
SAVESPTR(GvSV(bgv));
SAVESPTR(GvSV(PL_defgv));
x1 = sv_newmortal();
y1 = sv_newmortal();
SAVESPTR(GvAV(PL_defgv));
if (0){
argv = newAV();
av_push(argv, newSViv(10));
av_push(argv, newSViv(20));
sv_2mortal((SV*) argv);
GvAV(PL_defgv) = argv;
}
value = sv_newmortal();
GvSV(agv) = x1;
GvSV(bgv) = y1;
GvSV(PL_defgv) = value;
PUSH_MULTICALL(cv);
if (items>2){
for(y =newmap->height-1 ; y>=0; --y){
for (x = 0; x < newmap->width; ++x){
sv_setiv(x1,x + newmap->start_x);
sv_setiv(y1,y + newmap->start_y);
sv_setiv(value, newmap->map[get_offset_abs(newmap, x,y)]);
MULTICALL;
}
}
}
else {
for(y =0; y< newmap->height; ++y){
for (x = 0; x < newmap->width; ++x){
sv_setiv(x1,x + newmap->start_x);
sv_setiv(y1,y + newmap->start_y);
sv_setiv(value, newmap->map[get_offset_abs(newmap, x,y)]);
MULTICALL;
}
}
}
POP_MULTICALL;
XSRETURN_EMPTY;
}
void
foreach_xy_set (self, block)
SV * self;
SV * block;
PROTOTYPE: $&
CODE:
{
dVAR; dMULTICALL;
pmap newmap;
int x,y;
GV *agv,*bgv,*gv;
HV *stash;
I32 gimme = G_VOID;
SV **args = &PL_stack_base[ax];
SV *x1, *y1, *value;
CV *cv;
if (!sv_isobject(self))
croak("Need object");
newmap = (pmap) SvPV_nolen(SvRV(self));
cv = sv_2cv(block, &stash, &gv, 0);
agv = gv_fetchpv("a", TRUE, SVt_PV);
bgv = gv_fetchpv("b", TRUE, SVt_PV);
SAVESPTR(GvSV(agv));
SAVESPTR(GvSV(bgv));
SAVESPTR(GvSV(PL_defgv));
x1 = sv_newmortal();
y1 = sv_newmortal();
value = sv_newmortal();
GvSV(agv) = x1;
GvSV(bgv) = y1;
GvSV(PL_defgv) = value;
PUSH_MULTICALL(cv);
for(y =0; y< newmap->height; ++y){
for (x = 0; x < newmap->width; ++x){
sv_setiv(x1,x + newmap->start_x);
sv_setiv(y1,y + newmap->start_y);
sv_setiv(value, newmap->map[get_offset_abs(newmap, x,y)]);
MULTICALL;
newmap->map[get_offset_abs(newmap, x, y)] = SvIV(*PL_stack_sp);
}
}
POP_MULTICALL;
XSRETURN_EMPTY;
}
#endif
typedef struct map_like * pmap;
static int path_weigths[10]={50,14,10,14,10,50,10,14,10,14};
bool check_options(pmap map, HV *opts){
SV ** item;
if (!hv_exists(opts, "width", 5))
return 0;
if (!hv_exists(opts, "height", 6))
return 0;
item = hv_fetch(opts, "width", 5, 0);
map->width = SvIV(*item);
item = hv_fetch(opts, "height", 6, 0);
map->height = SvIV(*item);
return 1;
}
void
inline init_move_offset(pmap map, int * const moves, int trim){
const int dx = 1;
const int dy = map->width + 2;
moves[0] = 0;
moves[5] = 0;
moves[1] = -dx + dy;
moves[2] = + dy;
moves[3] = +dx + dy;
moves[4] = -dx ;
moves[6] = +dx ;
moves[7] = -dx - dy;
moves[8] = - dy;
moves[9] = +dx - dy;
if (trim){
moves[0] = moves[8];
moves[5] = moves[9];
}
}
bool
inline on_the_map(pmap newmap, int x, int y){
if (x< newmap->start_x ||y< newmap->start_y ){
return 0;
}
else if (x - newmap->start_x >= (int )newmap->width || y - newmap->start_y >= (int)newmap->height){
return 0;
}
return 1;
}
int
inline get_offset(pmap newmap, int x, int y){
return ( (y - newmap->start_y + 1)*(newmap->width+2) + (x-newmap->start_x+1));
}
int
inline get_offset_abs(pmap newmap, int x, int y){
return ( (y + 1)*(newmap->width+2) + (x + 1));
}
void
inline get_xy(pmap newmap, int offset, int *x,int *y){
*x = offset % ( newmap->width + 2) + newmap->start_x - 1;
*y = offset / ( newmap->width + 2) + newmap->start_y - 1;
}
MODULE = AI::Pathfinding::AStar::Rectangle PACKAGE = AI::Pathfinding::AStar::Rectangle
void
clone(pmap self)
PREINIT:
SV *string;
SV *clone;
PPCODE:
string = SvRV(ST(0));
clone = sv_newmortal();
sv_setsv( clone, string );
clone = newRV_inc( clone );
sv_bless( clone, SvSTASH( string ));
XPUSHs( sv_2mortal(clone));
void
clone_rect(pmap self, IV begin_x, IV begin_y, IV end_x, IV end_y)
PREINIT:
SV *clone;
struct map_like re_map;
pmap newmap;
size_t map_size;
PPCODE:
if (!on_the_map( self, begin_x, begin_y ))
croak_xs_usage( cv, "left corner of rectangle is out of the map" );
if (!on_the_map( self, end_x, end_y ))
croak_xs_usage( cv, "rigth corner of rectangle is out of the map" );
if ( ! ( begin_x <= end_x ))
croak_xs_usage( cv, "attemp made to make zero width rectangle" );
if ( ! ( begin_y <= end_y ))
croak_xs_usage( cv, "attemp made to make zero height rectangle" );
clone = sv_newmortal();
sv_setpvn( clone, "", 0 );
re_map.width = end_x - begin_x + 1;
re_map.height = end_y - begin_y + 1;
map_size = sizeof(struct map_like)+(re_map.width + 2) * (re_map.height+2) *sizeof( char );
SvGROW( clone, map_size );
/* Initializing */
newmap = (pmap) SvPV_nolen( clone );
Zero(newmap, map_size, char);
newmap->width = re_map.width;
newmap->height = re_map.height;
newmap->start_x = begin_x;
newmap->start_y = begin_y;
SvCUR_set(clone, map_size);
/*Copy passability */
if (1) {
int x, y;
for ( x = begin_x; x <= end_x ; ++x ){
for ( y = begin_y; y <= end_y; ++y ){
newmap->map[ get_offset( newmap, x, y )]=
self->map[ get_offset( self, x, y )];
}
}
};
/*Prepare for return full object */
clone = newRV_inc( clone );
sv_bless( clone, SvSTASH( SvRV(ST(0) )));
XPUSHs( sv_2mortal(clone));
void
new(self, options)
SV * self;
SV * options;
INIT:
SV * object;
struct map_like re_map;
pmap newmap;
size_t map_size;
SV *RETVALUE;
PPCODE:
if (!(SvROK(options) && (is_hash(SvRV(options))))){
croak("Not hashref: USAGE: new( {width=>10, height=>20})");
}
if (!check_options(&re_map, (HV *) SvRV(options))){
croak("Not enough params: USAGE: new( {width=>10, height=>20})");
croak("Fail found mandatory param");
}
object = sv_2mortal(newSVpvn("",0));
SvGROW(object, map_size = sizeof(struct map_like)+(re_map.width + 2) * (re_map.height+2));
newmap = (pmap) SvPV_nolen(object);
Zero(newmap, map_size, char);
newmap->width = re_map.width;
newmap->height = re_map.height;
SvCUR_set(object, map_size);
RETVALUE = sv_2mortal( newRV_inc(object ));
sv_bless(RETVALUE, gv_stashpv( SvPV_nolen( self ), GV_ADD));
XPUSHs(RETVALUE);
void
start_x(pmap self, int newpos_x = 0 )
PPCODE:
if (items>1){
self->start_x = newpos_x;
XPUSHs(ST(0));
}
else {
mXPUSHi(self->start_x);
};
void
start_y(pmap self, int newpos_y = 0 )
PPCODE:
if (items>1){
self->start_y = newpos_y;
XPUSHs(ST(0));
}
else {
mXPUSHi(self->start_y);
}
void
width(pmap newmap)
PPCODE:
XPUSHs(sv_2mortal(newSViv(newmap->width)));
void
height(pmap newmap)
PPCODE:
mXPUSHi(newmap->height);
void
begin_y( pmap self )
PPCODE:
mXPUSHi(self->start_y);
void
end_y( pmap self )
PPCODE:
mXPUSHi(self->start_y + (signed) self->height -1) ;
void
begin_x( pmap self )
PPCODE:
mXPUSHi( self->start_x );
void
end_x( pmap self )
PPCODE:
mXPUSHi( self->start_x + (signed) self->width -1 );
void
last_x(pmap self)
PPCODE:
mXPUSHi(self->start_x + (signed)self->width -1);
void
last_y(pmap newmap)
PPCODE:
mXPUSHi(newmap->start_y + (signed)newmap->height-1);
void
set_start_xy(pmap self, x, y)
int x;
int y;
PPCODE:
//PerlIO_stdoutf("start(x,y) = (%d,%d)\n", x, y);
self->start_x = x;
self->start_y = y;
//PerlIO_stdoutf("start(x,y) = (%d,%d)\n", self->width, self->height);
XPUSHs( ST(0) );
void
get_passability(self, x, y)
SV * self;
int x;
int y;
INIT:
pmap newmap;
PPCODE:
if (!sv_isobject(self))
croak("Need object");
newmap = (pmap) SvPV_nolen(SvRV(self));
if ( ! on_the_map( newmap, x, y )){
XPUSHs(&PL_sv_no);
}
else {
int offset = ( (y - newmap->start_y + 1)*(newmap->width+2) + (x-newmap->start_x+1));
XPUSHs( sv_2mortal(newSViv( newmap->map[offset])));
}
void
set_passability(self, x, y, value)
pmap self;
int x;
int y;
int value;
PPCODE:
if ( ! on_the_map( self, x, y )){
warn("x=%d,y=%d outside map", x, y);
XPUSHs(&PL_sv_no);
}
else {
int offset = ( (y - self->start_y + 1)*(self->width+2) + (x-self->start_x+1));
self->map[offset] = value;
};
void
path_goto(self, x, y, path)
SV * self;
int x;
int y;
char *path;
INIT:
pmap newmap;
char * position;
int moves[10];
int gimme;
int offset;
int weigth;
PPCODE:
if (!sv_isobject(self))
croak("Need object");
newmap = (pmap) SvPV_nolen(SvRV(self));
offset = ( (y - newmap->start_y + 1)*(newmap->width+2) + (x-newmap->start_x+1));
init_move_offset(newmap, moves, 0);
position = path;
weigth = 0;
while(*position){
if (*position < '0' || *position>'9'){
goto last_op;
};
offset+= moves[ *position - '0'];
weigth+= path_weigths[ *position - '0' ];
++position;
};
gimme = GIMME_V;
if (gimme == G_ARRAY){
int x,y;
int norm;
norm = offset ;
x = norm % ( newmap->width + 2) + newmap->start_x - 1;
y = norm / ( newmap->width + 2) + newmap->start_y - 1;
mXPUSHi(x);
mXPUSHi(y);
mXPUSHi(weigth);
};
last_op:;
void
draw_path_xy( pmap newmap, int x, int y, char *path, int value )
PREINIT:
char *position;
int moves[10];
PPCODE:
if ( !on_the_map(newmap, x, y) ){
croak("start is outside the map");
}
else {
int offset = get_offset(newmap, x, y);
const int max_offset = get_offset_abs( newmap, newmap->width, newmap->height);
const int min_offset = get_offset_abs( newmap, 0, 0);
init_move_offset(newmap, moves,0);
newmap->map[offset] = value;
position = path;
while(*position){
if (*position < '0' || *position>'9'){
croak("bad path: illegal symbols");
};
offset+= moves[ *position - '0'];
if (offset > max_offset || offset < min_offset ||
offset % (int)(newmap->width + 2) == 0 ||
offset % (int)(newmap->width + 2) == (int) newmap->width + 1 ){
croak("path otside map");
}
newmap->map[offset] = value;
++position;
}
get_xy(newmap, offset, &x, &y);
mXPUSHi(x);
mXPUSHi(y);
}
void
is_path_valid(self, x, y, path)
SV * self;
int x;
int y;
char *path;
INIT:
pmap newmap;
char * position;
int moves[10];
int gimme;
PPCODE:
if (!sv_isobject(self))
croak("Need object");
newmap = (pmap) SvPV_nolen(SvRV(self));
if ( ! on_the_map( newmap, x, y )){
XPUSHs(&PL_sv_no);
}
else {
int offset = ( (y - newmap->start_y + 1)*(newmap->width+2) + (x-newmap->start_x+1));
int weigth = 0;
init_move_offset(newmap, moves,0);
position = path;
while(*position){
if (*position < '0' || *position>'9'){
XPUSHs(&PL_sv_no);
goto last_op;
};
offset+= moves[ *position - '0'];
if (! newmap->map[offset] ){
XPUSHs(&PL_sv_no);
goto last_op;
}
weigth+= path_weigths[ *position - '0' ];
++position;
}
// fprintf( stderr, "ok");
gimme = GIMME_V;
if (gimme == G_ARRAY){
int x,y;
int norm;
norm = offset ;
x = norm % ( newmap->width + 2) + newmap->start_x - 1;
y = norm / ( newmap->width + 2) + newmap->start_y - 1;
mXPUSHi(x);
mXPUSHi(y);
mXPUSHi(weigth);
}
XPUSHs(&PL_sv_yes);
}
last_op:;
void
dastar( self, from_x, from_y, to_x, to_y )
int from_x;
int from_y;
int to_x;
int to_y;
SV* self;
INIT:
pmap newmap;
int moves[10];
struct map_item *layout;
int current, end_offset, start_offset;
int *opens;
int opens_start;
int opens_end;
static U8 path_char[8]={'8','1','2','3','4','9','6','7'};
static int weigths[8] ={10,14,10,14,10,14,10,14};
int iter_num;
int finish[5];
int map_size;
PPCODE:
if (!sv_isobject(self))
croak("Need object");
newmap = (pmap) SvPV_nolen(SvRV(self));
if (!on_the_map(newmap, from_x, from_y) || !on_the_map(newmap, to_x, to_y)){
XPUSHs(&PL_sv_no);
goto last_op;
}
if (! newmap->map[get_offset(newmap, from_x, from_y)]
|| ! newmap->map[get_offset(newmap, to_x, to_y)]){
XPUSHs(&PL_sv_no);
goto last_op;
}
start_offset = get_offset(newmap, from_x, from_y);
end_offset = get_offset(newmap, to_x, to_y);
if (start_offset == end_offset){
XPUSHs(&PL_sv_no);
XPUSHs(&PL_sv_yes);
goto last_op;
}
map_size= (2+newmap->width) * (2+newmap->height);
Newxz(layout, map_size, struct map_item);
Newx(opens, map_size, int);
init_move_offset(newmap, moves, 1);
opens_start = 0;
opens_end = 0;
iter_num = 0;
current = start_offset;
layout[current].g = 0;
finish[0] = end_offset;
finish[1] = end_offset+1;
finish[2] = end_offset-1;
finish[3] = end_offset+newmap->width+2;
finish[4] = end_offset-newmap->width-2;
while( current != end_offset){
int i;
int g;
if ( 0
|| current == finish[1]
|| current == finish[2]
|| current == finish[3]
|| current == finish[4])
break;
layout[current].open = 0;
layout[current].closed = 1;
for(i=1; i<8; i+=2){
int nextpoint = current + moves[i];
if ( layout[nextpoint].closed || newmap->map[nextpoint] == 0 )
continue;
g = weigths[i] + layout[current].g;
if (layout[nextpoint].open ){
if (g < layout[nextpoint].g){
// int g0;
// g0 = layout[nextpoint].g;
layout[nextpoint].g = g;
layout[nextpoint].k = layout[nextpoint].h + g ;
layout[nextpoint].prev = i;
}
}
else {
int x, y;
int h;
int abs_dx;
int abs_dy;
get_xy(newmap, nextpoint, &x, &y);
layout[nextpoint].open = 1;
abs_dx = abs( x-to_x );
abs_dy = abs( y-to_y );
// layout[nextpoint].h = h = ( abs_dx + abs_dy )*14;
h = ( abs_dx + abs_dy )*10; // Manheton
#h = 10 * ((abs_dx> abs_dy)? abs_dx: abs_dy);
layout[nextpoint].h = h ;
// layout[nextpoint].h = h = (abs( x - to_x ) + abs(y -to_y))*14;
layout[nextpoint].g = g;
layout[nextpoint].k = g + h;
layout[nextpoint].prev = i;
opens[opens_end++] = nextpoint;
}
}
if (opens_start >= opens_end){
XPUSHs(&PL_sv_no);
goto free_allocated;
}
else {
int index;
int min_k;
index = opens_start;
min_k = layout[opens[opens_start]].k ; // + layout[opens[opens_start]].h;
for (i = opens_start+1; i<opens_end; ++i){
int k = layout[opens[i]].k ; // + layout[opens[i]].h;
if (min_k> k){
min_k = k;
index = i;
}
}
current = opens[index];
opens[index] = opens[opens_start];
++opens_start;
iter_num++;
}
}
{
STRLEN i;
SV* path;
U8 *path_pv;
STRLEN path_len;
path = sv_2mortal(newSVpvn("",0));
//
// 1
while(current != start_offset){
STRLEN i = layout[current].prev;
sv_catpvn_nomg(path, (char *) &path_char[i], (STRLEN) 1);
current -= moves[i];
};
// 2
// 3
//
path_pv = (U8*)SvPV( path, path_len);
for(i=0; i<path_len/2; ++i){
U8 x;
x = path_pv[path_len-i-1];
path_pv[path_len - i - 1] = path_pv[i];
path_pv[ i ] = x;
}
if (GIMME_V == G_ARRAY){
XPUSHs(path);
XPUSHs(&PL_sv_yes);
}
else {
XPUSHs(path);
}
}
free_allocated:;
(void) Safefree(opens);
(void) Safefree(layout);
last_op:; // last resort Can't use return
void
astar( self, from_x, from_y, to_x, to_y )
int from_x;
int from_y;
int to_x;
int to_y;
SV* self;
INIT:
pmap newmap;
int moves[10];
struct map_item *layout;
int current, end_offset, start_offset;
int *opens;
int opens_start;
int opens_end;
static U8 path_char[8]={'8','1','2','3','4','9','6','7'};
static int weigths[8] ={10,14,10,14,10,14,10,14};
int iter_num;
int index;
int map_size;
PPCODE:
if (!sv_isobject(self))
croak("Need object");
newmap = (pmap) SvPV_nolen(SvRV(self));
if (!on_the_map(newmap, from_x, from_y) || !on_the_map(newmap, to_x, to_y)){
XPUSHs(&PL_sv_no);
goto last_op;
}
if (! newmap->map[get_offset(newmap, from_x, from_y)]
|| ! newmap->map[get_offset(newmap, to_x, to_y)]){
XPUSHs(&PL_sv_no);
goto last_op;
}
start_offset = get_offset(newmap, from_x, from_y);
end_offset = get_offset(newmap, to_x, to_y);
if (start_offset == end_offset){
XPUSHs(&PL_sv_no);
XPUSHs(&PL_sv_yes);
goto last_op;
}
map_size = (2+newmap->width) * (2+newmap->height);
Newxz(layout, map_size, struct map_item);
Newx(opens, map_size, int);
init_move_offset(newmap, moves, 1);
opens_start = 0;
opens_end = 0;
iter_num = 0;
current = start_offset;
layout[current].g = 0;
while( current != end_offset){
int i;
layout[current].open = 0;
layout[current].closed = 1;
for(i=0; i<8; ++i){
int nextpoint = current + moves[i];
int g;
if ( layout[nextpoint].closed || newmap->map[nextpoint] == 0 )
continue;
g = weigths[i] + layout[current].g;
if (layout[nextpoint].open ){
if (g < layout[nextpoint].g){
// int g0;
// g0 = layout[nextpoint].g;
layout[nextpoint].g = g;
layout[nextpoint].k = layout[nextpoint].h + g ;
layout[nextpoint].prev = i;
}
}
else {
int x, y;
int h;
int abs_dx;
int abs_dy;
get_xy(newmap, nextpoint, &x, &y);
layout[nextpoint].open = 1;
abs_dx = abs( x-to_x );
abs_dy = abs( y-to_y );
// layout[nextpoint].h = h = ( abs_dx + abs_dy )*14;
h = ( abs_dx + abs_dy )*10; // Manheton
#h = 10 * ((abs_dx> abs_dy)? abs_dx: abs_dy);
layout[nextpoint].h = h ;
// layout[nextpoint].h = h = (abs( x - to_x ) + abs(y -to_y))*14;
layout[nextpoint].g = g;
layout[nextpoint].k = g + h;
layout[nextpoint].prev = i;
opens[opens_end++] = nextpoint;
}
}
if (opens_start >= opens_end){
XPUSHs(&PL_sv_no);
goto free_allocated;
};
if (0) {
int min_f;
index = opens_start;
min_f = layout[opens[opens_start]].g + layout[opens[opens_start]].h;
for (i = opens_start+1; i<opens_end; ++i){
int f = layout[opens[i]].g + layout[opens[i]].h;
if (min_f> f){
min_f = f;
index = i;
}
}
}
else {
int min_k;
index = opens_start;
min_k = layout[opens[opens_start]].k ; // + layout[opens[opens_start]].h;
for (i = opens_start+1; i<opens_end; ++i){
int k = layout[opens[i]].k ; // + layout[opens[i]].h;
if (min_k> k){
min_k = k;
index = i;
}
}
}
current = opens[index];
opens[index] = opens[opens_start];
++opens_start;
iter_num++;
}
{
STRLEN i;
SV* path;
U8 *path_pv;
STRLEN path_len;
path = sv_2mortal(newSVpvn("",0));
while(current != start_offset){
STRLEN i = layout[current].prev;
sv_catpvn_nomg(path, (char *)&path_char[i], (STRLEN)1);
current -= moves[i];
};
path_pv = (U8*)SvPV( path, path_len);
for(i=0; i<path_len/2; ++i){
U8 x;
x = path_pv[path_len-i-1];
path_pv[path_len - i - 1] = path_pv[i];
path_pv[ i ] = x;
}
if (GIMME_V == G_ARRAY){
XPUSHs(path);
XPUSHs(&PL_sv_yes);
}
else {
XPUSHs(path);
}
}
free_allocated:;
(void) Safefree(opens);
(void) Safefree(layout);
last_op:; // last resort Can't use return
examples/snake_labirint.pl view on Meta::CPAN
#~ $m->foreach_xy_set( sub { $a < 12 && 1<$b && $b <9 } );
#~ $m->draw_path( 5, 5, '1666666888' );
#~ exit;
my @from = (0,0);
my @to = (WIDTH_X >> 1, WIDTH_Y >> 1);
my @map;
{
# Generate map
for my $x (0 .. WIDTH_X - 1 )
{
for my $y (0 .. WIDTH_Y - 1 )
{
$map[$x][$y] = 1;
}
}
$map[5][$_] = 0 for 5 .. WIDTH_Y - 5;
$map[WIDTH_X - 5][$_] = 0 for 5 .. WIDTH_Y - 5;
$map[$_][5] = 0 for 5 .. WIDTH_X - 5;
$map[$_][WIDTH_Y - 5] = 0 for 5 .. WIDTH_X - 10;
$map[$_][10] = 0 for 10 .. WIDTH_X - 10;
$map[WIDTH_X - 10][$_] = 0 for 10 .. WIDTH_Y - 5;
$map[10][$_] = 0 for 10 .. WIDTH_Y - 10;
$map[$_][WIDTH_Y - 10] = 0 for 10 .. WIDTH_X - 15;
$map[WIDTH_X - 15][$_] = 0 for 15 .. WIDTH_Y - 10;
$map[$_][15] = 0 for 15 .. WIDTH_X - 15;
}
# copy map to map object
$m->foreach_xy_set( sub { $map[$a][$b] });
my ($path) = $m->astar(@to, @from);
sub swap(\@\@){
@_[0,1] = @_[1,0];;
}
#swap(@to, @from);
$m->draw_path(@to, $path);
lib/AI/Pathfinding/AStar/Rectangle.pm view on Meta::CPAN
our @ISA = qw(Exporter);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
# This allows declaration use AI::Pathfinding::AStar::Rectangle ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(create_map
) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw(
);
our $VERSION = '0.23';
require XSLoader;
XSLoader::load('AI::Pathfinding::AStar::Rectangle', $VERSION);
# Preloaded methods go here.
sub foreach_xy{
my $self = shift;
my $sub = shift;
no strict 'refs';
local *a= *{ caller() . '::a' };
local *b= *{ caller() . '::b' };
local ($a, $b );
local $_;
for $a ( $self->start_x .. $self->last_x ){
for $b ( $self->start_y .. $self->last_y ){
$_ = $self->get_passability( $a, $b );
&$sub();
}
};
}
sub foreach_xy_set{
my $self = shift;
my $sub = shift;
no strict 'refs';
local *a= *{ caller() . '::a' };
local *b= *{ caller() . '::b' };
local ($a, $b );
local $_;
for $a ( $self->start_x .. $self->last_x ){
for $b ( $self->start_y .. $self->last_y ){
$_ = $self->get_passability( $a, $b );
$self->set_passability( $a, $b, (scalar &$sub()) );
};
};
}
sub create_map($){
unshift @_, __PACKAGE__;
goto &new;
}
1 for ($a, $b); #suppress warnings
sub set_passability_string{
my $self = shift;
my $passability = shift;
die "Bad passabilitity param for set_passability_string" unless $self->width * $self->height == length( $passability );
$self->foreach_xy_set( sub { substr $passability, 0, 1, '' } );
}
sub get_passability_string{
my $self = shift;
my $buf = '';
$self->foreach_xy( sub { $buf.= chr( $_)} );
return $buf;
}
sub draw_path{
my $map = shift;
my ($x, $y) = splice @_, 0, 2;
my $path = shift;
my @map;
$map->foreach_xy( sub {$map[$a][$b]= $_} );
# draw path
my %vect = (
# x y
1 => [-1, 1, ],
2 => [ 0, 1, '.|'],
3 => [ 1, 1, '|\\'],
4 => [-1, 0, '|<'],
6 => [ 1, 0, '|>'],
7 => [-1,-1, '|\\'],
8 => [ 0,-1, '\'|'],
9 => [ 1,-1, '|/']
);
my @path = split //, $path;
print "Steps: ".scalar(@path)."\n";
for ( @path )
{
$map[$x][$y] = '|o';
$x += $vect{$_}->[0];
$y -= $vect{$_}->[1];
$map[$x][$y] = '|o';
}
printf "%02d", $_ for 0 .. $map->last_x;
print "\n";
for my $y ( 0 .. $map->last_y - 1 )
{
for my $x ( 0 .. $map->last_x - 1 )
{
print $map[$x][$y] eq
'1' ? "|_" : (
$map[$x][$y] eq '0' ? "|#" : (
$map[$x][$y] eq '3' ? "|S" : (
$map[$x][$y] eq '4' ? "|E" : $map[$x][$y] ) ) );
}
print "$y\n";
}
}
1;
__END__
=head1 NAME
AI::Pathfinding::AStar::Rectangle - AStar algorithm on rectangle map
=head1 SYNOPSIS
use AI::Pathfinding::AStar::Rectangle qw(create_map);
my $map = create_map({height=>10, width=>10});
#
# -or-
#
# $map = AI::Pathfinding::AStar::Rectangle->new({{height=>10, width=>10});
for my $x ($map->start_x..$map->last_x){
for my $y ($map->start_y..$map->last_y){
$map->set_passability($x, $y, $A[$x][$y]) # 1 - Can pass througth , 0 - Can't pass
}
}
my $path = $map->astar( $from_x, $from_y, $to_x, $to_y);
print $path, "\n"; # print path in presentation of "12346789" like keys at keyboard
=head1 DESCRIPTION
AI::Pathfinding::AStar::Rectangle provide abstraction for Rectangle map with AStar algoritm
=head1 OBJECT METHODS
=over 4
lib/AI/Pathfinding/AStar/Rectangle.pm view on Meta::CPAN
return path like "1234..9"
where
1 - mean go left-down
2 - down
3 - down-right
...
9 - right-up
=item dastar( from_x, from_y, to_x, to_y)
Return diagonal path with AI
=item width()
Get map width
=item height()
Get map height
=item start_x(), start_y()
lib/AI/Pathfinding/AStar/Rectangle.pm view on Meta::CPAN
=item foreach_xy( BLOCK )
Call BLOCK for every point on map.
$map->foreach_xy( sub { $A[$a][$b] = $_ })
($a, $b, $_) (x, y, passability)
=item foreach_xy_set( sub { $A[$a][$b] });
set passability for every point at map.
BLOCK must return passability for point ($a, $b);
$a and $b must be global var not declared as my, our,
=item is_path_valid( start_x, start_y, path)
Check if path is valid path, all points from ( start_x, start_y ) to path end is passable
In list context return ( end_x, end_y, weigth, true or false )
=item path_goto( start_x, start_y, path)
In list context return
( end_x, end_y, weigth )
weight is sum of <diagonal (1379)> * 14 + <short path> * 10
=item draw_path( start_x, start_y, path)
print path to STDOUT
#!/usr/bin/perl
#
my $m = AI::Pathfinding::AStar::Rectangle->new({ width => 16, height => 8 });
$m->foreach_xy_set( sub { $a < 12 && 1<$b && $b <9 } );
$m->draw_path( 5, 5, '1666666888' );
Result:
# Steps: 10
# 00010203040506070809101112131415
# |#|#|#|#|#|#|#|#|#|#|#|#|#|#|#0
# |#|#|#|#|#|#|#|#|#|#|#|#|#|#|#1
# |_|_|_|_|_|_|_|_|_|_|_|_|#|#|#2
# |_|_|_|_|_|_|_|_|_|_|_|_|#|#|#3
# |_|_|_|_|o|o|o|o|o|o|o|_|#|#|#4
# |_|_|_|_|_|o|_|_|_|_|o|_|#|#|#5
#if 0
<<'SKIP';
#endif
/*
----------------------------------------------------------------------
ppport.h -- Perl/Pollution/Portability Version 3.19
Automatically created by Devel::PPPort running under perl 5.008008.
Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
includes in parts/inc/ instead.
Use 'perldoc ppport.h' to view the documentation below.
----------------------------------------------------------------------
SKIP
=pod
=head1 NAME
ppport.h - Perl/Pollution/Portability version 3.19
=head1 SYNOPSIS
perl ppport.h [options] [source files]
Searches current directory for files if no [source files] are given
--help show short help
--version show version
--patch=file write one patch file with changes
--copy=suffix write changed copies with suffix
--diff=program use diff program and options
--compat-version=version provide compatibility with Perl version
--cplusplus accept C++ comments
--quiet don't output anything except fatal errors
--nodiag don't show diagnostics
--nohints don't show hints
--nochanges don't suggest changes
--nofilter don't filter input files
--strip strip all script and doc functionality from
ppport.h
--list-provided list provided API
--list-unsupported list unsupported API
--api-info=name show Perl API portability information
=head1 COMPATIBILITY
This version of F<ppport.h> is designed to support operation with Perl
installations back to 5.003, and has been tested up to 5.10.0.
=head1 OPTIONS
=head2 --help
across differing versions of Perl itself, certain steps need to be taken.
=over 4
=item *
Including this header is the first major one. This alone will give you
access to a large part of the Perl API that hasn't been available in
earlier Perl releases. Use
perl ppport.h --list-provided
to see which API elements are provided by ppport.h.
=item *
You should avoid using deprecated parts of the API. For example, using
global Perl variables without the C<PL_> prefix is deprecated. Also,
some API functions used to have a C<perl_> prefix. Using this form is
also deprecated. You can safely use the supported API, as F<ppport.h>
will provide wrappers for older Perl versions.
These functions or variables will be marked C<explicit> in the list shown
by C<--list-provided>.
Depending on whether you module has a single or multiple files that
use such functions or variables, you want either C<static> or global
variants.
For a C<static> function or variable (used only in a single source
file), use:
#define NEED_function
#define NEED_variable
For a global function or variable (used in multiple source files),
use:
#define NEED_function_GLOBAL
#define NEED_variable_GLOBAL
Note that you mustn't have more than one global request for the
same function or variable in your project.
Function / Variable Static Request Global Request
-----------------------------------------------------------------------------------------
PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL
PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL
eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL
grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL
grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL
grok_number() NEED_grok_number NEED_grok_number_GLOBAL
grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL
grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL
load_module() NEED_load_module NEED_load_module_GLOBAL
my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL
my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL
my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL
my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL
newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL
newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL
newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL
newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL
pv_display() NEED_pv_display NEED_pv_display_GLOBAL
pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL
pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL
sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL
sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL
sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL
sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL
sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL
sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL
sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL
vload_module() NEED_vload_module NEED_vload_module_GLOBAL
vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL
warner() NEED_warner NEED_warner_GLOBAL
To avoid namespace conflicts, you can change the namespace of the
explicitly exported functions / variables using the C<DPPP_NAMESPACE>
macro. Just C<#define> the macro before including C<ppport.h>:
#define DPPP_NAMESPACE MyOwnNamespace_
#include "ppport.h"
The default namespace is C<DPPP_>.
=back
The good thing is that most of the above can be checked by running
F<ppport.h> on your source code. See the next section for
details.
=head1 EXAMPLES
To verify whether F<ppport.h> is needed for your module, whether you
should make any changes to your code, and whether any special defines
should be used, F<ppport.h> can be run as a Perl script to check your
source code. Simply say:
perl ppport.h
The result will usually be a list of patches suggesting changes
that should at least be acceptable, if not necessarily the most
efficient solution, or a fix for all possible problems.
If you know that your XS module uses features only available in
newer Perl releases, if you're aware that it uses C++ comments,
and if you want all suggestions as a single patch file, you could
use something like this:
perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff
If you only want your code to be scanned without any suggestions
for changes, use:
perl ppport.h --nochanges
You can specify a different C<diff> program or options, using
the C<--diff> option:
perl ppport.h --diff='diff -C 10'
This would output context diffs with 10 lines of context.
If you want to create patched copies of your files instead, use:
perl ppport.h --copy=.new
To display portability information for the C<newSVpvn> function,
use:
perl ppport.h --api-info=newSVpvn
Since the argument to C<--api-info> can be a regular expression,
you can use
perl ppport.h --api-info=/_nomg$/
to display portability information for all C<_nomg> functions or
perl ppport.h --api-info=/./
to display information for all known API elements.
=head1 BUGS
If this version of F<ppport.h> is causing failure during
the compilation of this module, please check if newer versions
of either this module or C<Devel::PPPort> are available on CPAN
before sending a bug report.
=cut
use strict;
# Disable broken TRIE-optimization
BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 }
my $VERSION = 3.19;
my %opt = (
quiet => 0,
diag => 1,
hints => 1,
changes => 1,
cplusplus => 0,
filter => 1,
strip => 0,
version => 0,
);
my($ppport) = $0 =~ /([\w.]+)$/;
my $LF = '(?:\r\n|[\r\n])'; # line feed
my $HS = "[ \t]"; # horizontal whitespace
# Never use C comments in this file!
my $ccs = '/'.'*';
my $cce = '*'.'/';
my $rccs = quotemeta $ccs;
my $rcce = quotemeta $cce;
eval {
require Getopt::Long;
Getopt::Long::GetOptions(\%opt, qw(
help quiet diag! filter! hints! changes! cplusplus strip version
patch=s copy=s diff=s compat-version=s
list-provided list-unsupported api-info=s
)) or usage();
};
if ($@ and grep /^-/, @ARGV) {
usage() if "@ARGV" =~ /^--?h(?:elp)?$/;
die "Getopt::Long not found. Please don't use any options.\n";
}
if ($opt{version}) {
print "This is $0 $VERSION.\n";
exit 0;
}
usage() if $opt{help};
strip() if $opt{strip};
if (exists $opt{'compat-version'}) {
my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) };
if ($@) {
die "Invalid version number format: '$opt{'compat-version'}'\n";
}
die "Only Perl 5 is supported\n" if $r != 5;
die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000;
$opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s;
}
else {
$opt{'compat-version'} = 5;
}
my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/
? ( $1 => {
($2 ? ( base => $2 ) : ()),
($3 ? ( todo => $3 ) : ()),
(index($4, 'v') >= 0 ? ( varargs => 1 ) : ()),
(index($4, 'p') >= 0 ? ( provided => 1 ) : ()),
(index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()),
} )
: die "invalid spec: $_" } qw(
AvFILLp|5.004050||p
AvFILL|||
CLASS|||n
CPERLscope|5.005000||p
CX_CURPAD_SAVE|||
CX_CURPAD_SV|||
CopFILEAV|5.006000||p
CopFILEGV_set|5.006000||p
CopFILEGV|5.006000||p
CopFILESV|5.006000||p
xmldump_packsubs|||
xmldump_sub|||
xmldump_vindent|||
yyerror|||
yylex|||
yyparse|||
yywarn|||
);
if (exists $opt{'list-unsupported'}) {
my $f;
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $API{$f}{todo};
print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
}
exit 0;
}
# Scan for possible replacement candidates
my(%replace, %need, %hints, %warnings, %depends);
my $replace = 0;
my($hint, $define, $function);
sub find_api
{
my $code = shift;
$code =~ s{
/ (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
| "[^"\\]*(?:\\.[^"\\]*)*"
| '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx;
grep { exists $API{$_} } $code =~ /(\w+)/mg;
}
while (<DATA>) {
if ($hint) {
my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings;
if (m{^\s*\*\s(.*?)\s*$}) {
for (@{$hint->[1]}) {
$h->{$_} ||= ''; # suppress warning with older perls
$h->{$_} .= "$1\n";
}
}
else { undef $hint }
}
$hint = [$1, [split /,?\s+/, $2]]
if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$};
if ($define) {
if ($define->[1] =~ /\\$/) {
$define->[1] .= $_;
}
else {
if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) {
my @n = find_api($define->[1]);
push @{$depends{$define->[0]}}, @n if @n
}
undef $define;
}
}
$define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)};
if ($function) {
if (/^}/) {
if (exists $API{$function->[0]}) {
my @n = find_api($function->[1]);
push @{$depends{$function->[0]}}, @n if @n
}
undef $function;
}
else {
$function->[1] .= $_;
}
}
$function = [$1, ''] if m{^DPPP_\(my_(\w+)\)};
$replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$};
$replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
$replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce};
$replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$};
if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) {
my @deps = map { s/\s+//g; $_ } split /,/, $3;
my $d;
for $d (map { s/\s+//g; $_ } split /,/, $1) {
push @{$depends{$d}}, @deps;
}
}
$need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
}
for (values %depends) {
my %s;
$_ = [sort grep !$s{$_}++, @$_];
}
if (exists $opt{'api-info'}) {
my $f;
my $count = 0;
my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$";
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $f =~ /$match/;
print "\n=== $f ===\n\n";
my $info = 0;
if ($API{$f}{base} || $API{$f}{todo}) {
my $base = format_version($API{$f}{base} || $API{$f}{todo});
print "Supported at least starting from perl-$base.\n";
$info++;
}
if ($API{$f}{provided}) {
my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003";
print "Support by $ppport provided back to perl-$todo.\n";
print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f};
print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f};
print "\n$hints{$f}" if exists $hints{$f};
print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f};
$info++;
}
print "No portability information available.\n" unless $info;
$count++;
}
$count or print "Found no API matching '$opt{'api-info'}'.";
print "\n";
exit 0;
}
if (exists $opt{'list-provided'}) {
my $f;
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $API{$f}{provided};
my @flags;
push @flags, 'explicit' if exists $need{$f};
push @flags, 'depend' if exists $depends{$f};
push @flags, 'hint' if exists $hints{$f};
push @flags, 'warning' if exists $warnings{$f};
my $flags = @flags ? ' ['.join(', ', @flags).']' : '';
print "$f$flags\n";
}
exit 0;
}
my @files;
my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc );
my $srcext = join '|', map { quotemeta $_ } @srcext;
if (@ARGV) {
my %seen;
for (@ARGV) {
if (-e) {
if (-f) {
push @files, $_ unless $seen{$_}++;
}
else { warn "'$_' is not a file.\n" }
}
else {
my @new = grep { -f } glob $_
or warn "'$_' does not exist.\n";
push @files, grep { !$seen{$_}++ } @new;
}
}
}
else {
eval {
require File::Find;
File::Find::find(sub {
$File::Find::name =~ /($srcext)$/i
and push @files, $File::Find::name;
}, '.');
};
if ($@) {
@files = map { glob "*$_" } @srcext;
}
}
if (!@ARGV || $opt{filter}) {
my(@in, @out);
my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files;
for (@files) {
my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i;
push @{ $out ? \@out : \@in }, $_;
}
if (@ARGV && @out) {
warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out);
}
@files = @in;
}
die "No input files given!\n" unless @files;
my(%files, %global, %revreplace);
%revreplace = reverse %replace;
my $filename;
my $patch_opened = 0;
for $filename (@files) {
unless (open IN, "<$filename") {
warn "Unable to read from $filename: $!\n";
next;
}
info("Scanning $filename ...");
my $c = do { local $/; <IN> };
close IN;
my %file = (orig => $c, changes => 0);
# Temporarily remove C/XS comments and strings from the code
my @ccom;
$c =~ s{
( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]*
| ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* )
| ( ^$HS*\#[^\r\n]*
| "[^"\\]*(?:\\.[^"\\]*)*"
| '[^'\\]*(?:\\.[^'\\]*)*'
| / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) )
}{ defined $2 and push @ccom, $2;
defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex;
$file{ccom} = \@ccom;
$file{code} = $c;
$file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m;
my $func;
for $func (keys %API) {
my $match = $func;
$match .= "|$revreplace{$func}" if exists $revreplace{$func};
if ($c =~ /\b(?:Perl_)?($match)\b/) {
$file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func};
$file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/;
if (exists $API{$func}{provided}) {
$file{uses_provided}{$func}++;
if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) {
$file{uses}{$func}++;
my @deps = rec_depend($func);
if (@deps) {
$file{uses_deps}{$func} = \@deps;
for (@deps) {
$file{uses}{$_} = 0 unless exists $file{uses}{$_};
}
}
for ($func, @deps) {
$file{needs}{$_} = 'static' if exists $need{$_};
}
}
}
if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) {
if ($c =~ /\b$func\b/) {
$file{uses_todo}{$func}++;
}
}
}
}
while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) {
if (exists $need{$2}) {
$file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++;
}
else { warning("Possibly wrong #define $1 in $filename") }
}
for (qw(uses needs uses_todo needed_global needed_static)) {
for $func (keys %{$file{$_}}) {
push @{$global{$_}{$func}}, $filename;
}
}
$files{$filename} = \%file;
}
# Globally resolve NEED_'s
my $need;
for $need (keys %{$global{needs}}) {
if (@{$global{needs}{$need}} > 1) {
my @targets = @{$global{needs}{$need}};
my @t = grep $files{$_}{needed_global}{$need}, @targets;
@targets = @t if @t;
@t = grep /\.xs$/i, @targets;
@targets = @t if @t;
my $target = shift @targets;
$files{$target}{needs}{$need} = 'global';
for (@{$global{needs}{$need}}) {
$files{$_}{needs}{$need} = 'extern' if $_ ne $target;
}
}
}
for $filename (@files) {
exists $files{$filename} or next;
info("=== Analyzing $filename ===");
my %file = %{$files{$filename}};
my $func;
my $c = $file{code};
my $warnings = 0;
for $func (sort keys %{$file{uses_Perl}}) {
if ($API{$func}{varargs}) {
unless ($API{$func}{nothxarg}) {
my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))}
{ $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge);
if ($changes) {
warning("Doesn't pass interpreter argument aTHX to Perl_$func");
$file{changes} += $changes;
}
}
}
else {
warning("Uses Perl_$func instead of $func");
$file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*}
{$func$1(}g);
}
}
for $func (sort keys %{$file{uses_replace}}) {
warning("Uses $func instead of $replace{$func}");
$file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
}
for $func (sort keys %{$file{uses_provided}}) {
if ($file{uses}{$func}) {
if (exists $file{uses_deps}{$func}) {
diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}}));
}
else {
diag("Uses $func");
}
}
$warnings += hint($func);
}
unless ($opt{quiet}) {
for $func (sort keys %{$file{uses_todo}}) {
print "*** WARNING: Uses $func, which may not be portable below perl ",
format_version($API{$func}{todo}), ", even with '$ppport'\n";
$warnings++;
}
}
for $func (sort keys %{$file{needed_static}}) {
my $message = '';
if (not exists $file{uses}{$func}) {
$message = "No need to define NEED_$func if $func is never used";
}
elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') {
$message = "No need to define NEED_$func when already needed globally";
}
if ($message) {
diag($message);
$file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg);
}
}
for $func (sort keys %{$file{needed_global}}) {
my $message = '';
if (not exists $global{uses}{$func}) {
$message = "No need to define NEED_${func}_GLOBAL if $func is never used";
}
elsif (exists $file{needs}{$func}) {
if ($file{needs}{$func} eq 'extern') {
$message = "No need to define NEED_${func}_GLOBAL when already needed globally";
}
elsif ($file{needs}{$func} eq 'static') {
$message = "No need to define NEED_${func}_GLOBAL when only used in this file";
}
}
if ($message) {
diag($message);
$file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg);
}
}
$file{needs_inc_ppport} = keys %{$file{uses}};
if ($file{needs_inc_ppport}) {
my $pp = '';
for $func (sort keys %{$file{needs}}) {
my $type = $file{needs}{$func};
next if $type eq 'extern';
my $suffix = $type eq 'global' ? '_GLOBAL' : '';
unless (exists $file{"needed_$type"}{$func}) {
if ($type eq 'global') {
diag("Files [@{$global{needs}{$func}}] need $func, adding global request");
}
else {
diag("File needs $func, adding static request");
}
$pp .= "#define NEED_$func$suffix\n";
}
}
if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) {
$pp = '';
$file{changes}++;
}
unless ($file{has_inc_ppport}) {
diag("Needs to include '$ppport'");
$pp .= qq(#include "$ppport"\n)
}
if ($pp) {
$file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms)
|| ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m)
|| ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m)
|| ($c =~ s/^/$pp/);
}
}
else {
if ($file{has_inc_ppport}) {
diag("No need to include '$ppport'");
$file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m);
}
}
# put back in our C comments
my $ix;
my $cppc = 0;
my @ccom = @{$file{ccom}};
for $ix (0 .. $#ccom) {
if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) {
$cppc++;
$file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/;
}
else {
$c =~ s/$rccs$ix$rcce/$ccom[$ix]/;
}
}
if ($cppc) {
my $s = $cppc != 1 ? 's' : '';
warning("Uses $cppc C++ style comment$s, which is not portable");
}
my $s = $warnings != 1 ? 's' : '';
my $warn = $warnings ? " ($warnings warning$s)" : '';
info("Analysis completed$warn");
if ($file{changes}) {
if (exists $opt{copy}) {
my $newfile = "$filename$opt{copy}";
if (-e $newfile) {
error("'$newfile' already exists, refusing to write copy of '$filename'");
}
else {
local *F;
if (open F, ">$newfile") {
info("Writing copy of '$filename' with changes to '$newfile'");
print F $c;
close F;
}
else {
error("Cannot open '$newfile' for writing: $!");
}
}
}
elsif (exists $opt{patch} || $opt{changes}) {
if (exists $opt{patch}) {
unless ($patch_opened) {
if (open PATCH, ">$opt{patch}") {
$patch_opened = 1;
}
else {
error("Cannot open '$opt{patch}' for writing: $!");
delete $opt{patch};
$opt{changes} = 1;
goto fallback;
}
}
mydiff(\*PATCH, $filename, $c);
}
else {
fallback:
info("Suggested changes:");
mydiff(\*STDOUT, $filename, $c);
}
}
else {
my $s = $file{changes} == 1 ? '' : 's';
info("$file{changes} potentially required change$s detected");
}
}
else {
info("Looks good");
}
}
close PATCH if $patch_opened;
exit 0;
sub try_use { eval "use @_;"; return $@ eq '' }
sub mydiff
{
local *F = shift;
my($file, $str) = @_;
my $diff;
if (exists $opt{diff}) {
$diff = run_diff($opt{diff}, $file, $str);
}
if (!defined $diff and try_use('Text::Diff')) {
$diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' });
$diff = <<HEADER . $diff;
--- $file
+++ $file.patched
HEADER
}
if (!defined $diff) {
$diff = run_diff('diff -u', $file, $str);
}
if (!defined $diff) {
$diff = run_diff('diff', $file, $str);
}
if (!defined $diff) {
error("Cannot generate a diff. Please install Text::Diff or use --copy.");
return;
}
print F $diff;
}
sub run_diff
{
my($prog, $file, $str) = @_;
my $tmp = 'dppptemp';
my $suf = 'aaa';
my $diff = '';
local *F;
while (-e "$tmp.$suf") { $suf++ }
$tmp = "$tmp.$suf";
if (open F, ">$tmp") {
print F $str;
close F;
if (open F, "$prog $file $tmp |") {
while (<F>) {
s/\Q$tmp\E/$file.patched/;
$diff .= $_;
}
close F;
unlink $tmp;
return $diff;
}
unlink $tmp;
}
else {
error("Cannot open '$tmp' for writing: $!");
}
return undef;
}
sub rec_depend
{
my($func, $seen) = @_;
return () unless exists $depends{$func};
$seen = {%{$seen||{}}};
return () if $seen->{$func}++;
my %s;
grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}};
}
sub parse_version
{
my $ver = shift;
if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
return ($1, $2, $3);
}
elsif ($ver !~ /^\d+\.[\d_]+$/) {
die "cannot parse version '$ver'\n";
}
$ver =~ s/_//g;
$ver =~ s/$/000000/;
my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
$v = int $v;
$s = int $s;
if ($r < 5 || ($r == 5 && $v < 6)) {
if ($s % 10) {
die "cannot parse version '$ver'\n";
}
}
return ($r, $v, $s);
}
sub format_version
{
my $ver = shift;
$ver =~ s/$/000000/;
my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
$v = int $v;
$s = int $s;
if ($r < 5 || ($r == 5 && $v < 6)) {
if ($s % 10) {
die "invalid version '$ver'\n";
}
$s /= 10;
$ver = sprintf "%d.%03d", $r, $v;
$s > 0 and $ver .= sprintf "_%02d", $s;
return $ver;
}
return sprintf "%d.%d.%d", $r, $v, $s;
}
sub info
{
$opt{quiet} and return;
print @_, "\n";
}
sub diag
{
$opt{quiet} and return;
$opt{diag} and print @_, "\n";
}
sub warning
{
$opt{quiet} and return;
print "*** ", @_, "\n";
}
sub error
{
print "*** ERROR: ", @_, "\n";
}
my %given_hints;
my %given_warnings;
sub hint
{
$opt{quiet} and return;
my $func = shift;
my $rv = 0;
if (exists $warnings{$func} && !$given_warnings{$func}++) {
my $warn = $warnings{$func};
$warn =~ s!^!*** !mg;
print "*** WARNING: $func\n", $warn;
$rv++;
}
if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) {
my $hint = $hints{$func};
$hint =~ s/^/ /mg;
print " --- hint for $func ---\n", $hint;
}
$rv;
}
sub usage
{
my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
my %M = ( 'I' => '*' );
$usage =~ s/^\s*perl\s+\S+/$^X $0/;
$usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
print <<ENDUSAGE;
Usage: $usage
See perldoc $0 for details.
ENDUSAGE
exit 2;
}
sub strip
{
my $self = do { local(@ARGV,$/)=($0); <> };
my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms;
$copy =~ s/^(?=\S+)/ /gms;
$self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms;
$self =~ s/^SKIP.*(?=^__DATA__)/SKIP
if (\@ARGV && \$ARGV[0] eq '--unstrip') {
eval { require Devel::PPPort };
\$@ and die "Cannot require Devel::PPPort, please install.\\n";
if (eval \$Devel::PPPort::VERSION < $VERSION) {
die "$0 was originally generated with Devel::PPPort $VERSION.\\n"
. "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n"
. "Please install a newer version, or --unstrip will not work.\\n";
}
Devel::PPPort::WriteFile(\$0);
exit 0;
}
print <<END;
Sorry, but this is a stripped version of \$0.
To be able to use its original script and doc functionality,
please try to regenerate this file using:
\$^X \$0 --unstrip
END
/ms;
my($pl, $c) = $self =~ /(.*^__DATA__)(.*)/ms;
$c =~ s{
/ (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
| ( "[^"\\]*(?:\\.[^"\\]*)*"
| '[^'\\]*(?:\\.[^'\\]*)*' )
| ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex;
$c =~ s!\s+$!!mg;
$c =~ s!^$LF!!mg;
$c =~ s!^\s*#\s*!#!mg;
$c =~ s!^\s+!!mg;
open OUT, ">$0" or die "cannot strip $0: $!\n";
print OUT "$pl$c\n";
exit 0;
}
__DATA__
*/
#ifndef _P_P_PORTABILITY_H_
#define _P_P_PORTABILITY_H_
#ifndef DPPP_NAMESPACE
# define DPPP_NAMESPACE DPPP_
#ifndef PERL_REVISION
# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION))
# define PERL_PATCHLEVEL_H_IMPLICIT
# include <patchlevel.h>
# endif
# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL)))
# include <could_not_find_Perl_patchlevel.h>
# endif
# ifndef PERL_REVISION
# define PERL_REVISION (5)
/* Replace: 1 */
# define PERL_VERSION PATCHLEVEL
# define PERL_SUBVERSION SUBVERSION
/* Replace PERL_PATCHLEVEL with PERL_VERSION */
/* Replace: 0 */
# endif
#endif
#define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10))
#define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION))
/* It is very unlikely that anyone will try to use this with Perl 6
(or greater), but who knows.
*/
#if PERL_REVISION != 5
# error ppport.h only works with Perl version 5
#endif /* PERL_REVISION != 5 */
#ifndef dTHR
# define dTHR dNOOP
#endif
#ifndef dTHX
# define dTHX dNOOP
#endif
#endif
#ifndef UVTYPE
# define UVTYPE unsigned IVTYPE
#endif
#ifndef UVSIZE
# define UVSIZE IVSIZE
#endif
#ifndef sv_setuv
# define sv_setuv(sv, uv) \
STMT_START { \
UV TeMpUv = uv; \
if (TeMpUv <= IV_MAX) \
sv_setiv(sv, TeMpUv); \
else \
sv_setnv(sv, (double)TeMpUv); \
} STMT_END
#endif
#ifndef newSVuv
# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv))
#endif
#ifndef sv_2uv
# define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv)))
#endif
#ifndef SvUVX
# define SvUVX(sv) ((UV)SvIVX(sv))
#ifndef SvUV
# define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
#endif
#ifndef SvUVx
# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv))
#endif
/* Hint: sv_uv
* Always use the SvUVx() macro instead of sv_uv().
*/
#ifndef sv_uv
# define sv_uv(sv) SvUVx(sv)
#endif
#if !defined(SvUOK) && defined(SvIOK_UV)
# define SvUOK(sv) SvIOK_UV(sv)
#endif
#ifndef XST_mUV
# define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) )
#endif
/* Older perls (<=5.003) lack AvFILLp */
#ifndef AvFILLp
# define AvFILLp AvFILL
#endif
#ifndef ERRSV
# define ERRSV get_sv("@",FALSE)
#endif
/* Hint: gv_stashpvn
* This function's backport doesn't support the length parameter, but
* rather ignores it. Portability can only be ensured if the length
* parameter is used for speed reasons, but the length can always be
* correctly computed from the string argument.
*/
#ifndef gv_stashpvn
# define gv_stashpvn(str,len,create) gv_stashpv(str,create)
#endif
/* Replace: 1 */
#ifndef get_cv
# define get_cv perl_get_cv
#endif
#ifndef get_sv
#endif
#ifndef dITEMS
# define dITEMS I32 items = SP - MARK
#endif
#ifndef dXSTARG
# define dXSTARG SV * targ = sv_newmortal()
#endif
#ifndef dAXMARK
# define dAXMARK I32 ax = POPMARK; \
register SV ** const mark = PL_stack_base + ax++
#endif
#ifndef XSprePUSH
# define XSprePUSH (sp = PL_stack_base + ax - 1)
#endif
#if (PERL_BCDVERSION < 0x5005000)
# undef XSRETURN
# define XSRETURN(off) \
STMT_START { \
PL_stack_sp = PL_stack_base + ax + ((off) - 1); \
return; \
} STMT_END
#endif
#ifndef XSPROTO
# define XSPROTO(name) void name(pTHX_ CV* cv)
#endif
#ifndef SVfARG
# define SVfARG(p) ((void*)(p))
#endif
#ifndef PERL_ABS
# define PERL_ABS(x) ((x) < 0 ? -(x) : (x))
# define SVf "_"
#endif
#ifndef UTF8_MAXBYTES
# define UTF8_MAXBYTES UTF8_MAXLEN
#endif
#ifndef CPERLscope
# define CPERLscope(x) x
#endif
#ifndef PERL_HASH
# define PERL_HASH(hash,str,len) \
STMT_START { \
const char *s_PeRlHaSh = str; \
I32 i_PeRlHaSh = len; \
U32 hash_PeRlHaSh = 0; \
while (i_PeRlHaSh--) \
hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \
(hash) = hash_PeRlHaSh; \
} STMT_END
#endif
#ifndef PERLIO_FUNCS_DECL
# ifdef PERLIO_FUNCS_CONST
# define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs
# define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs)
# else
# define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs
# define PERLIO_FUNCS_CAST(funcs) (funcs)
# endif
# define isPUNCT(c) ispunct(c)
#endif
#ifndef isXDIGIT
# define isXDIGIT(c) isxdigit(c)
#endif
#else
# if (PERL_BCDVERSION < 0x5010000)
/* Hint: isPRINT
* The implementation in older perl versions includes all of the
* isSPACE() characters, which is wrong. The version provided by
* Devel::PPPort always overrides a present buggy version.
*/
# undef isPRINT
# endif
#ifndef isALNUMC
# define isALNUMC(c) (isALPHA(c) || isDIGIT(c))
#endif
#ifndef isASCII
# define isASCII(c) ((c) <= 127)
#endif
#elif defined(NEED_PL_signals_GLOBAL)
U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT;
#else
extern U32 DPPP_(my_PL_signals);
#endif
#define PL_signals DPPP_(my_PL_signals)
#endif
/* Hint: PL_ppaddr
* Calling an op via PL_ppaddr requires passing a context argument
* for threaded builds. Since the context argument is different for
* 5.005 perls, you can use aTHXR (supplied by ppport.h), which will
* automatically be defined as the correct argument.
*/
#if (PERL_BCDVERSION <= 0x5005005)
/* Replace: 1 */
# define PL_ppaddr ppaddr
# define PL_no_modify no_modify
/* Replace: 0 */
#endif
#if (PERL_BCDVERSION <= 0x5004005)
/* Replace: 1 */
# define PL_sv_no sv_no
# define PL_sv_undef sv_undef
# define PL_sv_yes sv_yes
# define PL_tainted tainted
# define PL_tainting tainting
# define PL_tokenbuf tokenbuf
/* Replace: 0 */
#endif
/* Warning: PL_parser
* For perl versions earlier than 5.9.5, this is an always
* non-NULL dummy. Also, it cannot be dereferenced. Don't
* use it if you can avoid is and unless you absolutely know
* what you're doing.
* If you always check that PL_parser is non-NULL, you can
* define DPPP_PL_parser_NO_DUMMY to avoid the creation of
* a dummy parser structure.
*/
#if (PERL_BCDVERSION >= 0x5009005)
# ifdef DPPP_PL_parser_NO_DUMMY
# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \
(croak("panic: PL_parser == NULL in %s:%d", \
__FILE__, __LINE__), (yy_parser *) NULL))->var)
# else
# ifdef DPPP_PL_parser_NO_DUMMY_WARNING
# define D_PPP_parser_dummy_warning(var)
# else
# define D_PPP_parser_dummy_warning(var) \
warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__),
# endif
# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \
(D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var)
#if defined(NEED_PL_parser)
static yy_parser DPPP_(dummy_PL_parser);
#elif defined(NEED_PL_parser_GLOBAL)
yy_parser DPPP_(dummy_PL_parser);
#else
extern yy_parser DPPP_(dummy_PL_parser);
#endif
# endif
/* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */
/* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf
* Do not use this variable unless you know exactly what you're
* doint. It is internal to the perl parser and may change or even
* be removed in the future. As of perl 5.9.5, you have to check
* for (PL_parser != NULL) for this variable to have any effect.
* An always non-NULL PL_parser dummy is provided for earlier
* perl versions.
* If PL_parser is NULL when you try to access this variable, a
* dummy is being accessed instead and a warning is issued unless
* you define DPPP_PL_parser_NO_DUMMY_WARNING.
* If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access
* this variable will croak with a panic message.
*/
# define PL_expect D_PPP_my_PL_parser_var(expect)
# define PL_copline D_PPP_my_PL_parser_var(copline)
# define PL_rsfp D_PPP_my_PL_parser_var(rsfp)
# define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters)
# define PL_linestr D_PPP_my_PL_parser_var(linestr)
# define PL_bufptr D_PPP_my_PL_parser_var(bufptr)
# define PL_bufend D_PPP_my_PL_parser_var(bufend)
# define PL_lex_state D_PPP_my_PL_parser_var(lex_state)
# define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff)
# define PERL_LOADMOD_IMPORT_OPS 0x4
#endif
#ifndef G_METHOD
# define G_METHOD 64
# ifdef call_sv
# undef call_sv
# endif
# if (PERL_BCDVERSION < 0x5006000)
# define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \
(flags) & ~G_METHOD) : perl_call_sv(sv, flags))
# else
# define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \
(flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags))
# endif
#endif
/* Replace perl_eval_pv with eval_pv */
#ifndef eval_pv
#if defined(NEED_eval_pv)
static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
static
#else
# undef eval_pv
#endif
#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b)
#define Perl_eval_pv DPPP_(my_eval_pv)
#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL)
SV*
DPPP_(my_eval_pv)(char *p, I32 croak_on_error)
{
dSP;
SV* sv = newSVpv(p, 0);
PUSHMARK(sp);
eval_sv(sv, G_SCALAR);
SvREFCNT_dec(sv);
SPAGAIN;
sv = POPs;
PUTBACK;
if (croak_on_error && SvTRUE(GvSV(errgv)))
croak(SvPVx(GvSV(errgv), na));
return sv;
}
#endif
#endif
#ifndef vload_module
#if defined(NEED_vload_module)
static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args);
static
#else
# undef vload_module
#endif
#define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d)
#define Perl_vload_module DPPP_(my_vload_module)
#if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL)
void
DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args)
{
dTHR;
dVAR;
OP *veop, *imop;
OP * const modname = newSVOP(OP_CONST, 0, name);
/* 5.005 has a somewhat hacky force_normal that doesn't croak on
SvREADONLY() if PL_compling is true. Current perls take care in
ck_require() to correctly turn off SvREADONLY before calling
force_normal_flags(). This seems a better fix than fudging PL_compling
*/
SvREADONLY_off(((SVOP*)modname)->op_sv);
modname->op_private |= OPpCONST_BARE;
if (ver) {
veop = newSVOP(OP_CONST, 0, ver);
}
else
veop = NULL;
if (flags & PERL_LOADMOD_NOIMPORT) {
imop = sawparens(newNULLLIST());
}
else if (flags & PERL_LOADMOD_IMPORT_OPS) {
imop = va_arg(*args, OP*);
}
else {
SV *sv;
imop = NULL;
sv = va_arg(*args, SV*);
while (sv) {
imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
sv = va_arg(*args, SV*);
}
}
{
const line_t ocopline = PL_copline;
COP * const ocurcop = PL_curcop;
const int oexpect = PL_expect;
#if (PERL_BCDVERSION >= 0x5004000)
utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
veop, modname, imop);
#else
utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
modname, imop);
#endif
PL_expect = oexpect;
PL_copline = ocopline;
PL_curcop = ocurcop;
}
}
#endif
#endif
#ifndef load_module
#if defined(NEED_load_module)
static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...);
static
#else
# undef load_module
#endif
#define load_module DPPP_(my_load_module)
#define Perl_load_module DPPP_(my_load_module)
#if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL)
void
DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...)
{
va_list args;
va_start(args, ver);
vload_module(flags, name, ver, &args);
va_end(args);
}
#endif
#endif
#ifndef newRV_inc
# define newRV_inc(sv) newRV(sv) /* Replace */
#endif
#ifndef newRV_noinc
#if defined(NEED_newRV_noinc)
#ifdef newRV_noinc
# undef newRV_noinc
#endif
#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a)
#define Perl_newRV_noinc DPPP_(my_newRV_noinc)
#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL)
SV *
DPPP_(my_newRV_noinc)(SV *sv)
{
SV *rv = (SV *)newRV(sv);
SvREFCNT_dec(sv);
return rv;
}
#endif
#endif
/* Hint: newCONSTSUB
* Returns a CV* as of perl-5.7.1. This return value is not supported
* by Devel::PPPort.
*/
/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
#if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005)
#if defined(NEED_newCONSTSUB)
static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv);
static
#else
extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv);
#endif
#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
/* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */
/* (There's no PL_parser in perl < 5.005, so this is completely safe) */
#define D_PPP_PL_copline PL_copline
void
DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv)
{
U32 oldhints = PL_hints;
HV *old_cop_stash = PL_curcop->cop_stash;
HV *old_curstash = PL_curstash;
line_t oldline = PL_curcop->cop_line;
PL_curcop->cop_line = D_PPP_PL_copline;
PL_hints &= ~HINT_BLOCK_SCOPE;
if (stash)
PL_curstash = PL_curcop->cop_stash = stash;
newSUB(
#if (PERL_BCDVERSION < 0x5003022)
start_subparse(),
#elif (PERL_BCDVERSION == 0x5003022)
start_subparse(0),
#else /* 5.003_23 onwards */
start_subparse(FALSE, 0),
#endif
newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)),
newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
);
PL_hints = oldhints;
PL_curcop->cop_stash = old_cop_stash;
PL_curstash = old_curstash;
PL_curcop->cop_line = oldline;
}
#endif
#endif
/*
* Boilerplate macros for initializing and accessing interpreter-local
* data from C. All statics in extensions should be reworked to use
* this, if you want to make the extension thread-safe. See ext/re/re.xs
* for an example of the use of these macros.
*
* Code that uses these macros is responsible for the following:
* 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
* 2. Declare a typedef named my_cxt_t that is a structure that contains
* all the data that needs to be interpreter-local.
* 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
* 4. Use the MY_CXT_INIT macro such that it is called exactly once
* (typically put in the BOOT: section).
* 5. Use the members of the my_cxt_t structure everywhere as
* MY_CXT.member.
* 6. Use the dMY_CXT macro (a declaration) in all the functions that
* access MY_CXT.
*/
#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
#ifndef START_MY_CXT
/* This must appear in all extensions that define a my_cxt_t structure,
* right after the definition (i.e. at file scope). The non-threads
* case below uses it to declare the data as static. */
#define START_MY_CXT
#if (PERL_BCDVERSION < 0x5004068)
/* Fetches the SV that keeps the per-interpreter data. */
#define dMY_CXT_SV \
SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE)
#else /* >= perl5.004_68 */
#define dMY_CXT_SV \
SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
sizeof(MY_CXT_KEY)-1, TRUE)
#endif /* < perl5.004_68 */
/* This declaration should be used within all functions that use the
* interpreter-local data. */
#define dMY_CXT \
dMY_CXT_SV; \
my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
/* Creates and zeroes the per-interpreter data.
* (We allocate my_cxtp in a Perl SV so that it will be released when
* the interpreter goes away.) */
#define MY_CXT_INIT \
dMY_CXT_SV; \
/* newSV() allocates one more than needed */ \
my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
Zero(my_cxtp, 1, my_cxt_t); \
sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
/* This macro must be used to access members of the my_cxt_t structure.
* e.g. MYCXT.some_data */
#define MY_CXT (*my_cxtp)
/* Judicious use of these macros can reduce the number of times dMY_CXT
* is used. Use is similar to pTHX, aTHX etc. */
#define pMY_CXT my_cxt_t *my_cxtp
#define pMY_CXT_ pMY_CXT,
#define _pMY_CXT ,pMY_CXT
#define aMY_CXT my_cxtp
#define aMY_CXT_ aMY_CXT,
#define _aMY_CXT ,aMY_CXT
#endif /* START_MY_CXT */
#ifndef MY_CXT_CLONE
/* Clones the per-interpreter data. */
#define MY_CXT_CLONE \
dMY_CXT_SV; \
my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\
sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
#endif
#else /* single interpreter */
#ifndef START_MY_CXT
#define START_MY_CXT static my_cxt_t my_cxt;
#define dMY_CXT_SV dNOOP
#define dMY_CXT dNOOP
#define MY_CXT_INIT NOOP
# define UVuf "u"
# define UVof "o"
# define UVxf "x"
# define UVXf "X"
# endif
# endif
#endif
#ifndef NVef
# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000)
/* Not very likely, but let's try anyway. */
# define NVef PERL_PRIeldbl
# define NVff PERL_PRIfldbl
# define NVgf PERL_PRIgldbl
# else
# define NVef "e"
# define NVff "f"
# define NVgf "g"
# endif
#endif
#ifndef SvREFCNT_inc
# ifdef PERL_USE_GCC_BRACE_GROUPS
# define SvREFCNT_inc(sv) \
({ \
SV * const _sv = (SV*)(sv); \
if (_sv) \
(SvREFCNT(_sv))++; \
_sv; \
})
# else
# define SvREFCNT_inc(sv) \
((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL)
# endif
#endif
#ifndef SvREFCNT_inc_simple
# ifdef PERL_USE_GCC_BRACE_GROUPS
# define SvREFCNT_inc_simple(sv) \
({ \
if (sv) \
(SvREFCNT(sv))++; \
(SV *)(sv); \
})
# else
# define SvREFCNT_inc_simple(sv) \
((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL)
# endif
#endif
#ifndef SvREFCNT_inc_NN
# ifdef PERL_USE_GCC_BRACE_GROUPS
# define SvREFCNT_inc_NN(sv) \
({ \
SV * const _sv = (SV*)(sv); \
SvREFCNT(_sv)++; \
_sv; \
})
# else
# define SvREFCNT_inc_NN(sv) \
(PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv)
# endif
#endif
#ifndef SvREFCNT_inc_void
# ifdef PERL_USE_GCC_BRACE_GROUPS
# define SvREFCNT_inc_void(sv) \
({ \
SV * const _sv = (SV*)(sv); \
if (_sv) \
(void)(SvREFCNT(_sv)++); \
})
# else
# define SvREFCNT_inc_void(sv) \
(void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0)
# endif
#endif
#ifndef SvREFCNT_inc_simple_void
# define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END
#endif
#ifndef SvREFCNT_inc_simple_NN
# define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv))
#endif
# undef newSV_type
#endif
#define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a)
#define Perl_newSV_type DPPP_(my_newSV_type)
#if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL)
SV*
DPPP_(my_newSV_type)(pTHX_ svtype const t)
{
SV* const sv = newSV(0);
sv_upgrade(sv, t);
return sv;
}
#endif
#endif
#if (PERL_BCDVERSION < 0x5006000)
# define D_PPP_CONSTPV_ARG(x) ((char *) (x))
#else
# define D_PPP_CONSTPV_ARG(x) (x)
#endif
#ifndef newSVpvn
# define newSVpvn(data,len) ((data) \
? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \
: newSV(0))
#endif
#ifndef newSVpvn_utf8
# define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
#endif
#ifndef SVf_UTF8
# define SVf_UTF8 0
#endif
#ifndef newSVpvn_flags
# undef newSVpvn_flags
#endif
#define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c)
#define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags)
#if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL)
SV *
DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags)
{
SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len);
SvFLAGS(sv) |= (flags & SVf_UTF8);
return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv;
}
#endif
#endif
/* Backwards compatibility stuff... :-( */
#if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen)
# define NEED_sv_2pv_flags
#endif
#if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL)
# define NEED_sv_2pv_flags_GLOBAL
#endif
/* Hint: sv_2pv_nolen
* Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen().
*/
#ifndef sv_2pv_nolen
# define sv_2pv_nolen(sv) SvPV_nolen(sv)
#endif
#ifdef SvPVbyte
/* Hint: SvPVbyte
* Does not work in perl-5.6.1, ppport.h implements a version
* borrowed from perl-5.7.3.
*/
#if (PERL_BCDVERSION < 0x5007000)
#if defined(NEED_sv_2pvbyte)
static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp);
static
#else
extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp);
#endif
# undef sv_2pvbyte
#endif
#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b)
#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte)
#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL)
char *
DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp)
{
sv_utf8_downgrade(sv,0);
return SvPV(sv,*lp);
}
#endif
/* Hint: sv_2pvbyte
* Use the SvPVbyte() macro instead of sv_2pvbyte().
*/
#undef SvPVbyte
#define SvPVbyte(sv, lp) \
((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
#endif
#else
# define SvPVbyte SvPV
# define sv_2pvbyte sv_2pv
#endif
#ifndef sv_2pvbyte_nolen
# define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv)
#endif
/* Hint: sv_pvn
* Always use the SvPV() macro instead of sv_pvn().
*/
/* Hint: sv_pvn_force
* Always use the SvPV_force() macro instead of sv_pvn_force().
*/
/* If these are undefined, they're not handled by the core anyway */
#ifndef SV_IMMEDIATE_UNREF
# define SV_IMMEDIATE_UNREF 0
#endif
#ifndef SV_GMAGIC
# define SV_GMAGIC 0
#endif
# undef sv_2pv_flags
#endif
#define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c)
#define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags)
#if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL)
char *
DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags)
{
STRLEN n_a = (STRLEN) flags;
return sv_2pv(sv, lp ? lp : &n_a);
}
#endif
#if defined(NEED_sv_pvn_force_flags)
static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags);
static
#else
extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags);
#endif
# undef sv_pvn_force_flags
#endif
#define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c)
#define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags)
#if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL)
char *
DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags)
{
STRLEN n_a = (STRLEN) flags;
return sv_pvn_force(sv, lp ? lp : &n_a);
}
#endif
#endif
#if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) )
# define DPPP_SVPV_NOLEN_LP_ARG &PL_na
#else
# define DPPP_SVPV_NOLEN_LP_ARG 0
#endif
#ifndef SvPV_const
# define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC)
#endif
#ifndef SvPV_mutable
# define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC)
#endif
#ifndef SvPV_flags
# define SvPV_flags(sv, lp, flags) \
((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags))
#endif
#ifndef SvPV_flags_const
# define SvPV_flags_const(sv, lp, flags) \
((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \
(const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN))
#endif
#ifndef SvPV_flags_const_nolen
# define SvPV_flags_const_nolen(sv, flags) \
((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
? SvPVX_const(sv) : \
(const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN))
#endif
#ifndef SvPV_flags_mutable
# define SvPV_flags_mutable(sv, lp, flags) \
((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \
sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN))
#endif
#ifndef SvPV_force
# define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC)
#endif
#ifndef SvPV_force_nolen
# define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC)
#endif
#ifndef SvPV_force_mutable
#ifndef SvPV_force_nomg
# define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0)
#endif
#ifndef SvPV_force_nomg_nolen
# define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0)
#endif
#ifndef SvPV_force_flags
# define SvPV_force_flags(sv, lp, flags) \
((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags))
#endif
#ifndef SvPV_force_flags_nolen
# define SvPV_force_flags_nolen(sv, flags) \
((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags))
#endif
#ifndef SvPV_force_flags_mutable
# define SvPV_force_flags_mutable(sv, lp, flags) \
((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \
: sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN))
#endif
#ifndef SvPV_nolen
# define SvPV_nolen(sv) \
((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC))
#endif
#ifndef SvPV_nolen_const
# define SvPV_nolen_const(sv) \
((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN))
#endif
#ifndef SvPV_nomg
# define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0)
#endif
#ifndef SvPV_nomg_const
# define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0)
#endif
#ifndef SvPV_nomg_const_nolen
# define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0)
#endif
#ifndef SvPV_renew
# define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \
SvPV_set((sv), (char *) saferealloc( \
(Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \
} STMT_END
#endif
#ifndef SvMAGIC_set
# define SvMAGIC_set(sv, val) \
STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \
(((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END
#endif
#if (PERL_BCDVERSION < 0x5009003)
#ifndef SvPVX_const
# define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv)))
#endif
#ifndef SvPVX_mutable
# define SvPVX_mutable(sv) (0 + SvPVX(sv))
#endif
#ifndef SvRV_set
# define SvRV_set(sv, val) \
STMT_START { assert(SvTYPE(sv) >= SVt_RV); \
(((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END
#endif
#else
#ifndef SvPVX_const
# define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv))
#endif
#ifndef SvPVX_mutable
# define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv)
#endif
#ifndef SvRV_set
# define SvRV_set(sv, val) \
STMT_START { assert(SvTYPE(sv) >= SVt_RV); \
((sv)->sv_u.svu_rv = (val)); } STMT_END
#endif
#endif
#ifndef SvSTASH_set
# define SvSTASH_set(sv, val) \
STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \
(((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END
#endif
#if (PERL_BCDVERSION < 0x5004000)
#ifndef SvUV_set
# define SvUV_set(sv, val) \
STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
(((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END
#endif
#else
#ifndef SvUV_set
# define SvUV_set(sv, val) \
STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
(((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END
#endif
#endif
#if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf)
#if defined(NEED_vnewSVpvf)
static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args);
static
#else
extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args);
# undef vnewSVpvf
#endif
#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b)
#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf)
#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL)
SV *
DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args)
{
register SV *sv = newSV(0);
sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
return sv;
}
#endif
#endif
#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf)
# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
#endif
#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf)
extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...);
#endif
#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg)
#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL)
void
DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
{
va_list args;
va_start(args, pat);
sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
SvSETMAGIC(sv);
va_end(args);
}
#endif
#endif
#ifdef PERL_IMPLICIT_CONTEXT
#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext)
#if defined(NEED_sv_catpvf_mg_nocontext)
static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...);
static
#endif
#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL)
void
DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...)
{
dTHX;
va_list args;
va_start(args, pat);
sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
SvSETMAGIC(sv);
va_end(args);
}
#endif
#endif
#endif
/* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */
#ifndef sv_catpvf_mg
# ifdef PERL_IMPLICIT_CONTEXT
# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
# else
# define sv_catpvf_mg Perl_sv_catpvf_mg
# endif
#endif
#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg)
# define sv_vcatpvf_mg(sv, pat, args) \
STMT_START { \
sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
SvSETMAGIC(sv); \
} STMT_END
#endif
#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg)
#if defined(NEED_sv_setpvf_mg)
static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...);
static
#else
extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...);
#endif
#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg)
#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL)
void
DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
{
va_list args;
va_start(args, pat);
sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
SvSETMAGIC(sv);
va_end(args);
}
#endif
#endif
#ifdef PERL_IMPLICIT_CONTEXT
#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext)
#if defined(NEED_sv_setpvf_mg_nocontext)
static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...);
static
#endif
#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL)
void
DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...)
{
dTHX;
va_list args;
va_start(args, pat);
sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
SvSETMAGIC(sv);
va_end(args);
}
#endif
#endif
#endif
/* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */
#ifndef sv_setpvf_mg
# ifdef PERL_IMPLICIT_CONTEXT
# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
# else
# define sv_setpvf_mg Perl_sv_setpvf_mg
# endif
#endif
#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg)
# define sv_vsetpvf_mg(sv, pat, args) \
STMT_START { \
sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
SvSETMAGIC(sv); \
} STMT_END
#endif
#ifndef newSVpvn_share
#if defined(NEED_newSVpvn_share)
static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash);
static
#else
extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash);
#endif
# undef newSVpvn_share
#endif
#define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c)
#define Perl_newSVpvn_share DPPP_(my_newSVpvn_share)
#if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL)
SV *
DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash)
{
SV *sv;
if (len < 0)
len = -len;
if (!hash)
PERL_HASH(hash, (char*) src, len);
sv = newSVpvn((char *) src, len);
sv_upgrade(sv, SVt_PVIV);
SvIVX(sv) = hash;
SvREADONLY_on(sv);
SvPOK_on(sv);
return sv;
}
#endif
#endif
#ifndef SvSHARED_HASH
# define SvSHARED_HASH(sv) (0 + SvUVX(sv))
#endif
#ifndef HvNAME_get
# define HvNAME_get(hv) HvNAME(hv)
extern void DPPP_(my_warner)(U32 err, const char *pat, ...);
#endif
#define Perl_warner DPPP_(my_warner)
#if defined(NEED_warner) || defined(NEED_warner_GLOBAL)
void
DPPP_(my_warner)(U32 err, const char *pat, ...)
{
SV *sv;
va_list args;
PERL_UNUSED_ARG(err);
va_start(args, pat);
sv = vnewSVpvf(pat, &args);
va_end(args);
sv_2mortal(sv);
warn("%s", SvPV_nolen(sv));
}
#define warner Perl_warner
#define Perl_warner_nocontext Perl_warner
#endif
#endif
/* concatenating with "" ensures that only literal strings are accepted as argument
* note that STR_WITH_LEN() can't be used as argument to macros or functions that
* under some configurations might be macros
*/
#ifndef STR_WITH_LEN
# define STR_WITH_LEN(s) (s ""), (sizeof(s)-1)
#endif
#ifndef newSVpvs
# define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1)
#endif
#ifndef newSVpvs_flags
# define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags)
#endif
#ifndef SvIV_nomg
# define SvIV_nomg SvIV
#endif
#ifndef SvUV_nomg
# define SvUV_nomg SvUV
#endif
#ifndef sv_catpv_mg
# define sv_catpv_mg(sv, ptr) \
STMT_START { \
SV *TeMpSv = sv; \
sv_catpv(TeMpSv,ptr); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_catpvn_mg
# define sv_catpvn_mg(sv, ptr, len) \
STMT_START { \
SV *TeMpSv = sv; \
sv_catpvn(TeMpSv,ptr,len); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_catsv_mg
# define sv_catsv_mg(dsv, ssv) \
STMT_START { \
SV *TeMpSv = dsv; \
sv_catsv(TeMpSv,ssv); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_setiv_mg
# define sv_setiv_mg(sv, i) \
STMT_START { \
SV *TeMpSv = sv; \
sv_setiv(TeMpSv,i); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_setnv_mg
# define sv_setnv_mg(sv, num) \
STMT_START { \
SV *TeMpSv = sv; \
sv_setnv(TeMpSv,num); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_setpv_mg
# define sv_setpv_mg(sv, ptr) \
STMT_START { \
SV *TeMpSv = sv; \
sv_setpv(TeMpSv,ptr); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_setpvn_mg
# define sv_setpvn_mg(sv, ptr, len) \
STMT_START { \
SV *TeMpSv = sv; \
sv_setpvn(TeMpSv,ptr,len); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_setsv_mg
# define sv_setsv_mg(dsv, ssv) \
STMT_START { \
SV *TeMpSv = dsv; \
sv_setsv(TeMpSv,ssv); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_setuv_mg
# define sv_setuv_mg(sv, i) \
STMT_START { \
SV *TeMpSv = sv; \
sv_setuv(TeMpSv,i); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_usepvn_mg
# define sv_usepvn_mg(sv, ptr, len) \
STMT_START { \
SV *TeMpSv = sv; \
sv_usepvn(TeMpSv,ptr,len); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef SvVSTRING_mg
# define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL)
#endif
/* Hint: sv_magic_portable
* This is a compatibility function that is only available with
* Devel::PPPort. It is NOT in the perl core.
* Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when
* it is being passed a name pointer with namlen == 0. In that
* case, perl 5.8.0 and later store the pointer, not a copy of it.
* The compatibility can be provided back to perl 5.004. With
* earlier versions, the code will not compile.
*/
#if (PERL_BCDVERSION < 0x5004000)
/* code that uses sv_magic_portable will not compile */
#elif (PERL_BCDVERSION < 0x5008000)
# define sv_magic_portable(sv, obj, how, name, namlen) \
STMT_START { \
SV *SvMp_sv = (sv); \
char *SvMp_name = (char *) (name); \
I32 SvMp_namlen = (namlen); \
if (SvMp_name && SvMp_namlen == 0) \
{ \
MAGIC *mg; \
sv_magic(SvMp_sv, obj, how, 0, 0); \
mg = SvMAGIC(SvMp_sv); \
mg->mg_len = -42; /* XXX: this is the tricky part */ \
mg->mg_ptr = SvMp_name; \
} \
else \
{ \
sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \
} \
} STMT_END
#else
# define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e)
#endif
#ifdef USE_ITHREADS
#ifndef CopFILE
# define CopFILE(c) ((c)->cop_file)
#ifndef CopSTASH
# define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv)
#endif
#ifndef CopSTASH_set
# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch)
#endif
#ifndef CopSTASH_eq
# define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \
|| (CopSTASHPV(c) && HvNAME(hv) \
&& strEQ(CopSTASHPV(c), HvNAME(hv)))))
#endif
#else
#ifndef CopFILEGV
# define CopFILEGV(c) ((c)->cop_filegv)
#endif
#ifndef CopFILEGV_set
# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
#endif
#endif
#define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b)
#define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix)
#if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL)
bool
DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send)
{
#ifdef USE_LOCALE_NUMERIC
#ifdef PL_numeric_radix_sv
if (PL_numeric_radix_sv && IN_LOCALE) {
STRLEN len;
char* radix = SvPV(PL_numeric_radix_sv, len);
if (*sp + len <= send && memEQ(*sp, radix, len)) {
*sp += len;
return TRUE;
}
}
#else
/* older perls don't have PL_numeric_radix_sv so the radix
* must manually be requested from locale.h
*/
#include <locale.h>
dTHR; /* needed for older threaded perls */
struct lconv *lc = localeconv();
char *radix = lc->decimal_point;
if (radix && IN_LOCALE) {
STRLEN len = strlen(radix);
if (*sp + len <= send && memEQ(*sp, radix, len)) {
*sp += len;
return TRUE;
}
}
#endif
#endif /* USE_LOCALE_NUMERIC */
/* always try "." if numeric radix didn't match because
* we may have data from different locales mixed */
if (*sp < send && **sp == '.') {
++*sp;
return TRUE;
}
return FALSE;
}
#endif
#endif
#ifndef grok_number
#if defined(NEED_grok_number)
static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
static
#else
extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
#ifdef grok_number
# undef grok_number
#endif
#define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c)
#define Perl_grok_number DPPP_(my_grok_number)
#if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL)
int
DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep)
{
const char *s = pv;
const char *send = pv + len;
const UV max_div_10 = UV_MAX / 10;
const char max_mod_10 = UV_MAX % 10;
int numtype = 0;
int sawinf = 0;
int sawnan = 0;
while (s < send && isSPACE(*s))
s++;
if (s == send) {
return 0;
} else if (*s == '-') {
s++;
numtype = IS_NUMBER_NEG;
}
else if (*s == '+')
s++;
if (s == send)
return 0;
/* next must be digit or the radix separator or beginning of infinity */
if (isDIGIT(*s)) {
/* UVs are at least 32 bits, so the first 9 decimal digits cannot
overflow. */
UV value = *s - '0';
/* This construction seems to be more optimiser friendly.
(without it gcc does the isDIGIT test and the *s - '0' separately)
With it gcc on arm is managing 6 instructions (6 cycles) per digit.
In theory the optimiser could deduce how far to unroll the loop
before checking for overflow. */
if (++s < send) {
int digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
/* Now got 9 digits, so need to check
each time for overflow. */
digit = *s - '0';
while (digit >= 0 && digit <= 9
&& (value < max_div_10
|| (value == max_div_10
&& digit <= max_mod_10))) {
value = value * 10 + digit;
if (++s < send)
digit = *s - '0';
else
break;
}
if (digit >= 0 && digit <= 9
&& (s < send)) {
/* value overflowed.
skip the remaining digits, don't
worry about setting *valuep. */
do {
s++;
} while (s < send && isDIGIT(*s));
numtype |=
IS_NUMBER_GREATER_THAN_UV_MAX;
goto skip_value;
}
}
}
}
}
}
}
}
}
}
}
}
}
}
}
}
}
}
numtype |= IS_NUMBER_IN_UV;
if (valuep)
*valuep = value;
skip_value:
if (GROK_NUMERIC_RADIX(&s, send)) {
numtype |= IS_NUMBER_NOT_INT;
while (s < send && isDIGIT(*s)) /* optional digits after the radix */
s++;
}
}
else if (GROK_NUMERIC_RADIX(&s, send)) {
numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
/* no digits before the radix means we need digits after it */
if (s < send && isDIGIT(*s)) {
do {
s++;
} while (s < send && isDIGIT(*s));
if (valuep) {
/* integer approximation is valid - it's 0. */
*valuep = 0;
}
}
else
return 0;
} else if (*s == 'I' || *s == 'i') {
s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
s++; if (s < send && (*s == 'I' || *s == 'i')) {
s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
s++;
}
sawinf = 1;
} else if (*s == 'N' || *s == 'n') {
/* XXX TODO: There are signaling NaNs and quiet NaNs. */
s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
s++;
sawnan = 1;
} else
return 0;
if (sawinf) {
numtype &= IS_NUMBER_NEG; /* Keep track of sign */
numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
} else if (sawnan) {
numtype &= IS_NUMBER_NEG; /* Keep track of sign */
numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
} else if (s < send) {
/* we can have an optional exponent part */
if (*s == 'e' || *s == 'E') {
/* The only flag we keep is sign. Blow away any "it's UV" */
numtype &= IS_NUMBER_NEG;
numtype |= IS_NUMBER_NOT_INT;
s++;
if (s < send && (*s == '-' || *s == '+'))
s++;
if (s < send && isDIGIT(*s)) {
do {
s++;
} while (s < send && isDIGIT(*s));
}
else
return 0;
}
}
while (s < send && isSPACE(*s))
s++;
if (s >= send)
return numtype;
if (len == 10 && memEQ(pv, "0 but true", 10)) {
if (valuep)
*valuep = 0;
return IS_NUMBER_IN_UV;
}
return 0;
}
#endif
#endif
/*
* The grok_* routines have been modified to use warn() instead of
* Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit,
* which is why the stack variable has been renamed to 'xdigit'.
*/
#ifndef grok_bin
#if defined(NEED_grok_bin)
static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
static
#else
extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
#endif
#ifdef grok_bin
# undef grok_bin
#endif
#define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d)
#define Perl_grok_bin DPPP_(my_grok_bin)
#if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL)
UV
DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
{
const char *s = start;
STRLEN len = *len_p;
UV value = 0;
NV value_nv = 0;
const UV max_div_2 = UV_MAX / 2;
bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
bool overflowed = FALSE;
if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
/* strip off leading b or 0b.
for compatibility silently suffer "b" and "0b" as valid binary
numbers. */
if (len >= 1) {
if (s[0] == 'b') {
s++;
len--;
}
else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
s+=2;
len-=2;
}
}
}
for (; len-- && *s; s++) {
char bit = *s;
if (bit == '0' || bit == '1') {
/* Write it in this wonky order with a goto to attempt to get the
compiler to make the common case integer-only loop pretty tight.
With gcc seems to be much straighter code than old scan_bin. */
redo:
if (!overflowed) {
if (value <= max_div_2) {
value = (value << 1) | (bit - '0');
continue;
}
/* Bah. We're just overflowed. */
warn("Integer overflow in binary number");
overflowed = TRUE;
value_nv = (NV) value;
}
value_nv *= 2.0;
/* If an NV has not enough bits in its mantissa to
* represent a UV this summing of small low-order numbers
* is a waste of time (because the NV cannot preserve
* the low-order bits anyway): we could just remember when
* did we overflow and in the end just multiply value_nv by the
* right amount. */
value_nv += (NV)(bit - '0');
continue;
}
if (bit == '_' && len && allow_underscores && (bit = s[1])
&& (bit == '0' || bit == '1'))
{
--len;
++s;
goto redo;
}
if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
warn("Illegal binary digit '%c' ignored", *s);
break;
}
if ( ( overflowed && value_nv > 4294967295.0)
#if UVSIZE > 4
|| (!overflowed && value > 0xffffffff )
#endif
) {
warn("Binary number > 0b11111111111111111111111111111111 non-portable");
}
*len_p = s - start;
if (!overflowed) {
*flags = 0;
return value;
}
*flags = PERL_SCAN_GREATER_THAN_UV_MAX;
if (result)
*result = value_nv;
return UV_MAX;
}
#endif
#endif
#ifndef grok_hex
#if defined(NEED_grok_hex)
static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
static
#else
extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
#ifdef grok_hex
# undef grok_hex
#endif
#define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d)
#define Perl_grok_hex DPPP_(my_grok_hex)
#if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL)
UV
DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
{
const char *s = start;
STRLEN len = *len_p;
UV value = 0;
NV value_nv = 0;
const UV max_div_16 = UV_MAX / 16;
bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
bool overflowed = FALSE;
const char *xdigit;
if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
/* strip off leading x or 0x.
for compatibility silently suffer "x" and "0x" as valid hex numbers.
*/
if (len >= 1) {
if (s[0] == 'x') {
s++;
len--;
}
else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
s+=2;
len-=2;
}
}
}
for (; len-- && *s; s++) {
xdigit = strchr((char *) PL_hexdigit, *s);
if (xdigit) {
/* Write it in this wonky order with a goto to attempt to get the
compiler to make the common case integer-only loop pretty tight.
With gcc seems to be much straighter code than old scan_hex. */
redo:
if (!overflowed) {
if (value <= max_div_16) {
value = (value << 4) | ((xdigit - PL_hexdigit) & 15);
continue;
}
warn("Integer overflow in hexadecimal number");
overflowed = TRUE;
value_nv = (NV) value;
}
value_nv *= 16.0;
/* If an NV has not enough bits in its mantissa to
* represent a UV this summing of small low-order numbers
* is a waste of time (because the NV cannot preserve
* the low-order bits anyway): we could just remember when
* did we overflow and in the end just multiply value_nv by the
* right amount of 16-tuples. */
value_nv += (NV)((xdigit - PL_hexdigit) & 15);
continue;
}
if (*s == '_' && len && allow_underscores && s[1]
&& (xdigit = strchr((char *) PL_hexdigit, s[1])))
{
--len;
++s;
goto redo;
}
if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
warn("Illegal hexadecimal digit '%c' ignored", *s);
break;
}
if ( ( overflowed && value_nv > 4294967295.0)
#if UVSIZE > 4
|| (!overflowed && value > 0xffffffff )
#endif
) {
warn("Hexadecimal number > 0xffffffff non-portable");
}
*len_p = s - start;
if (!overflowed) {
*flags = 0;
return value;
}
*flags = PERL_SCAN_GREATER_THAN_UV_MAX;
if (result)
*result = value_nv;
return UV_MAX;
}
#endif
#endif
#ifndef grok_oct
#if defined(NEED_grok_oct)
static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
static
#else
extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
#ifdef grok_oct
# undef grok_oct
#endif
#define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d)
#define Perl_grok_oct DPPP_(my_grok_oct)
#if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL)
UV
DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
{
const char *s = start;
STRLEN len = *len_p;
UV value = 0;
NV value_nv = 0;
const UV max_div_8 = UV_MAX / 8;
bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
bool overflowed = FALSE;
for (; len-- && *s; s++) {
/* gcc 2.95 optimiser not smart enough to figure that this subtraction
out front allows slicker code. */
int digit = *s - '0';
if (digit >= 0 && digit <= 7) {
/* Write it in this wonky order with a goto to attempt to get the
compiler to make the common case integer-only loop pretty tight.
*/
redo:
if (!overflowed) {
if (value <= max_div_8) {
value = (value << 3) | digit;
continue;
}
/* Bah. We're just overflowed. */
warn("Integer overflow in octal number");
overflowed = TRUE;
value_nv = (NV) value;
}
value_nv *= 8.0;
/* If an NV has not enough bits in its mantissa to
* represent a UV this summing of small low-order numbers
* is a waste of time (because the NV cannot preserve
* the low-order bits anyway): we could just remember when
* did we overflow and in the end just multiply value_nv by the
* right amount of 8-tuples. */
value_nv += (NV)digit;
continue;
}
if (digit == ('_' - '0') && len && allow_underscores
&& (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
{
--len;
++s;
goto redo;
}
/* Allow \octal to work the DWIM way (that is, stop scanning
* as soon as non-octal characters are seen, complain only iff
* someone seems to want to use the digits eight and nine). */
if (digit == 8 || digit == 9) {
if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
warn("Illegal octal digit '%c' ignored", *s);
}
break;
}
if ( ( overflowed && value_nv > 4294967295.0)
#if UVSIZE > 4
|| (!overflowed && value > 0xffffffff )
#endif
) {
warn("Octal number > 037777777777 non-portable");
}
*len_p = s - start;
if (!overflowed) {
*flags = 0;
return value;
}
*flags = PERL_SCAN_GREATER_THAN_UV_MAX;
if (result)
*result = value_nv;
return UV_MAX;
}
#endif
#endif
#if !defined(my_snprintf)
#if defined(NEED_my_snprintf)
static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...);
static
#else
extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...);
#endif
#define my_snprintf DPPP_(my_my_snprintf)
#define Perl_my_snprintf DPPP_(my_my_snprintf)
#if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL)
int
DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...)
{
dTHX;
int retval;
va_list ap;
va_start(ap, format);
#ifdef HAS_VSNPRINTF
retval = vsnprintf(buffer, len, format, ap);
#else
retval = vsprintf(buffer, format, ap);
#endif
va_end(ap);
if (retval < 0 || (len > 0 && (Size_t)retval >= len))
Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
return retval;
}
#endif
#endif
#if !defined(my_sprintf)
#if defined(NEED_my_sprintf)
static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...);
static
#else
#endif
#define my_sprintf DPPP_(my_my_sprintf)
#define Perl_my_sprintf DPPP_(my_my_sprintf)
#if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL)
int
DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...)
{
va_list args;
va_start(args, pat);
vsprintf(buffer, pat, args);
va_end(args);
return strlen(buffer);
}
#endif
#endif
#ifdef NO_XSLOCKS
# ifdef dJMPENV
# define dXCPT dJMPENV; int rEtV = 0
# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0)
# define XCPT_TRY_END JMPENV_POP;
#endif
#define my_strlcat DPPP_(my_my_strlcat)
#define Perl_my_strlcat DPPP_(my_my_strlcat)
#if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL)
Size_t
DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size)
{
Size_t used, length, copy;
used = strlen(dst);
length = strlen(src);
if (size > 0 && used < size - 1) {
copy = (length >= size - used) ? size - used - 1 : length;
memcpy(dst + used, src, copy);
dst[used + copy] = '\0';
}
return used + length;
}
#endif
#endif
#if !defined(my_strlcpy)
#if defined(NEED_my_strlcpy)
static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size);
static
#else
extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size);
#endif
#define my_strlcpy DPPP_(my_my_strlcpy)
#define Perl_my_strlcpy DPPP_(my_my_strlcpy)
#if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL)
Size_t
DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size)
{
Size_t length, copy;
length = strlen(src);
if (size > 0) {
copy = (length >= size) ? size - 1 : length;
memcpy(dst, src, copy);
dst[copy] = '\0';
}
return length;
}
#endif
#endif
#ifndef PERL_PV_ESCAPE_QUOTE
# define PERL_PV_ESCAPE_QUOTE 0x0001
#endif
#ifndef PERL_PV_PRETTY_QUOTE
# define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE
#endif
#ifndef PERL_PV_PRETTY_DUMP
# define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE
#endif
#ifndef PERL_PV_PRETTY_REGPROP
# define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE
#endif
/* Hint: pv_escape
* Note that unicode functionality is only backported to
* those perl versions that support it. For older perl
* versions, the implementation will fall back to bytes.
*/
#ifndef pv_escape
#if defined(NEED_pv_escape)
static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags);
static
#else
extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags);
#endif
#ifdef pv_escape
# undef pv_escape
#endif
#define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f)
#define Perl_pv_escape DPPP_(my_pv_escape)
#if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL)
char *
DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str,
const STRLEN count, const STRLEN max,
STRLEN * const escaped, const U32 flags)
{
const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\';
const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc;
char octbuf[32] = "%123456789ABCDF";
STRLEN wrote = 0;
STRLEN chsize = 0;
STRLEN readsize = 1;
#if defined(is_utf8_string) && defined(utf8_to_uvchr)
bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0;
#endif
const char *pv = str;
const char * const end = pv + count;
octbuf[0] = esc;
if (!(flags & PERL_PV_ESCAPE_NOCLEAR))
sv_setpvs(dsv, "");
#if defined(is_utf8_string) && defined(utf8_to_uvchr)
if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
isuni = 1;
#endif
for (; pv < end && (!max || wrote < max) ; pv += readsize) {
const UV u =
#if defined(is_utf8_string) && defined(utf8_to_uvchr)
isuni ? utf8_to_uvchr((U8*)pv, &readsize) :
#endif
(U8)*pv;
const U8 c = (U8)u & 0xFF;
if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) {
if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
chsize = my_snprintf(octbuf, sizeof octbuf,
"%"UVxf, u);
else
chsize = my_snprintf(octbuf, sizeof octbuf,
"%cx{%"UVxf"}", esc, u);
} else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
chsize = 1;
} else {
if (c == dq || c == esc || !isPRINT(c)) {
chsize = 2;
switch (c) {
case '\\' : /* fallthrough */
case '%' : if (c == esc)
octbuf[1] = esc;
else
chsize = 1;
break;
case '\v' : octbuf[1] = 'v'; break;
case '\t' : octbuf[1] = 't'; break;
case '\r' : octbuf[1] = 'r'; break;
case '\n' : octbuf[1] = 'n'; break;
case '\f' : octbuf[1] = 'f'; break;
case '"' : if (dq == '"')
octbuf[1] = '"';
else
chsize = 1;
break;
default: chsize = my_snprintf(octbuf, sizeof octbuf,
pv < end && isDIGIT((U8)*(pv+readsize))
? "%c%03o" : "%c%o", esc, c);
}
} else {
chsize = 1;
}
}
if (max && wrote + chsize > max) {
break;
} else if (chsize > 1) {
sv_catpvn(dsv, octbuf, chsize);
wrote += chsize;
} else {
char tmp[2];
my_snprintf(tmp, sizeof tmp, "%c", c);
sv_catpvn(dsv, tmp, 1);
wrote++;
}
if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
break;
}
if (escaped != NULL)
*escaped= pv - str;
return SvPVX(dsv);
}
#endif
#endif
#ifndef pv_pretty
#if defined(NEED_pv_pretty)
static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags);
static
#else
#ifdef pv_pretty
# undef pv_pretty
#endif
#define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g)
#define Perl_pv_pretty DPPP_(my_pv_pretty)
#if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL)
char *
DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count,
const STRLEN max, char const * const start_color, char const * const end_color,
const U32 flags)
{
const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
STRLEN escaped;
if (!(flags & PERL_PV_PRETTY_NOCLEAR))
sv_setpvs(dsv, "");
if (dq == '"')
sv_catpvs(dsv, "\"");
else if (flags & PERL_PV_PRETTY_LTGT)
sv_catpvs(dsv, "<");
if (start_color != NULL)
sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color));
pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR);
if (end_color != NULL)
sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color));
if (dq == '"')
sv_catpvs(dsv, "\"");
else if (flags & PERL_PV_PRETTY_LTGT)
sv_catpvs(dsv, ">");
if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count)
sv_catpvs(dsv, "...");
return SvPVX(dsv);
}
#endif
#endif
#ifndef pv_display
#if defined(NEED_pv_display)
static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim);
static
#else
# undef pv_display
#endif
#define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e)
#define Perl_pv_display DPPP_(my_pv_display)
#if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL)
char *
DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
{
pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
if (len > cur && pv[cur] == '\0')
sv_catpvs(dsv, "\\0");
return SvPVX(dsv);
}
#endif
#endif
#endif /* _P_P_PORTABILITY_H_ */
/* End of File ppport.h */
t/01-simple.t view on Meta::CPAN
#########################
# change 'tests => 1' to 'tests => last_test_to_print';
use Test::More tests => 10+9+2+1;
1 for $Test::More::TODO;
our $T = 'AI::Pathfinding::AStar::Rectangle';
BEGIN{
eval "use ExtUtils::testlib;" unless grep { m/::testlib/ } keys %INC;
print "not ok $@" if $@;
$T = 'AI::Pathfinding::AStar::Rectangle';
eval "use $T qw(create_map);";
die "Can't load $T: $@." if $@;
}
use AI::Pathfinding::AStar::Rectangle qw(create_map);
my $a= $T->new({ width => 12, height => 15 });
ok($a);
is(ref ($a), $T);
is(ref create_map({width=>1, height=>1}), $T);
is($a->width, 12, 'width');
is($a->height, 15, 'height');
t/02-passability.t view on Meta::CPAN
#########################
# change 'tests => 1' to 'tests => last_test_to_print';
use Test::More 'no_plan';
use strict;
use warnings;
1 for $Test::More::TODO;
my $T;
BEGIN{
eval "use ExtUtils::testlib;" unless grep { m/::testlib/ } keys %INC;
print "not ok $@" if $@;
$T = 'AI::Pathfinding::AStar::Rectangle';
eval "use $T qw(create_map);";
die "Can't load $T: $@." if $@;
}
my $m= $T->new({ width => 12, height => 15 });
my $accum;
$accum = '';
for my $x(-2..14){
for my $y (-2..17){
$accum.= $m->get_passability($x,$y);
}
}
is($accum, ( '0' x (12*15)), "all 0");
$m->foreach_xy_set( sub { $a + 2 ;});
$accum = '';
$m->foreach_xy( sub {$accum.= 1 if ($a + 2) == $_;});
is($accum, ( '1' x (12*15)), "all 1 ");
$m->foreach_xy_set( sub { $b + 2 ;});
$accum = '';
t/02-passability.t view on Meta::CPAN
$m->foreach_xy( sub {$accum.= 1 if ($b + 2) == $_;});
is($accum, ( '1' x (12*15)), "all 1 ");
$m->set_start_xy(0,0);
my $count = 0;
$count = 0;
for my $x (0..11){
for my $y (0..14){
$count = ($count + 1) % 127 +1;
$m->set_passability($x,$y, $count);
is($m->get_passability($x,$y), $count, "check fix");
$m->set_start_xy(13, 20);
is($m->get_passability($x+13,$y+20), $count, "check fix with offset");
$m->set_start_xy(0,0);
}
}
$m=$T->new({ width => 12, height => 15 });
$count = 0;
for my $y (0..14){
for my $x (0..11){
ok(not $m->get_passability($x,$y));
$count = ($count + 1) % 127 +1;
$m->set_passability($x,$y, $count);
is($m->get_passability($x,$y), $count, "check fix no offset");
$m->set_start_xy(13, 20);
is($m->get_passability($x+13,$y+20), $count, "check fix with offset");
$m->set_start_xy(0,0);
}
}
{
my $m=$T->new({ width => 15, height => 12 });
for my $y(-2..14){
for my $x (-2..17){
ok(not $m->get_passability($x,$y));
}
}
$m->set_start_xy(0,0);
my $count = 0;
$count = 0;
for my $y (0..11){
for my $x (0..14){
ok(not $m->get_passability($x,$y));
$count = ($count + 1) % 127 +1;
$m->set_passability($x,$y, $count);
is($m->get_passability($x,$y), $count, "check fix");
$m->set_start_xy(13, 20);
is($m->get_passability($x+13,$y+20), $count, "check fix with offset");
$m->set_start_xy(0,0);
}
}
$m=$T->new({ width => 15, height => 12 });
$count = 0;
for my $x (0..14){
for my $y (0..11){
ok(not $m->get_passability($x,$y));
$count = ($count + 1) % 127 +1;
$m->set_passability($x,$y, $count);
is($m->get_passability($x,$y), $count, "check fix no offset");
$m->set_start_xy(13, 20);
is($m->get_passability($x+13,$y+20), $count, "check fix with offset");
$m->set_start_xy(0,0);
}
}
}
#########################
# Insert your test code below, the Test::More module is use()ed here so read
# its man page ( perldoc Test::More ) for help writing this test script.
t/03-path-valid.t view on Meta::CPAN
use Test::More 'no_plan';
1 for $Test::More::TODO;
use Data::Dumper;
my $T;
BEGIN{
$T = "AI::Pathfinding::AStar::Rectangle";
eval "use ExtUtils::testlib;" unless grep { m/testlib/ } keys %INC;
eval "use $T";
}
my $m = $T->new({ width => 5, height => 5 });
for my $d ("0".."9"){
is_deeply([$m->is_path_valid(0,0,$d)], ['']);
#print Dumper([$m->is_path_valid(0,0,$d)], ['']);
};
$m->set_start_xy(2,5);
for my $x (2..6){
for my $y(5..9){
$m->set_passability($x,$y, 1);
}
}
is_deeply( [$m->is_path_valid(2,5, $_)], [''], "failed from 2,5 path=$_") for split "", 74189;
is_deeply( [scalar $m->is_path_valid(2,5, $_)], [1], "success from 2,5 path=$_") for split "", 23605;
is_deeply( [$m->is_path_valid(2,9, $_)], [''], "failed from 2,9 path=$_") for split "", 12347;
is_deeply( [scalar $m->is_path_valid(2,9, $_)], [1], "success from 2,9 path=$_") for split "", 89605;
t/03-path-valid.t view on Meta::CPAN
is_deeply( [$m->is_path_valid(6,9, $_)], [''], "failed from 6,9 path=$_") for split "", 12369;
is_deeply( [scalar $m->is_path_valid(6,9, $_)], [1], "success from 6,9 path=$_") for split "", 47805;
is_deeply( [$m->is_path_valid(3,6, $_)], [3, 6, 20, 1], "success from 2,5 path=$_") for unpack "(a2)*","46648228" ;
is_deeply( [$m->is_path_valid(3,6, $_)], [3, 6, 28, 1], "success from 2,5 path=$_") for unpack "(a2)*","19913773" ;
is_deeply( [$m->is_path_valid(3,6, $_)], [3, 6, 100, 1], "success from 2,5 path=$_") for unpack "(a2)*","00550550" ;
for my $x (2..6){
for my $y(5..9){
is_deeply( [$m->is_path_valid($x, $y, "")], [$x, $y, 0, 1], "success from $x,$y path=''") ;
}
}
t/04-astar.t view on Meta::CPAN
#!perl
use Test::More 'no_plan';
1 for $Test::More::TODO;
use Data::Dumper;
my $T;
BEGIN {
$T = "AI::Pathfinding::AStar::Rectangle";
eval "use ExtUtils::testlib;" unless grep { m/testlib/ } keys %INC;
eval "use $T";
}
{
my $m = $T->new( { width => 5, height => 5 } );
for my $d ( "0" .. "9" ) {
# is_deeply([$m->validate_path(0,0,$d)], ['']);
# print Dumper([$m->validate_path(0,0,$d)], ['']);
}
$m->set_start_xy( 2, 5 );
for my $x ( 2 .. 6 ) {
for my $y ( 5 .. 9 ) {
$m->set_passability( $x, $y, 1 );
}
}
is_deeply( [ $m->astar( 2, 5, 2, 5 ) ], [ '', 1 ], "empty path" );
is_deeply( [ $m->astar( 2, 5, 2, 6 ) ], [ '2', 1 ], " path= 8" );
is_deeply( [ $m->astar( 2, 5, 3, 5 ) ], [ '6', 1 ], " path= 6" );
is_deeply( [ $m->astar( 2, 5, 3, 6 ) ], [ '3', 1 ], " path= 9" );
for ( split "", 14789 ) {
my ( $x, $y ) = $m->path_goto( 2, 5, $_ );
is_deeply( [ $m->astar( 2, 5, $x, $y ) ], [""], "no path" );
}
for ( split "", 12346789 ) {
my ( $x, $y ) = $m->path_goto( 3, 6, $_ );
print join " ", 3, 6, $x, $y, $_,"\n";
is_deeply( [ $m->astar( 3, 6, $x, $y ) ], [ $_, 1 ], "curry" );
}
for ( split "", 12346789 ) {
my ( $x, $y , $metric, $res) = $m->is_path_valid( 4, 7, $_ x 2 );
is_deeply(
[ $m->astar( 4, 7, $x, $y ) ],
[ $_ x 2, 1 ],
"curry 2"
);
}
}
t/05-foreach.t view on Meta::CPAN
#!perl
use Test::More 'no_plan';
1 for $Test::More::TODO;
use Data::Dumper;
my $T;
BEGIN {
$T = "AI::Pathfinding::AStar::Rectangle";
eval "use ExtUtils::testlib;" unless grep { m/testlib/ } keys %INC;
eval "use $T";
}
{
my $m = $T->new( { width => 5, height => 5 } );
$a = "TODO_a";
$b = "TODO_b";
$_ = "TODO__";
my $ok = 1;
$m->foreach_xy( sub {$ok &&= defined $a && defined $b && defined $_ && $_ == 0; } );
is( $ok, 1, "foreach on empty");
is( $a, "TODO_a", '$a remain value' );
is( $b, "TODO_b", '$b remain value' );
is( $_, "TODO__", '$_ remain value' );
$ok = 1;
$m->foreach_xy_set( sub { $ok &&= defined $a && defined $b && defined $_ && $_ == 0 ; $a %2 } );
is( $ok, 1 , '$a, $b, $_ defined and right');
is( $a, "TODO_a", '$a remain value' );
is( $b, "TODO_b", '$b remain value' );
is( $_, "TODO__", '$_ remain value' );
$ok = 1;
$m->foreach_xy( sub {$ok &&= defined $a && defined $b && defined $_ && $_ == $a %2 ; } );
is( $ok, 1, "foreach on even \$a");
is( $m->get_passability( 0,0 ), 0, "(0,0)");
is( $m->get_passability( 0,1 ), 0, "(0,1)");
is( $m->get_passability( 1,0 ), 1, "(1,0)");
is( $m->get_passability( 1,1 ), 1, "(1,1)");
my $q = $m->clone();
$ok = 1;
$q->foreach_xy( sub {$ok &&= defined $a && defined $b && defined $_ && $_ == $a %2 ; } );
is( $ok, 1, "foreach on cloned");
ok( $q != $m , "clone is different" );
is( $q->width, $m->width, "clone width");
is( $q->height, $m->height, "clone height");
is( $q->start_x, $m->start_x, "clone start_x");
is( $q->start_y, $m->start_y, "clone start_y");
is( $q->last_x, $m->last_x, "clone last_x");
is( $q->last_y, $m->last_y, "clone last_y");
$q = $m->clone_rect( 1, 1, 2, 3);
$ok = 1;
$q->foreach_xy( sub {$ok &&= defined $a && defined $b && defined $_ && $_ == $a %2 ; } );
is($ok, 1, "foreach on rect clone" );
ok( $q != $m, "rect clone is different" );
is( $q->width, 2, "clone width");
is( $q->height, 3, "clone height");
is( $q->start_x, 1, "clone start_x");
is( $q->start_y, 1, "clone start_y");
is( $q->last_x, 2, "clone last_x");
is( $q->last_y, 3, "clone last_y");
}
t/06-setstart.t view on Meta::CPAN
#!perl
use Test::More 'no_plan';
1 for $Test::More::TODO;
use Data::Dumper;
my $T;
BEGIN {
$T = "AI::Pathfinding::AStar::Rectangle";
eval "use ExtUtils::testlib;" unless grep { m/testlib/ } keys %INC;
eval "use $T";
}
{
my $m = $T->new( { width => 5, height => 5 } );
$m->set_start_xy(-1, 0);
is( $m->begin_x, -1, "begin_x (1)");
is( $m->begin_y, 0, "begin_y (1)");
is( $m->start_x, -1, "start_x (1)");
is( $m->start_y, 0, "start_y (1)");
is( $m->end_x, 3, "end_x (2)");
is( $m->end_y, 4, "end_y (2)");
is( $m->last_x, 3, "last_x (2)");
is( $m->last_y, 4, "last_y (2)");
$m->set_start_xy( 0, -1);
is( $m->begin_x, 0, "begin_x (3)");
is( $m->begin_y, -1, "begin_y (3)");
is( $m->start_x, 0, "start_x (3)");
is( $m->start_y, -1, "start_y (3)");
is( $m->end_x, 4, "end_x (4)");
is( $m->end_y, 3, "end_y (4)");
is( $m->last_x, 4, "last_x (4)");
is( $m->last_y, 3, "last_y (4)");
}
t/07-dastar.t view on Meta::CPAN
#!perl
use Test::More 'no_plan';
1 for $Test::More::TODO;
use Data::Dumper;
my $T;
BEGIN {
$T = "AI::Pathfinding::AStar::Rectangle";
eval "use ExtUtils::testlib;" unless grep { m/testlib/ } keys %INC;
eval "use $T";
}
{
my $m = $T->new( { width => 5, height => 5 } );
$m->set_start_xy( 2, 5 );
for my $x ( 2 .. 6 ) {
for my $y ( 5 .. 9 ) {
$m->set_passability( $x, $y, 1 );
}
}
is_deeply( [ $m->dastar( 2, 5, 2, 5 ) ], [ '', 1 ], "empty path" );
is_deeply( [ $m->dastar( 2, 5, 2, 6 ) ], [ '', 1 ], " path= 8" );
is_deeply( [ $m->dastar( 2, 5, 3, 5 ) ], [ '', 1 ], " path= 6" );
is_deeply( [ $m->dastar( 2, 5, 3, 6 ) ], [ '3', 1 ], " path= 9" );
for ( split "", 14789 ) {
my ( $x, $y ) = $m->path_goto( 2, 5, $_ );
is_deeply( [ $m->dastar( 2, 5, $x, $y ) ], [""], "no path" );
}
for ( split "", 12346789 ) {
my ( $x, $y ) = $m->path_goto( 3, 6, $_ );
#print join " ", 3, 6, $x, $y, $_,"\n";
is_deeply( [ $m->dastar( 3, 6, $x, $y ) ], [ $_%2 ? $_ : '', 1 ], "curry" );
}
for ( split "", 1379 ) {
my ( $x, $y , $metric, $res) = $m->is_path_valid( 4, 7, $_ x 2 );
is_deeply(
[ $m->dastar( 4, 7, $x, $y ) ],
[ $_ x 2, 1 ],
"curry 2"
);
}
}
TYPEMAP
pmap MAP_OBJ
INPUT
MAP_OBJ
if ( !sv_isobject( $arg ) )
croak_xs_usage( cv, \"Need object\" );
$var = (pmap)SvPV_nolen(SvRV($arg));
OUTPUT
MAP_OBJ
sv_setiv($arg, (I32) $var);
( run in 0.330 second using v1.01-cache-2.11-cpan-4d50c553e7e )