#package;
use strict;
# This file contains functions to build .pd from the HDF prototypes
# Define a low-level perl interface to HDF from these definitions.
sub create_low_level
{
# This file must be modified to only include
# netCDF 3 function definitions.
# Also, all C function declarations must be on one line.
my $defn = shift;
my $sub = "create_low_level()";
my @lines = split (/\n/, $defn);
foreach my $line (@lines)
{
next if ( $line =~ /^\#/ ); # Skip commented out lines
next if ( $line =~ /^\s*$/ ); # Skip blank lines
unless ($line =~ /^(\w+\**)\s+(\w+)\((.+)\)(\+*\d*)\;/)
{
die "$sub: Can't parse this line!\n";
}
my ($return_type, $func_name, $params, $add) = ($1, $2, $3, $4);
my @vars;
my @types;
my $output = {};
foreach my $param ( split (/,/, $params) )
{
my ($varname) = ($param =~ /(\w+)$/);
$param =~ s/$varname//; # parm now contains the full C type
$output->{$varname} = 1
if (($param =~ /\*/) && ($param !~ /const/));
$param =~ s/const //; # get rid of 'const' in C type
$param =~ s/^\s+//;
$param =~ s/\s+$//; # pare off the variable type from 'parm'
push (@vars, $varname);
push (@types, $param);
}
# Create the XS header:
my $xsout = '';
$xsout .= "$return_type\n";
$xsout .= "_$func_name (" . join (", ", @vars) . ")\n";
# Add in the variable declarations:
foreach my $i ( 0 .. $#vars )
{
$xsout .= "\t$types[$i]\t$vars[$i]\n";
}
# Add the CODE section:
$xsout .= "CODE:\n";
$xsout .= "\tRETVAL = ";
$xsout .= "$add + "
if defined($add);
$xsout .= "$func_name (";
# Add more variable stuff:
foreach my $i ( 0 .. $#vars )
{
my $type = $types[$i];
if ($type =~ /PDL/)
{
$type =~ s/PDL//; # Get rid of PDL type when writing xs CODE section
$xsout .= "($type)$vars[$i]"."->data,";
}
else
{
$xsout .= "$vars[$i],";
}
}
chop ($xsout); # remove last comma
$xsout .= ");\n";
# Add the OUTPUT section:
$xsout .= "OUTPUT:\n";
$xsout .= "\tRETVAL\n";
foreach my $var ( keys %$output )
{
$xsout .= "\t$var\n";
}
$xsout .= "\n\n";
# Add it to the PDL::PP file:
pp_addxs ('', $xsout);
}
} # End of create_low_level()...
sub create_generic
{
my $defn = shift;
my @alltype = ('char', 'unsigned char', 'short int', 'unsigned short int',
'long int', 'unsigned long int', 'float', 'double');
my @nametype = ('char', 'uchar', 'short', 'ushort',
'long', 'ulong', 'float', 'double');
foreach my $i ( 0 .. $#alltype )
{
my $xsout = $defn;
$xsout =~ s/GENERIC/$alltype[$i]/eg;
$xsout =~ s/NAME/$nametype[$i]/eg;
pp_addxs ('', $xsout);
}
} # End of create_generic()...
1;