pp_addpm({At => Top}, <<'EOD');
=head1 NAME
PDL::IO::HDF - An interface library for HDF4 files.
=head1 SYNOPSIS
use PDL;
use PDL::IO::HDF::VS;
#### no doc for now ####
=head1 DESCRIPTION
This librairy provide functions to manipulate
HDF4 files with VS and V interface (reading, writing, ...)
For more information on HDF4, see http://www.hdfgroup.org/products/hdf4/
=head1 FUNCTIONS
=cut
EOD
pp_addhdr(<<'EOH');
#include <hdf.h>
#include <mfhdf.h>
#include <string.h>
#include <stdio.h>
#include <perl.h>
#include <EXTERN.h>
#include <XSUB.h>
#define PDLchar pdl
#define PDLuchar pdl
#define PDLshort pdl
#define PDLint pdl
#define PDLlong pdl
#define PDLfloat pdl
#define PDLdouble pdl
#define PDLvoid pdl
#define uchar unsigned char
#define PDLlist pdl
EOH
#define AVRef AV
#pp_bless ("PDL::IO::HDF::VS");
use FindBin;
use lib "$FindBin::Bin/..";
use buildfunc;
#-------------------------------------------------------------------------
# Create low level interface from HDF VS and V header file.
#-------------------------------------------------------------------------
create_low_level (<<'EODEF');
#
# HDF (H) Interface
#
int Hishdf(const char *filename);
int Hopen(const char *filename, int access, int n_dds);
int Hclose(int file_id)+1;
#
# VGROUP/VDATA Interface
#
int Vstart(int hdfid);
int Vend(int hdfid);
int Vgetid(int hdfid, int vgroup_ref);
int Vattach(int hdfid, int vgroup_ref, const char *access);
int Vdetach(int vgroup_id);
int Vntagrefs(int vgroup_id);
int Vgettagref(int vgroup_id, int index, int *tag, int *ref);
int Vinquire(int vgroup_id, int *n_entries, char *vgroup_name);
int Vsetname(int vgroup_id, const char *vgroup_name);
int Vsetclass(int vgroup_id, const char *vgroup_class);
int Visvg(int vgroup_id, int obj_ref);
int Visvs(int vgroup_id, int obj_ref);
int Vaddtagref(int vgroup_id, int tag, int ref);
int Vinsert(int vgroup_id, int v_id);
int VSsetname(int vdata_id, const char *vdata_name);
int VSsetclass(int vdata_id, const char *vdata_class);
int VSgetid(int hdfid, int vdata_ref);
int VSattach(int hdfid, int vdata_ref, const char *access);
int VSdetach(int vdata_id);
int VSelts(int vdata_id);
int VSsizeof(int vdata_id, const char *fields);
int VSfind(int hdfid, const char *vdata_name);
int VFfieldtype(int vdata_id, int field_index);
int VFnfields(int vdata_ref);
int VFfieldorder(int vdata_ref, int field_index);
int VSfdefine(int vata_id, const char *fieldname, int data_type, int order)+1;
int VSsetfields(int vata_id, const char *fieldname_list)+1;
int VSwrite(int vdata_id, const PDLvoid *databuf, int n_records, int interlace_mode);
int VSread(int vdata_id, PDLvoid *databuf, int n_records, int interlace_mode);
#int VSlone(int file_id, int *ref_array, int max_ref);
int VSfnattrs(int vdata_id, int field_index);
int VSgetattr(int vdata_id, int field_index, int attr_index, PDLlong *values);
int VSisattr(int vdata_id);
int SDstart(const char *filename, int access_mode);
int SDreftoindex(int sd_id, int sds_ref);
int SDselect(int sd_id, int index);
int SDgetinfo(int sds_id, char *sds_name, int *rank, int *dimsizes, int *number_type, int *nattrs);
int SDendaccess(int sds_id);
int SDend(int sd_id);
EODEF
pp_addxs('',<<'ENDOFXS');
int
_WriteMultPDL(VID, nb_records, nb_fields, interlace_mode, ...);
int VID
int nb_records
int nb_fields
int interlace_mode
PROTOTYPE: @
CODE:
unsigned char *databuff, *ptrbuff;
unsigned long int total_size;
int i, j, k, curvalue, cursdim;
SV * sizeofPDL;
SV * listofPDL;
SV * sdimofPDL;
SV * * SvTmp1, * * SvTmp2, * * SvTmp3;
pdl *curPDL;
sizeofPDL = SvRV( ST(4) );
sdimofPDL = SvRV( ST(5) );
listofPDL = SvRV( ST(6) );
total_size = 0;
for(i=0; i<nb_fields; i++)
{
SvTmp1 = av_fetch((AV*)sizeofPDL, i, 0);
curvalue = SvIV( *SvTmp1 );
SvTmp3 = av_fetch((AV*)sdimofPDL, i, 0);
cursdim = SvIV( *SvTmp3 );
total_size += curvalue * cursdim;
}
total_size *= nb_records;
databuff = (unsigned char *)malloc( total_size );
if(databuff==NULL)
croak("memory allocation error");
ptrbuff = databuff;
if(interlace_mode == 0)
{
for(i=0; i<nb_records; i++)
{
for(j=0; j<nb_fields; j++)
{
SvTmp2 = av_fetch((AV*)listofPDL, j, 0);
curPDL = PDL->SvPDLV( *SvTmp2 );
SvTmp3 = av_fetch((AV*)sdimofPDL, j, 0);
cursdim = SvIV( *SvTmp3 );
SvTmp1 = av_fetch((AV*)sizeofPDL, j, 0);
curvalue = SvIV( *SvTmp1 );
for(k=0; k<cursdim; k++)
{
#printf("Value %d= %d\n", k, *(int *)(curPDL->data + curvalue*i + curvalue*k*nb_records));
memcpy( ptrbuff, (unsigned char *)(curPDL->data + curvalue*i + curvalue*k*nb_records), curvalue );
#printf("Value %d=%d\n", k, *(int *)(curPDL->data + curvalue*i*cursdim + curvalue*k));
#memcpy( ptrbuff, (unsigned char *)(curPDL->data + curvalue*i*cursdim + curvalue*k), curvalue );
#printf("buffer %d= %d\n", k, *(int *)ptrbuff);
ptrbuff += curvalue;
}
}
}
}
else
{
for(j=0; j<nb_fields; j++)
{
SvTmp2 = av_fetch((AV*)listofPDL, j, 0);
curPDL = PDL->SvPDLV( *SvTmp2 );
SvTmp1 = av_fetch((AV*)sizeofPDL, j, 0);
curvalue = SvIV( *SvTmp1 );
SvTmp3 = av_fetch((AV*)sdimofPDL, j, 0);
cursdim = SvIV( *SvTmp3 );
memcpy( ptrbuff, (unsigned char *)(curPDL->data), curvalue*nb_records*cursdim );
ptrbuff += curvalue*nb_records*cursdim;
#printf("buffer %d= %d\n", k, curvalue*nb_records*cursdim);
}
interlace_mode = 1;
}
fprintf(stderr, "Calling VSwrite(VID=%d, databuff=%p, nb_records=%d, interlace_mode=%d)...\n",
VID, databuff, nb_records, interlace_mode);
RETVAL = VSwrite(VID, databuff, nb_records, interlace_mode);
OUTPUT:
RETVAL
void
_Vgetname(vgroup_id, vgroup_name);
int vgroup_id
char *vgroup_name
CODE:
vgroup_name=(char *)malloc(VGNAMELENMAX);
Vgetname(vgroup_id,vgroup_name);
OUTPUT:
vgroup_name
void
_VSgetname(vdata_id, vdata_name);
int vdata_id
char *vdata_name
CODE:
vdata_name=(char *)malloc(VGNAMELENMAX*sizeof(char));
VSgetname(vdata_id,vdata_name);
OUTPUT:
vdata_name
void
_Vgetclass(vgroup_id, vgroup_class);
int vgroup_id
char *vgroup_class
CODE:
vgroup_class=(char *)malloc(VGNAMELENMAX*sizeof(char));
Vgetclass(vgroup_id,vgroup_class);
OUTPUT:
vgroup_class
void
_VSgetclass(vdata_id, vdata_class);
int vdata_id
char *vdata_class
CODE:
vdata_class=(char *)malloc(VGNAMELENMAX*sizeof(char));
VSgetclass(vdata_id,vdata_class);
OUTPUT:
vdata_class
int
_VSgetfields(vdata_id, fields);
int vdata_id
char *fields
CODE:
char *tmpfields;
int len;
tmpfields=(char *)malloc(10000*sizeof(char));
RETVAL=VSgetfields(vdata_id, tmpfields);
len=strlen(tmpfields);
fields=(char *)malloc(len*sizeof(char)+1);
strcpy(fields,tmpfields);
OUTPUT:
RETVAL
fields
AV *
_VSlone(file_id);
int file_id;
CODE:
AV *ref_vdata_list;
int *ref_array;
SV *ref_vdata;
int32 nlone;
ref_vdata_list=newAV();
ref_array=(int *)malloc(MAX_FIELD_SIZE*sizeof(int));
nlone = VSlone(file_id, ref_array, MAX_FIELD_SIZE);
int32 i;
for(i=0;i<nlone;i++){
ref_vdata=newSViv((IV)ref_array[i]);
av_push(ref_vdata_list, ref_vdata);
}
RETVAL=ref_vdata_list;
OUTPUT:
RETVAL
int
_VSinquire(vdata_id, n_records, interlace, fields, vdata_size, vdata_name);
int vdata_id
int *n_records
int *interlace
char *fields
int *vdata_size
char *vdata_name
CODE:
char *tmpfields;
int len;
vdata_name=(char *)malloc(VGNAMELENMAX*sizeof(char));
tmpfields=(char *)malloc(10000*sizeof(char));
RETVAL=VSinquire(vdata_id, n_records, interlace, tmpfields, vdata_size, vdata_name)+1;
len=strlen(tmpfields);
fields=(char *)malloc(len*sizeof(char)+1);
strcpy(fields,tmpfields);
OUTPUT:
RETVAL
n_records
interlace
fields
vdata_size
vdata_name
ENDOFXS
pp_addpm(<<'EOPM');
use PDL::Primitive;
use PDL::Basic;
use strict;
use PDL::IO::HDF;
my $TMAP = {
PDL::byte->[0] => 1,
PDL::short->[0] => 2,
PDL::ushort->[0] => 2,
PDL::long->[0] => 4,
PDL::float->[0] => 4,
PDL::double->[0] => 8
};
sub _pkg_name
{ return "PDL::IO::HDF::VS::" . shift() . "()"; }
=head2 new
=for ref
Open or create a new HDF object with VS and V interface.
=for usage
Arguments:
1 : The name of the HDF file.
If you want to write to it, prepend the name with the '+' character : "+name.hdf"
If you want to create it, prepend the name with the '-' character : "-name.hdf"
Otherwise the file will be opened in read only mode.
Returns the hdf object (die on error)
=for example
my $hdf = PDL::IO::HDF::VS->new("file.hdf");
=cut
sub new
{
# general
my $type = shift;
my $filename = shift;
my $self = {};
if (substr($filename, 0, 1) eq '+')
{ # open for writing
$filename = substr ($filename, 1); # chop off +
$self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_WRITE + PDL::IO::HDF->DFACC_READ;
}
if (substr($filename, 0, 1) eq '-')
{ # Creating
$filename = substr ($filename, 1); # chop off -
$self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_CREATE;
}
unless( defined($self->{ACCESS_MODE}) )
{
$self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_READ;
}
$self->{FILE_NAME} = $filename;
$self->{HID} = PDL::IO::HDF::VS::_Hopen( $self->{FILE_NAME}, $self->{ACCESS_MODE}, 20 );
if ($self->{HID})
{
PDL::IO::HDF::VS::_Vstart( $self->{HID} );
my $SDID = PDL::IO::HDF::VS::_SDstart( $self->{FILE_NAME}, $self->{ACCESS_MODE} );
#### search for vgroup
my $vgroup = {};
my $vg_ref = -1;
while( ($vg_ref = PDL::IO::HDF::VS::_Vgetid( $self->{HID}, $vg_ref )) != PDL::IO::HDF->FAIL)
{
my $vg_id = PDL::IO::HDF::VS::_Vattach( $self->{HID}, $vg_ref, 'r' );
my $n_entries = 0;
my $vg_name = " "x(PDL::IO::HDF->VNAMELENMAX+1);
my $res = PDL::IO::HDF::VS::_Vinquire( $vg_id, $n_entries, $vg_name );
my $vg_class = "";
PDL::IO::HDF::VS::_Vgetclass( $vg_id, $vg_class );
$vgroup->{$vg_name}->{ref} = $vg_ref;
$vgroup->{$vg_name}->{class} = $vg_class;
my $n_pairs = PDL::IO::HDF::VS::_Vntagrefs( $vg_id );
for ( 0 .. $n_pairs-1 )
{
my ($tag, $ref);
$res = PDL::IO::HDF::VS::_Vgettagref( $vg_id, $_, $tag = 0, $ref = 0 );
if($tag == 1965)
{ # Vgroup
my $id = PDL::IO::HDF::VS::_Vattach( $self->{HID}, $ref, 'r' );
my $name = " "x(PDL::IO::HDF->VNAMELENMAX+1);
my $res = PDL::IO::HDF::VS::_Vgetname( $id, $name );
PDL::IO::HDF::VS::_Vdetach( $id );
$vgroup->{$vg_name}->{children}->{$name} = $ref;
$vgroup->{$name}->{parents}->{$vg_name} = $vg_ref;
}
elsif($tag == 1962)
{ # Vdata
my $id = PDL::IO::HDF::VS::_VSattach( $self->{HID}, $ref, 'r' );
my $name = " "x(PDL::IO::HDF->VNAMELENMAX+1);
my $res = PDL::IO::HDF::VS::_VSgetname( $id, $name );
my $class = "";
PDL::IO::HDF::VS::_VSgetclass( $id, $class );
PDL::IO::HDF::VS::_VSdetach( $id );
$vgroup->{$vg_name}->{attach}->{$name}->{type} = 'VData';
$vgroup->{$vg_name}->{attach}->{$name}->{ref} = $ref;
$vgroup->{$vg_name}->{attach}->{$name}->{class} = $class
if( $class ne '' );
}
if( ($SDID != PDL::IO::HDF->FAIL) && ($tag == 720)) #tag for SDS tag/ref (see 702)
{
my $i = _SDreftoindex( $SDID, $ref );
my $sds_ID = _SDselect( $SDID, $i );
my $name = " "x(PDL::IO::HDF->MAX_NC_NAME+1);
my $rank = 0;
my $dimsize = " "x( (4 * PDL::IO::HDF->MAX_VAR_DIMS) + 1 );
my $numtype = 0;
my $nattrs = 0;
$res = _SDgetinfo( $sds_ID, $name, $rank, $dimsize , $numtype, $nattrs );
$vgroup->{$vg_name}->{attach}->{$name}->{type} = 'SDS_Data';
$vgroup->{$vg_name}->{attach}->{$name}->{ref} = $ref;
}
} # for each pair...
PDL::IO::HDF::VS::_Vdetach( $vg_id );
} # while vg_ref...
PDL::IO::HDF::VS::_SDend( $SDID );
$self->{VGROUP} = $vgroup;
#### search for vdata
my $vdata_ref=-1;
my $vdata_id=-1;
my $vdata = {};
# get lone vdata (not member of a vgroup)
my $lone=PDL::IO::HDF::VS::_VSlone($self->{HID});
my $MAX_REF = 0;
while ( $vdata_ref = shift @$lone )
{
my $mode="r";
if ( $self->{ACCESS_MODE} != PDL::IO::HDF->DFACC_READ )
{
$mode="w";
}
$vdata_id = PDL::IO::HDF::VS::_VSattach( $self->{HID}, $vdata_ref, $mode );
my $vdata_size = 0;
my $n_records = 0;
my $interlace = 0;
my $fields = "";
my $vdata_name = "";
my $status = PDL::IO::HDF::VS::_VSinquire(
$vdata_id, $n_records, $interlace, $fields, $vdata_size, $vdata_name );
die "PDL::IO::HDF::VS::_VSinquire (vdata_id=$vdata_id)"
unless $status;
$vdata->{$vdata_name}->{REF} = $vdata_ref;
$vdata->{$vdata_name}->{NREC} = $n_records;
$vdata->{$vdata_name}->{INTERLACE} = $interlace;
$vdata->{$vdata_name}->{ISATTR} = PDL::IO::HDF::VS::_VSisattr( $vdata_id );
my $field_index = 0;
foreach my $onefield ( split( ",", $fields ) )
{
$vdata->{$vdata_name}->{FIELDS}->{$onefield}->{TYPE} =
PDL::IO::HDF::VS::_VFfieldtype( $vdata_id, $field_index );
$vdata->{$vdata_name}->{FIELDS}->{$onefield}->{INDEX} = $field_index;
$field_index++;
}
PDL::IO::HDF::VS::_VSdetach( $vdata_id );
} # while vdata_ref...
$self->{VDATA} = $vdata;
} # if $self->{HDID}...
bless($self, $type);
} # End of new()...
sub Vgetchildren
{
my ($self, $name) = @_;
return( undef )
unless defined( $self->{VGROUP}->{$name}->{children} );
return keys %{$self->{VGROUP}->{$name}->{children}};
} # End of Vgetchildren()...
# Now defunct:
sub Vgetchilds
{
my $self = shift;
return $self->Vgetchildren( @_ );
} # End of Vgetchilds()...
sub Vgetattach
{
my ($self, $name) = @_;
return( undef )
unless defined( $self->{VGROUP}->{$name}->{attach} );
return keys %{$self->{VGROUP}->{$name}->{children}};
} # End of Vgetattach()...
sub Vgetparents
{
my ($self, $name) = @_;
return( undef )
unless defined( $self->{VGROUP}->{$name}->{parents} );
return keys %{$self->{VGROUP}->{$name}->{parents}};
} # End of Vgetparents()...
sub Vgetmains
{
my ($self) = @_;
my @rlist;
foreach( keys %{$self->{VGROUP}} )
{
push(@rlist, $_)
unless defined( $self->{VGROUP}->{$_}->{parents} );
}
return @rlist;
} # End of Vgetmains()...
sub Vcreate
{
my($self, $name, $class, $where) = @_;
my $id = PDL::IO::HDF::VS::_Vattach( $self->{HID}, -1, 'w' );
return( undef )
if( $id == PDL::IO::HDF->FAIL );
my $res = _Vsetname($id, $name);
$res = _Vsetclass($id, $class)
if defined( $class );
$self->{VGROUP}->{$name}->{ref} = '???';
$self->{VGROUP}->{$name}->{class} = $class
if defined( $class );
if( defined( $where ) )
{
return( undef )
unless defined( $self->{VGROUP}->{$where} );
my $ref = $self->{VGROUP}->{$where}->{ref};
my $Pid = PDL::IO::HDF::VS::_Vattach( $self->{HID}, $ref, 'w' );
my $index = PDL::IO::HDF::VS::_Vinsert( $Pid, $id );
my ($t, $r) = (0, 0);
$res = PDL::IO::HDF::VS::_Vgettagref( $Pid, $index, $t, $r );
PDL::IO::HDF::VS::_Vdetach( $Pid );
$self->{VGROUP}->{$name}->{parents}->{$where} = $ref;
$self->{VGROUP}->{$where}->{children}->{$name} = $r;
$self->{VGROUP}->{$name}->{ref} = $r;
}
return( _Vdetach( $id ) + 1 );
} # End of Vcreate()...
=head2 close
=for ref
Close the VS interface.
=for usage
no arguments
=for example
my $result = $hdf->close();
=cut
sub close
{
my $self = shift;
_Vend( $self->{HID} );
my $Hid = $self->{HID};
$self = undef;
return( _Hclose($Hid) + 1 );
} # End of close()...
sub VSisattr
{
my($self, $name) = @_;
return undef
unless defined( $self->{VDATA}->{$name} );
return $self->{VDATA}->{$name}->{ISATTR};
} # End of VSisattr()...
sub VSgetnames
{
my $self = shift;
return keys %{$self->{VDATA}};
} # End of VSgetnames()...
sub VSgetfieldnames
{
my ( $self, $name ) = @_;
my $sub = _pkg_name( 'VSgetfieldnames' );
die "$sub: vdata name $name doesn't exist!\n"
unless defined( $self->{VDATA}->{$name} );
return keys %{$self->{VDATA}->{$name}->{FIELDS}};
} # End of VSgetfieldnames()...
# Now defunct:
sub VSgetfieldsnames
{
my $self = shift;
return $self->VSgetfieldnames( @_ );
} # End of VSgetfieldsnames()...
sub VSread
{
my ( $self, $name, $field ) = @_;
my $sub = _pkg_name( 'VSread' );
my $data = null;
my $vdata_ref = PDL::IO::HDF::VS::_VSfind( $self->{HID}, $name );
die "$sub: vdata name $name doesn't exist!\n"
unless $vdata_ref;
my $vdata_id = PDL::IO::HDF::VS::_VSattach( $self->{HID}, $vdata_ref, 'r' );
my $vdata_size = 0;
my $n_records = 0;
my $interlace = 0;
my $fields = "";
my $vdata_name = "";
my $status = PDL::IO::HDF::VS::_VSinquire(
$vdata_id, $n_records, $interlace, $fields, $vdata_size, $vdata_name );
my $data_type = PDL::IO::HDF::VS::_VFfieldtype(
$vdata_id, $self->{VDATA}->{$name}->{FIELDS}->{$field}->{INDEX} );
die "$sub: data_type $data_type not implemented!\n"
unless defined( $PDL::IO::HDF::SDinvtypeTMAP->{$data_type} );
my $order = PDL::IO::HDF::VS::_VFfieldorder(
$vdata_id, $self->{VDATA}->{$name}->{FIELDS}->{$field}->{INDEX} );
if($order == 1)
{
$data = ones( $PDL::IO::HDF::SDinvtypeTMAP2->{$data_type}, $n_records );
}
else
{
$data = ones( $PDL::IO::HDF::SDinvtypeTMAP2->{$data_type}, $n_records, $order );
}
$status = PDL::IO::HDF::VS::_VSsetfields( $vdata_id, $field );
die "$sub: _VSsetfields\n"
unless $status;
$status = PDL::IO::HDF::VS::_VSread( $vdata_id, $data, $n_records, $interlace);
PDL::IO::HDF::VS::_VSdetach( $vdata_id );
return $data;
} # End of VSread()...
sub VSwrite
{
my($self, $name, $mode, $field, $value) = @_;
return( undef )
if( $$value[0]->getndims > 2); #too many dims
my $VD_id;
my $res;
my @foo = split( /:/, $name );
return( undef )
if defined( $self->{VDATA}->{$foo[0]} );
$VD_id = _VSattach( $self->{HID}, -1, 'w' );
return( undef )
if( $VD_id == PDL::IO::HDF->FAIL );
$res = _VSsetname( $VD_id, $foo[0] );
return( undef )
if( $res == PDL::IO::HDF->FAIL );
$res = _VSsetclass( $VD_id, $foo[1] )
if defined( $foo[1] );
return( undef )
if( $res == PDL::IO::HDF->FAIL );
my @listfield = split( /,/, $field );
for( my $i = 0; $i <= $#$value; $i++ )
{
my $HDFtype = $PDL::IO::HDF::SDtypeTMAP->{$$value[$i]->get_datatype()};
$res = _VSfdefine( $VD_id, $listfield[$i], $HDFtype, $$value[$i]->getdim(1) );
return( undef )
unless $res;
}
$res = _VSsetfields( $VD_id, $field );
return( undef )
unless $res;
my @sizeofPDL;
my @sdimofPDL;
foreach ( @$value )
{
push(@sdimofPDL, $_->getdim(1));
push(@sizeofPDL, $TMAP->{$_->get_datatype()});
}
$res = _WriteMultPDL( $VD_id, $$value[0]->getdim(0), $#$value+1, $mode, \@sizeofPDL, \@sdimofPDL, $value);
return( undef )
if( _VSdetach($VD_id) == PDL::IO::HDF->FAIL );
return $res;
} # End of VSwrite()...
sub DESTROY
{
my $self = shift;
$self->close;
} # End of DESTROY()...
EOPM
#
# Add the tail of the docs:
#
pp_addpm(<<'EOD');
=head1 CURRENT AUTHOR & MAINTAINER
Judd Taylor, Orbital Systems, Ltd.
judd dot t at orbitalsystems dot com
=head1 PREVIOUS AUTHORS
Olivier Archer olivier.archer@ifremer.fr
contribs of Patrick Leilde patrick.leilde@ifremer.fr
=head1 SEE ALSO
perl(1), PDL(1), PDL::IO::HDF(1).
=cut
EOD
pp_done();