Prima
view release on metacpan or search on metacpan
Prima/sys/Gencls.pm view on Meta::CPAN
if ( $resSub eq "char*") {
print HEADER <<LABEL;
{
char * $incRet =$castedResult SvPV_nolen( $incRes);
sv_2mortal( $incRes);
return $incRet;
}
LABEL
} else {
print HEADER "\treturn $incRes;\n";
}
}
print HEADER "}\n\n";
};
}
sub out_FROMPERL_methods
{
my ( $methods, $full) = @_;
my %thunks = ();
# portable methods, bodies
for ( my $i = 0; $i < scalar @{$methods}; $i++) {
my @parms = split( " ", $$methods[ $i]);
my $id = shift @parms;
# forward declarations
if ( $full && $publicMethods{$id})
{
print HEADER "XS( ${ownCType}_${id}_FROMPERL);\n\n";
next;
}
if ( $full && $optimize && $templates_xs{$id}) {
unless ( exists $thunks{$templates_xs{$id}}) {
$thunks{$templates_xs{$id}} = 1;
print HEADER "extern void $templates_xs{$id}( XS_STARTPARAMS, char* subName, void* func);\n\n";
}
my $func = ( exists $pipeMethods{ $id}) ?
$pipeMethods{$id} :
"${ownCType}_$id";
print HEADER <<LABEL;
XS( ${ownCType}_${id}_FROMPERL) {
$templates_xs{$id}( XS_CALLPARAMS, \"${ownOClass}\:\:$id\", (void*)$func);
}
LABEL
next;
}
my $result = shift @parms; # result type
my $eptr = $result =~ /^\*/ ? "*" : ""; # whether result is a pointer
my ( $lpr, $rpr) = $eptr ? ('(',')') : ('','');
$result =~ s[^\*][]; # strip * signs
my $resSub = $mapTypes { $result} || $result; # basic result type ( typecast skip)
my $nParam = scalar @parms;
my $useHandle = !exists( $staticMethods{ $id});
@defParms = @{$allMethodsDefaults[$allMethods{$id}]};
my $firstDP = undef;
my $lastDP = 0;
my $property = defined $properties{$id};
my $ifpropset;
my $propparms = 1;
my $propextras;
$propextras = 1 if $property && $nParam > ( $useHandle ? 3 : 2);
for ( my $k = 0; $k < scalar @defParms; $k++)
{
if ( defined $defParms[$k])
{
$firstDP = $k unless defined $firstDP;
$lastDP++;
}
}
my $useHV = $nParam ? $parms[ $#parms] eq 'HV*' : 0;
shift @parms if $useHandle;
shift @parms if $property;
my $delta = 0;
foreach (@parms)
{ # adjust parms count referring
my $lVar = $_; $lVar =~ s[^\*][];
if ( exists( $structs{ $lVar}) && !defined( ${$structs{ $lVar}[2]}{hash}))
{ # to possible structs
$delta = scalar @{$structs{$lVar}[0]} - 1;
} elsif ( exists( $arrays{ $lVar})) { # and arrays
$delta = $arrays{$lVar}[0] - 1;
} else {
$delta = 0;
}
$nParam += $delta;
}
$propparms += $delta if $property;
if ( $full) {
print HEADER "XS( ${ownCType}_${id}_FROMPERL)";
} else {
# using pre-generated thunk name. Suggesting call is responsive to set
# $methods to filtered array, that for sure contains that names.
print HEADER "void $templates_xs{$id}( XS_STARTPARAMS, char* subName, void* func)";
}
print HEADER "\n{\n";
print HEADER " dXSARGS;\n";
print HEADER " Handle $incSelf;\n" if $useHandle;
print HEADER " (void)ax;\n" if !$useHandle && ( $nParam == 0);
print HEADER " if ";
if ( $useHV)
{
print HEADER "(( items - $nParam + 1) % 2 != 0)";
} else {
if ( $property) {
my $min = $nParam - $propparms - ( $useHandle ? 1 : 2);
my $max = $nParam - 1;
$ifpropset = "items > $min";
print HEADER "(( items != $min) && ( items != $max))";
} elsif ( $lastDP) {
print HEADER "(( items > $nParam) || ( items < ${\($nParam-$lastDP)}))";
} else {
print HEADER "( items != $nParam)";
}
}
my $croakId = $full ? "${ownOClass}\:\:\%s\", \"$id\"" : "\%s\", subName";
print HEADER "\n\t\tcroak (\"Invalid usage of $croakId);\n";
if ( $useHandle)
{
print HEADER <<LABEL;
$incSelf = $incGetMate( ST( 0));
if ( $incSelf == NULL_HANDLE)
croak( "Illegal object reference passed to $croakId);
LABEL
}
if ( defined $firstDP)
{
print HEADER "\t{\n";
print HEADER "\t\tEXTEND( sp, $nParam - items);\n";
for ( my $k = $firstDP; $k < scalar @defParms; $k++)
{
my $it=$nParam - (scalar @parms)+$k+1;
my $dp=$defParms[$k];
my $tp=$mapTypes{$parms[$k]}||$parms[$k];
print HEADER "\tif ( items < $it) ";
my $mc = mortal( $tp);
print HEADER "PUSHs( $mc( ".type2sv( $tp, $dp)."));\n";
# print HEADER "PUSHs( sv_2mortal( new$xsConv{$tp}[7]( $dp$xsConv{$tp}[5])));\n";
# ^^ to enable being Handle default parameters
}
print HEADER "\t}\n";
}
print HEADER "\t{\n\t\t";
my $structCount = 0;
my $stn = $useHandle ? 1 : 0;
unless ($resSub eq "void") {
print HEADER "$result $eptr $incRes;\n\t\t"
};
# generating struct local vars
my $reuseStructVar;
my $idparm = 0;
foreach (@parms)
{
my $ptr = $_ =~ /^\*/ ? "&" : "";
my $lVar = $_; $lVar =~ s[^\*][];
my ( $lp, $rp) = $ptr ? ('(',')') : ('','');
if ( exists $structs{$lVar} && defined ${$structs{$lVar}[2]}{hash}) {
$reuseStructVar = 1, last
if $property && $idparm == $#parms && ( $ptr eq "");
print HEADER "$lVar $incRes$structCount;\n\t\t";
$structCount++;
} elsif ( exists $arrays{$lVar} || exists $structs{$lVar}) {
$reuseStructVar = 1, last
if $property && $idparm == $#parms && ( $ptr eq "");
print HEADER "$lVar $incRes$structCount;\n\t\t";
$structCount++;
} else {
Prima/sys/Gencls.pm view on Meta::CPAN
foreach (@parms) {
my $ptr = $_ =~ /^\*/ ? "&" : "";
my $lVar = $_; $lVar =~ s[^\*][];
my ( $lp, $rp) = $ptr ? ('(',')') : ('','');
# hash structure
if ( $property && $idparm == $#parms) {
$structCount = '' if $reuseStructVar;
$paramAuxSet .= '****'; # label point
}
if ( exists $structs{$lVar} && defined ${$structs{$lVar}[2]}{hash})
{
$paramAuxSet .= "SvHV_$lVar( ST( $stn), \&$incRes$structCount, $subId);\n\t\t";
$structCount++;
$stn++;
} elsif ( exists $structs{$lVar}) # struct
{
for ( my $j = 0; $j < scalar @{ $structs{ $lVar}[ 0]}; $j++) {
my $lType = ${ $structs{ $lVar}[ 0]}[ $j];
my $lName = ${ $structs{ $lVar}[ 1]}[ $j];
if ( $lType eq "string") {
$paramAuxSet .= "strncpy( $incRes$structCount. $lName, ( char*) SvPV_nolen( ST( $stn)), 255); $incRes$structCount. $lName\[255\]=0;\n\t\t";
} else {
$paramAuxSet .= "$incRes$structCount. $lName = ";
if ( $lType eq "SV*") {
$paramAuxSet .= "ST( $stn);\n\t\t";
} else {
my $mtType = $mapTypes{$lType} || $lType;
$paramAuxSet .= "( $lType) $xsConv{$mtType}[1]( ST( $stn)$xsConv{$mtType}[8]);\n\t\t";
}
}
$stn++;
}
$structCount++;
# array
} elsif ( exists $arrays{$lVar}) {
my $lName = $arrays{$lVar}[1];
my $lType = $lName;
$lName = $mapTypes{$lName} || $lName;
my $str;
$paramAuxSet .= "{\n\t\t\tint $incCount;\n\t\t\t";
$paramAuxSet .= "for ( $incCount = 0; $incCount < $arrays{$lVar}[0]; $incCount++)\n\t\t\t";
if ( $lName eq 'SV*') {
$str = "$incRes$structCount\[$incCount\] = ST( $stn + $incCount)"
} elsif ( $lName eq 'string') {
$str = "strncpy( $incRes$structCount\[$incCount\], ( char*) SvPV_nolen( ST( $stn + $incCount)), 255);$incRes$structCount\[$incCount\]\[255\]=0"
} else {
$str = "$incRes$structCount\[$incCount\] = ( $lType) $xsConv{$lName}[1]( ST( $stn + $incCount)$xsConv{$lName}[8])";
}
$paramAuxSet .= "\t$str;\n\t\t}\n\t\t";
$stn += $arrays{$lVar}[0];
$structCount++;
} else {
$stn++
};
$idparm++;
}
# generating call
my $lpaus = ( length( $paramAuxSet) > 4) || ( $paramAuxSet eq '****');
if ( $lpaus || $property) {
if ( $property && $lpaus) {
my $label = "if ( !( $ifpropset)) {\n";
$label .= "\t\t\tmemset(&$incRes,0,sizeof($incRes));\n" if $reuseStructVar;
$label .= "\t\t\tgoto CALL_POINT;\n\t\t}\n\t\t";
$paramAuxSet =~ s/\*\*\*\*/$label/;
}
print HEADER $paramAuxSet;
print HEADER "CALL_POINT : " if $property && $lpaus;
}
print HEADER "$incRes = " unless $resSub eq "void";
if ( $full) {
print HEADER ( exists $pipeMethods{ $id}) ?
$pipeMethods{$id} :
"${ownCType}_$id";
} else {
my @parmList = @parms;
unshift( @parmList, 'Bool') if $property;
unshift( @parmList, 'Handle') if $useHandle;
for ( @parmList) {
s/^\*(.*)/$1\*/;
} # since "*Struc" if way to know it's user ptr, map it back
my $parmz = join( ', ', @parmList);
print HEADER "(( $resSub$eptr (*)( $parmz)) func)";
}
print HEADER "(\n";
print HEADER "\t\t\t$incSelf" if $useHandle;
$stn = 0;
$stn++ if $useHandle;
if ( $property) {
print HEADER ",\n" if $stn > 0;
print HEADER "\t\t\t$ifpropset";
}
$structCount = 0;
$idparm = 0;
foreach (@parms) {
my $ptr = $_ =~ /^\*/ ? "&" : "";
my $lVar = $_;
$lVar =~ s[^\*][];
$mtVar = $mapTypes{ $lVar} || $lVar;
my ( $lp, $rp) = $ptr ? ('(',')') : ('','');
$structCount = '' if $property && $reuseStructVar && $idparm == $#parms;
print HEADER ",\n" if $stn > 0;
print HEADER "\t\t\t";
print HEADER "( $ifpropset) ? ( " if
$property && !$reuseStructVar && $idparm == $#parms;
my $defPropParm;
if ( exists $structs{$lVar} || exists $arrays{$lVar})
{
if ( exists $structs{$lVar}) {
$stn += defined ${$structs{$lVar}[2]}{hash} ?
1 :
scalar @{ $structs{ $lVar}[ 0]};
} else {
$stn += $arrays{$lVar}[0];
};
print HEADER "$ptr$incRes$structCount";
$defPropParm = "${lVar}_buffer";
$structCount++;
} else {
if ( $mtVar eq "SV*") {
print HEADER "ST ( $stn)";
} elsif ( $mtVar eq "HV*") {
print HEADER "hv";
} else {
print HEADER "$ptr( $lVar) $xsConv{$mtVar}[1]( ST( $stn)$xsConv{$mtVar}[8])";
}
$defPropParm = "($lVar)0";
$stn++;
}
print HEADER ") : $defPropParm" if
$property && !$reuseStructVar && $idparm == $#parms;
$idparm++;
}
print HEADER "\n";
print HEADER "\t\t);\n";
print HEADER "\t\tSPAGAIN;\n\t\tSP -= items;\n"
if (!( $resSub eq "void") || $useHV);
print HEADER "\t\tif ( $ifpropset) {\n\t\t\tXSRETURN_EMPTY;\n\t\t\treturn;\n\t\t}\n"
if $property;
my $pphv = 0;
# result generation
if ( exists $structs{$resSub} && defined ${$structs{$resSub}[2]}{hash}) {
# hashed structure -> hash reference
my $bptr = ( $eptr eq '*') ? '' : '&';
print HEADER "\t\tXPUSHs( sv_2mortal( sv_${resSub}2HV( $bptr$incRes)));\n";
$pphv = 1;
} elsif ( exists( $structs{ $resSub})) {
# structure -> array
my $rParms = scalar @{ $structs{ $resSub}[ 0]};
print HEADER "\t\tEXTEND(sp, $rParms);\n";
for ( my $j = 0; $j < $rParms; $j++) {
my $lType = @{ $structs{ $resSub}[ 0]}[ $j];
$lType = $mapTypes{$lType}||$lType;
my $lName = @{ $structs{ $resSub}[ 1]}[ $j];
my $mc = mortal( $lType);
my $inter = type2sv( $lType, "$lpr$eptr$incRes$rpr. $lName");
print HEADER "\t\tPUSHs( $mc( $inter));\n";
}
$pphv = $rParms;
} elsif ( exists( $arrays{ $resSub})) {
# array-> array
my $rParms = $arrays{$resSub}[0];
my $lType = $arrays{$resSub}[1];
$lType = $mapTypes{$lType}||$lType;
print HEADER "\t\tEXTEND(sp, $rParms);\n";
my $adx = ( $rParms > 1) ? "\t\t" : "";
print HEADER "\t\t{\n\t\t\tint $incCount;\n"
if $adx;
print HEADER "\t\t\tfor ( $incCount = 0; $incCount < $rParms; ${incCount}++)\n"
if $adx;
my $mc = mortal( $lType);
my $inter = type2sv( $lType, "$lpr$eptr$incRes$rpr\[$incCount\]");
print HEADER "${adx}\tPUSHs( $mc( $inter));\n";
print HEADER "\t\t}\n" if $adx;
$pphv = $rParms;
} elsif ($resSub eq "void") {
# nothing
$pphv = 0;
} else {
# scalars
$pphv = 1;
if ($resSub eq "Handle") {
print HEADER "\t\tif ( $incRes && (( $incInst) $incRes)-> $hMate && ((( $incInst) $incRes)-> $hMate != NULL_SV))\n";
print HEADER "\t\t{\n";
print HEADER "\t\t\tXPUSHs( sv_mortalcopy((( $incInst) $incRes)-> $hMate));\n";
print HEADER "\t\t} else XPUSHs( &PL_sv_undef);\n";
} elsif ($resSub eq "SV*") {
print HEADER "\t\tXPUSHs( sv_2mortal( $incRes));\n";
} else {
print HEADER "\t\tXPUSHs( sv_2mortal( new$xsConv{$resSub}[7]( $incRes$xsConv{$resSub}[5])));\n";
}
};
print HEADER "\t\tpush_hv( ax, sp, items, mark, $pphv, hv);\n\t\treturn;\n"
if $useHV;
print HEADER "\t}\n";
print HEADER $pphv ? "\tPUTBACK;\n\treturn;\n" : "\tXSRETURN_EMPTY;\n";
print HEADER "}\n\n";
( run in 1.182 second using v1.01-cache-2.11-cpan-71847e10f99 )