use strict;
use warnings;

pp_addpm({At => 'Top'}, <<'EOD');
use strict;
use warnings;

=head1 NAME

PDL::IO::HDF::VS - An interface library for HDF4 files.

=head1 SYNOPSIS

  use PDL;
  use PDL::IO::HDF::VS;

   #### no doc for now ####

=head1 DESCRIPTION

This library provides 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 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, sizeofPDL, sdimofPDL, listofPDL);
                int VID
                int nb_records
                int nb_fields
                int interlace_mode
                AV *sizeofPDL
                AV *sdimofPDL
                AV *listofPDL
        PROTOTYPE: @
        CODE:
            unsigned long int total_size = 0;
            int i, j, k;
            for(i=0; i<nb_fields; i++)
            {
                SV **SvTmp1 = av_fetch(sizeofPDL, i, 0);
                int curvalue = SvIV( *SvTmp1 );
                SV **SvTmp3 = av_fetch(sdimofPDL, i, 0);
                int cursdim = SvIV( *SvTmp3 );
                total_size += curvalue * cursdim;
            }
            total_size *= nb_records;
            unsigned char *databuff = (unsigned char *)malloc( total_size );
            if(databuff==NULL)
                croak("memory allocation error");
            unsigned char *ptrbuff = databuff;
            if(interlace_mode == 0)
            {
                for(i=0; i<nb_records; i++)
                {
                    for(j=0; j<nb_fields; j++)
                    {
                        SV **SvTmp2 = av_fetch(listofPDL, j, 0);
                        pdl *curPDL = PDL->SvPDLV( *SvTmp2 );
                        SV **SvTmp3 = av_fetch(sdimofPDL, j, 0);
                        int cursdim = SvIV( *SvTmp3 );
                        SV **SvTmp1 = av_fetch(sizeofPDL, j, 0);
                        int curvalue = SvIV( *SvTmp1 );
                        for(k=0; k<cursdim; k++)
                        {
                            memcpy( ptrbuff, (unsigned char *)(curPDL->data + curvalue*i + curvalue*k*nb_records), curvalue );
                            ptrbuff += curvalue;
                        }
                    }
                }
            }
            else
            {
                for(j=0; j<nb_fields; j++)
                {
                    SV **SvTmp2 = av_fetch(listofPDL, j, 0);
                    pdl *curPDL = PDL->SvPDLV( *SvTmp2 );
                    SV **SvTmp3 = av_fetch(sdimofPDL, j, 0);
                    int cursdim = SvIV( *SvTmp3 );
                    SV **SvTmp1 = av_fetch(sizeofPDL, j, 0);
                    int curvalue = SvIV( *SvTmp1 );
                    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);
            free(databuff);
        OUTPUT:
            RETVAL

SV *
_Vgetname(vgroup_id);
                int vgroup_id
        CODE:
                uint16 len;
                if (Vgetnamelen(vgroup_id, &len)) croak("Failed to get Vgetnamelen for ID=%d", vgroup_id);
                char vgroup_name[len+1];
                Vgetname(vgroup_id,vgroup_name);
                RETVAL = newSVpvn(vgroup_name,len);
        OUTPUT:
                RETVAL

SV *
_VSgetname(vdata_id);
                int vdata_id
        CODE:
                char vdata_name[VGNAMELENMAX];
                VSgetname(vdata_id,vdata_name);
                RETVAL = newSVpv(vdata_name,0);
        OUTPUT:
                RETVAL

SV *
_Vgetclass(vgroup_id);
                int vgroup_id
        CODE:
                uint16 len;
                if (Vgetclassnamelen(vgroup_id, &len)) croak("Failed to get Vgetclassnamelen for ID=%d", vgroup_id);
                char vgroup_class[len+1];
                Vgetclass(vgroup_id,vgroup_class);
                RETVAL = newSVpvn(vgroup_class,len);
        OUTPUT:
                RETVAL

SV *
_VSgetclass(vdata_id);
                int vdata_id
        CODE:
                char vdata_class[VGNAMELENMAX];
                VSgetclass(vdata_id,vdata_class);
                RETVAL = newSVpv(vdata_class,0);
        OUTPUT:
                RETVAL

int
_VSgetfields(vdata_id, fields);
                int vdata_id
                char *fields
        CODE:
                char tmpfields[10000];
                RETVAL=VSgetfields(vdata_id, tmpfields);
                fields = tmpfields;
        OUTPUT:
                RETVAL
                fields

AV *
_VSlone(file_id);
		int file_id;
	CODE:
		AV  *ref_vdata_list=newAV();
		int ref_array[MAX_FIELD_SIZE];
		int32 nlone = VSlone(file_id, ref_array, MAX_FIELD_SIZE);
		int32 i;
		for(i=0;i<nlone;i++){
			av_push(ref_vdata_list, newSViv((IV)ref_array[i]));
		}
		RETVAL=ref_vdata_list;
	OUTPUT:
		RETVAL

void
_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[10000];
        char tmpname[VGNAMELENMAX];
        if (VSinquire(vdata_id, n_records, interlace, tmpfields, vdata_size, tmpname))
            croak("PDL::IO::HDF::VS::_VSinquire (vdata_id=%d)",vdata_id);
        vdata_name=tmpname;
        fields = tmpfields;
OUTPUT:
        n_records
        interlace
        fields
        vdata_size
        vdata_name

ENDOFXS

pp_addpm(<<'EOPM');

use PDL::Primitive;
use PDL::Basic;

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 $vg_name = PDL::IO::HDF::VS::_Vgetname($vg_id);
            $vgroup->{$vg_name}{ref} = $vg_ref;
            $vgroup->{$vg_name}{class} = PDL::IO::HDF::VS::_Vgetclass($vg_id);
            my $n_pairs = PDL::IO::HDF::VS::_Vntagrefs( $vg_id );
            for ( 0 .. $n_pairs-1 )
            {
                my ($tag, $ref);
                my $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 = PDL::IO::HDF::VS::_Vgetname($id);
                    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 = PDL::IO::HDF::VS::_VSgetname( $id );
                    my $class = PDL::IO::HDF::VS::_VSgetclass( $id );
                    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});

	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 $n_records = 0;
            my $interlace = 0;
            my $fields = "";
            my $vdata_size = 0;
            my $vdata_name = "";

            PDL::IO::HDF::VS::_VSinquire(
                            $vdata_id, $n_records, $interlace, $fields, $vdata_size, $vdata_name );
            $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 sort 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 sort keys %{$self->{VGROUP}->{$name}->{children}};
} # End of Vgetattach()...

sub Vgetparents
{
    my ($self, $name) = @_;
    return( undef )
        unless defined( $self->{VGROUP}->{$name}->{parents} );

    return sort keys %{$self->{VGROUP}->{$name}->{parents}};
} # End of Vgetparents()...

sub Vgetmains
{
    my ($self) = @_;
    my @rlist;
    foreach( sort 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 sort 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 sort 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 = "";
    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 );
    }
    my $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), L<PDL>, L<PDL::IO::HDF>.

=cut

EOD

pp_done();