1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97
|
#package;
use strict;
use warnings;
# 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 ( sort keys %$output )
{
$xsout .= "\t$var\n";
}
$xsout .= "\n\n";
# Add it to the PDL::PP file:
pp_addxs ('', $xsout);
}
} # End of create_low_level()...
1;
|