Graphics-VTK
view release on metacpan or search on metacpan
# $c_args List of args to call the c-function with
# $outputs List of args that should be be in the output list
# listSize size to list to be returned. 0 of undef if no list is
# to be returned
# funcArg Defined with the arg name if this is a function that has function pointer args (like 'SetExecuteMethod', etc)
# argDims dims of any args. used to create an initialization section
# e.g. if an arg2 has dims 2, then an initialization section will
# be created double arg2[] = { arg2_0, arg2_1 };
# argTypes types of the args
#
# supplyThis Flag = classname if we need to manually supply the 'THIS' variable in the preinit section of this function
# This is needed for an overloaded method that is defined as an overall static method, but has some overloaded
# methods that are non-static.
sub writeXScode{
my($classInfo, $returnType, $funcName, $funct, $returnTypeNeedsAddress,
$c_args, $outputs, $listSize, $funcArg, $arg_dims, $arg_types, $supplyThis) = @_;
$arg_dims ||= []; # default value for arg dims
$arg_types ||= []; # default value for arg dims
my @preInitLines; # any pre-init section lines
# If this function returns a class (and is not the 'New' method, supply the preinit XS section to make the CLASS
# variable equal to the class returned:
my $returnClass;
if( ($returnClass = $classInfo->{functions}{$funcName}{ReturnClass}) ne 'None'
&& $returnType =~ /^vtk\S+/ && $funct ne 'New'){
push @preInitLines, "\t\tchar CLASS[80] = \"Graphics::VTK\:\:$returnClass\"\;";
}
if( $listSize ){ # We need to return a list:
push @preInitLines, "\t\t$returnType retval;";
}
if( $supplyThis && $returnType !~ /\bstatic\b/){ # this is a non-static method, with a static overall xs return type
push @preInitLines, "\t\tvtk$supplyThis * THIS;";
push @preInitLines, "\t\tif( sv_isobject(ST(0)) && (SvTYPE(SvRV(ST(0))) == SVt_PVMG) )";
push @preInitLines, "\t\t\tif (sv_derived_from(ST(0), \"Graphics::VTK::$supplyThis\")) {";
push @preInitLines, "\t\t\t\tTHIS = (vtk$supplyThis *)SvIV((SV*)SvRV( ST(0) ));";
push @preInitLines, "\t\t\t}";
push @preInitLines, "\t\t\telse{";
push @preInitLines, "\t\t\t\tcroak(\"Graphics::VTK::$supplyThis::$funct() -- THIS not of type Graphics::VTK::$supplyThis\");";
push @preInitLines, "\t\t\t}";
push @preInitLines, "\t\telse{";
push @preInitLines, "\t\t\twarn( \"Graphics::VTK::$supplyThis::$funct() -- THIS is not a blessed SV reference\" );";
push @preInitLines, "\t\t\tXSRETURN_UNDEF;";
push @preInitLines, "\t\t};";
}
if( @preInitLines ){
print join("\n", ("\t\tPREINIT:", @preInitLines))."\n";
}
my $retValText = "RETVAL";
if( $listSize){ # Returning a list:
$retValText = "retval";
# We are emulating a 'PPCODE' section with 'CODE' text because
# xsubpp doesn't like multiple CASE's with PPCODEs in them.
print "\t\tCODE:\n";
print "\t\tSP -= items;\n\t\t";
}
else{
print "\t\tCODE:\n\t\t";
}
# Check for needing a initialization due to args dims
my $indx = 0;
foreach my $c_arg(@$c_args){
if( $arg_dims->[$indx] && $arg_dims->[$indx] > 1){
my $type = $arg_types->[$indx];
$type =~ s/\*\s*$//g; # get rid of any pointer '*' for the initialization code
print "$type $c_arg\[\] = ";
my @subArgs = map $c_arg."_$_", (0..($arg_dims->[$indx]-1));
print "{ ".join(", ",@subArgs)."};\n\t\t";
}
$indx++;
}
# Check for function pointer arg:
if( $funcArg){ # output function arg stuff:
print"HV * methodHash;
HV * HashEntry;
HE * tempHE;
HV * tempHV;
/* put a copy of the callback in the executeMethodList hash */
methodHash = perl_get_hv(\"Graphics::VTK::Object::executeMethodList\", FALSE);
if (methodHash == (HV*)NULL)
printf(\"Graphics::VTK::executeMethodList hash doesn't exist???\\n\");
else{
tempHE = hv_fetch_ent(methodHash, ST(0), 0,0);
if( tempHE == (HE*)NULL ) { /* Entry doesn't exist (i.e. we didn't create it, make an entry for it */
tempHV = newHV(); /* Create empty hash ref and put in executeMethodList */
hv_store_ent(methodHash, ST(0), newRV_inc((SV*) tempHV), 0);
}
HashEntry = (HV *) SvRV(HeVAL(hv_fetch_ent(methodHash, ST(0), 0,0)));
hv_store_ent(HashEntry, newSVpv(\"$funcName\",0), newRV($funcArg), 0);
}\n\t\t";
unshift @$c_args, 'callperlsub'; # add the call perlsub infront of the c_args
}
if( $returnType !~ /^\s*(static\s+)?void\s*$/){
print "$retValText = ";
}
if( $funct ne 'New' && $returnType !~ /^\s*static/ ){ # use THIS->func unless this is the constructor, or static method
if( $returnTypeNeedsAddress){ # return type needs to be turned into adress
print '&(THIS)';
}
else{ # return type is already what it needs to be
print 'THIS';
}
print "->".$funct."(".join(", ",@$c_args).");\n";
}
else{
print "$className\:\:".$funct."(".join(", ",@$c_args).");\n";
}
# If returning a class, modify the class name to get what is actually being
# This will properly bless the object returned into the correct class.
# For example vtkCullerCollection->GetNextItem returns a vtkCuller object, but
# it could also return a object that is a subclass of vtkCuller, but including
# the following code, we get the real class name of the return class
# (+3 added to the pointer to not pick up the leading 'vtk' in the classname
if( $returnClass ne 'None'
&& $returnType =~ /^vtk\S+/ && $funct ne 'New'){
print "\t\tif(RETVAL != NULL){\n\t\t\tstrcpy(CLASS,\"Graphics::VTK::\")\;\n\t\t\tstrcat(CLASS,RETVAL->GetClassName()+3)\;\n\t\t}\n";
}
#
if( $listSize ){ # Returning a list
# Get the base type from the return type (i.e. without the *)
my $baseType = $returnType;
$baseType =~ s/\*//g;
$baseType =~ s/^\s+//g; # get rid of leading/trailing whitespace
$baseType =~ s/\s+$//g;
# XS macro used to turn the return type
# into a perl scalar value
my $XSmacro;
if( $baseType =~ /int/ && $baseType =~ /char/){
$XSmacro = 'newSViv';
}
else{
$XSmacro = 'newSVnv';
}
print "\t\tEXTEND(SP, $listSize);\n";
foreach ( ( 0..($listSize-1))){
print "\t\tPUSHs(sv_2mortal(".$XSmacro."(retval[".$_."])));\n"
}
# This stuff is needed because we are emulating a PPCODE section
# using a CODE section, because xsubpp doesn't like multiple CASE's with PPCODEs in them.
print "\t\tPUTBACK;\n";
print "\t\treturn;\n";
}
elsif( $returnType =~ /^\s*(static\s+)?void$/){
print "\t\tXSRETURN_EMPTY;\n";
}
else{
push @$outputs, 'RETVAL';
}
print "\t\tOUTPUT:\n\t\t".join("\n\t\t", @$outputs)."\n" if( @$outputs);
}
#
# Sub to take a list of arg types for some functions
# (Assumed to be the same number of args), and find
# which arg numbers are unique across all the funcs supplied
#
# Input Data is of the form:
# ( FunctionName => [ Arg Types])
# $funcTypes = {
# 'func1' => [ qw/ int vtkDude double / ],
# 'func1_' => [ qw/ int double vtkDude / ],
# 'func1__' => [ qw/ int vtkDude double / ]
# };
# Output Data is of the form:
# $uniqueArgs = {
# 'func1' => { } # nothing unique
# 'func2' => { 2 => double, 3 => vtkDude } # args 2 and 3 unique
# 'func3' => { } # nothing unique
sub findUniqueArgs{
my $funcTypes = shift;
# Get the number of args, and the number of funcs
my @funcs = keys %$funcTypes;
my $noArgs = scalar( @{$funcTypes->{$funcs[0]}});
my $noFuncs = scalar(@funcs);
my $uniqueArgs = {}; # setup output hash
foreach (@funcs){ $uniqueArgs->{$_} = {} };
# Go thru each arg, and thru each funcs
foreach my $argNo(1..$noArgs){
# Get all the types for this arg Number
my @types = map $funcTypes->{$_}[$argNo-1], @funcs;
my %typeCount; # hash of the occurences of the type
foreach (@types){
$typeCount{$_}++;
}
# Now mark the unique ones
foreach my $func(@funcs){
my $type = $funcTypes->{$func}[$argNo-1];
if( $typeCount{$type} ==1){ # Unique Arg
$uniqueArgs->{$func}{$argNo} = $type;
( run in 0.660 second using v1.01-cache-2.11-cpan-5511b514fd6 )