"Fossies" - the Fresh Open Source Software Archive

Member "PDL-2.025/IO/HDF/VS/VS.pd" (19 Nov 2020, 22918 Bytes) of package /linux/misc/PDL-2.025.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) C and C++ source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "VS.pd": 2.024_vs_2.025.

    1 pp_addpm({At => Top}, <<'EOD');
    2 
    3 =head1 NAME 
    4 
    5 PDL::IO::HDF - An interface library for HDF4 files.
    6 
    7 =head1 SYNOPSIS
    8 
    9   use PDL;
   10   use PDL::IO::HDF::VS;
   11         
   12    #### no doc for now ####
   13 
   14 =head1 DESCRIPTION
   15 
   16 This library provides functions to manipulate
   17 HDF4 files with VS and V interface (reading, writing, ...)
   18 
   19 For more information on HDF4, see http://www.hdfgroup.org/products/hdf4/
   20 
   21 =head1 FUNCTIONS
   22 
   23 =cut
   24 
   25 EOD
   26 
   27 
   28 pp_addhdr(<<'EOH');
   29 
   30 #include <hdf.h>
   31 #include <mfhdf.h>
   32 #include <string.h>
   33 #include <stdio.h>
   34 
   35 #include <perl.h>
   36 #include <EXTERN.h>
   37 #include <XSUB.h>
   38 
   39 #define PDLchar pdl
   40 #define PDLuchar pdl
   41 #define PDLshort pdl
   42 #define PDLint pdl
   43 #define PDLlong pdl
   44 #define PDLfloat pdl
   45 #define PDLdouble pdl
   46 #define PDLvoid pdl
   47 #define uchar unsigned char
   48 
   49 #define PDLlist pdl
   50 
   51 EOH
   52 
   53 #define AVRef AV
   54 #pp_bless ("PDL::IO::HDF::VS");
   55 
   56 use FindBin;
   57 use lib "$FindBin::Bin/..";
   58 use buildfunc;
   59 
   60 
   61 #-------------------------------------------------------------------------
   62 # Create low level interface from HDF VS and V header file.
   63 #-------------------------------------------------------------------------
   64 
   65 create_low_level (<<'EODEF');
   66 #
   67 # HDF (H) Interface
   68 #
   69 int Hishdf(const char *filename);
   70 int Hopen(const char *filename, int access, int n_dds);
   71 int Hclose(int file_id)+1;
   72 #
   73 # VGROUP/VDATA Interface
   74 #
   75 int Vstart(int hdfid);
   76 int Vend(int hdfid);
   77 int Vgetid(int hdfid, int vgroup_ref);
   78 int Vattach(int hdfid, int vgroup_ref, const char *access);
   79 int Vdetach(int vgroup_id);
   80 int Vntagrefs(int vgroup_id);
   81 
   82 int Vgettagref(int vgroup_id, int index, int *tag, int *ref);
   83 int Vinquire(int vgroup_id, int *n_entries, char *vgroup_name);
   84 
   85 int Vsetname(int vgroup_id, const char *vgroup_name);
   86 int Vsetclass(int vgroup_id, const char *vgroup_class);
   87 int Visvg(int vgroup_id, int obj_ref);
   88 int Visvs(int vgroup_id, int obj_ref);
   89 int Vaddtagref(int vgroup_id, int tag, int ref);
   90 int Vinsert(int vgroup_id, int v_id);
   91 
   92 int VSsetname(int vdata_id, const char *vdata_name);
   93 int VSsetclass(int vdata_id, const char *vdata_class);
   94 int VSgetid(int hdfid, int vdata_ref);
   95 int VSattach(int hdfid, int vdata_ref, const char *access);
   96 int VSdetach(int vdata_id);
   97 int VSelts(int vdata_id);
   98 int VSsizeof(int vdata_id, const char *fields);
   99 int VSfind(int hdfid, const char *vdata_name);
  100 int VFfieldtype(int vdata_id, int field_index);
  101 int VFnfields(int vdata_ref);
  102 int VFfieldorder(int vdata_ref, int field_index);
  103 
  104 int VSfdefine(int vata_id, const char *fieldname, int data_type, int order)+1;
  105 int VSsetfields(int vata_id, const char *fieldname_list)+1;
  106 int VSwrite(int vdata_id, const PDLvoid *databuf, int n_records, int interlace_mode);
  107 int VSread(int vdata_id, PDLvoid *databuf, int n_records, int interlace_mode);
  108 #int VSlone(int file_id, int *ref_array, int max_ref);
  109 
  110 int VSfnattrs(int vdata_id, int field_index);
  111 int VSgetattr(int vdata_id, int field_index, int attr_index, PDLlong *values);
  112 int VSisattr(int vdata_id);
  113 
  114 int SDstart(const char *filename, int access_mode);
  115 int SDreftoindex(int sd_id, int sds_ref);
  116 int SDselect(int sd_id, int index);
  117 int SDgetinfo(int sds_id, char *sds_name, int *rank, int *dimsizes, int *number_type, int *nattrs);
  118 int SDendaccess(int sds_id);
  119 int SDend(int sd_id);
  120 
  121 EODEF
  122 
  123 pp_addxs('',<<'ENDOFXS');
  124 
  125 int
  126 _WriteMultPDL(VID, nb_records, nb_fields, interlace_mode, ...);
  127                 int VID
  128                 int nb_records
  129                 int nb_fields
  130                 int interlace_mode
  131         PROTOTYPE: @
  132         CODE:
  133             unsigned char *databuff, *ptrbuff;
  134             unsigned long int total_size;
  135             int i, j, k, curvalue, cursdim;
  136             SV * sizeofPDL;
  137             SV * listofPDL;
  138             SV * sdimofPDL;
  139             SV * * SvTmp1, * * SvTmp2, * * SvTmp3;
  140             pdl *curPDL;
  141 
  142             sizeofPDL = SvRV( ST(4) );
  143             sdimofPDL = SvRV( ST(5) );
  144             listofPDL = SvRV( ST(6) );
  145 
  146             total_size = 0;
  147             for(i=0; i<nb_fields; i++)
  148             {
  149                 SvTmp1 = av_fetch((AV*)sizeofPDL, i, 0);
  150                 curvalue = SvIV( *SvTmp1 );
  151 
  152                 SvTmp3 = av_fetch((AV*)sdimofPDL, i, 0);
  153                 cursdim = SvIV( *SvTmp3 );
  154 
  155                 total_size += curvalue * cursdim;
  156             }
  157 
  158             total_size *= nb_records;
  159             databuff = (unsigned char *)malloc( total_size );
  160             if(databuff==NULL)
  161                 croak("memory allocation error");
  162             ptrbuff = databuff;
  163 
  164             if(interlace_mode == 0)
  165             {
  166                 for(i=0; i<nb_records; i++)
  167                 {
  168                     for(j=0; j<nb_fields; j++)
  169                     {
  170                         SvTmp2 = av_fetch((AV*)listofPDL, j, 0);
  171                         curPDL = PDL->SvPDLV( *SvTmp2 );
  172 
  173                         SvTmp3 = av_fetch((AV*)sdimofPDL, j, 0);
  174                         cursdim = SvIV( *SvTmp3 );
  175 
  176                         SvTmp1 = av_fetch((AV*)sizeofPDL, j, 0);
  177                         curvalue = SvIV( *SvTmp1 );
  178 
  179                         for(k=0; k<cursdim; k++)
  180                         {
  181                             #printf("Value %d= %d\n", k, *(int *)(curPDL->data + curvalue*i + curvalue*k*nb_records));
  182                             memcpy( ptrbuff, (unsigned char *)(curPDL->data + curvalue*i + curvalue*k*nb_records), curvalue );
  183 
  184                             #printf("Value %d=%d\n", k, *(int *)(curPDL->data + curvalue*i*cursdim + curvalue*k));
  185                             #memcpy( ptrbuff, (unsigned char *)(curPDL->data + curvalue*i*cursdim + curvalue*k), curvalue );
  186 
  187                             #printf("buffer %d= %d\n", k, *(int *)ptrbuff);
  188                             ptrbuff += curvalue;
  189                         }
  190                     }
  191                 }
  192             }
  193             else
  194             { 
  195                 for(j=0; j<nb_fields; j++)
  196                 {
  197                     SvTmp2 = av_fetch((AV*)listofPDL, j, 0);
  198                     curPDL = PDL->SvPDLV( *SvTmp2 );
  199                 
  200                     SvTmp1 = av_fetch((AV*)sizeofPDL, j, 0);
  201                     curvalue = SvIV( *SvTmp1 );
  202 
  203                     SvTmp3 = av_fetch((AV*)sdimofPDL, j, 0);
  204                     cursdim = SvIV( *SvTmp3 );
  205 
  206                     memcpy( ptrbuff, (unsigned char *)(curPDL->data), curvalue*nb_records*cursdim );
  207                     ptrbuff += curvalue*nb_records*cursdim;
  208                     #printf("buffer %d= %d\n", k, curvalue*nb_records*cursdim);
  209                 }
  210                 interlace_mode = 1;
  211             }
  212             fprintf(stderr, "Calling VSwrite(VID=%d, databuff=%p, nb_records=%d, interlace_mode=%d)...\n", 
  213                     VID, databuff, nb_records, interlace_mode);
  214             RETVAL = VSwrite(VID, databuff, nb_records, interlace_mode);
  215         OUTPUT:
  216             RETVAL
  217 
  218 void
  219 _Vgetname(vgroup_id, vgroup_name);
  220                 int vgroup_id
  221                 char *vgroup_name
  222         CODE:
  223                 vgroup_name=(char *)malloc(VGNAMELENMAX);
  224                 Vgetname(vgroup_id,vgroup_name);
  225         OUTPUT:
  226                 vgroup_name
  227 
  228 void
  229 _VSgetname(vdata_id, vdata_name);
  230                 int vdata_id
  231                 char *vdata_name
  232         CODE:
  233                 vdata_name=(char *)malloc(VGNAMELENMAX*sizeof(char));
  234                 VSgetname(vdata_id,vdata_name);
  235         OUTPUT:
  236                 vdata_name
  237 
  238 void
  239 _Vgetclass(vgroup_id, vgroup_class);
  240                 int vgroup_id
  241                 char *vgroup_class
  242         CODE:
  243                 vgroup_class=(char *)malloc(VGNAMELENMAX*sizeof(char));        
  244                 Vgetclass(vgroup_id,vgroup_class);
  245         OUTPUT:
  246                 vgroup_class
  247 
  248 void
  249 _VSgetclass(vdata_id, vdata_class);
  250                 int vdata_id
  251                 char *vdata_class
  252         CODE:
  253                 vdata_class=(char *)malloc(VGNAMELENMAX*sizeof(char));        
  254                 VSgetclass(vdata_id,vdata_class);
  255         OUTPUT:
  256                 vdata_class
  257 
  258 int
  259 _VSgetfields(vdata_id, fields);
  260                 int vdata_id
  261                 char *fields
  262         CODE:
  263                 char *tmpfields;
  264                 int len;                
  265                 tmpfields=(char *)malloc(10000*sizeof(char));
  266                 RETVAL=VSgetfields(vdata_id, tmpfields);
  267                 len=strlen(tmpfields);
  268                 fields=(char *)malloc(len*sizeof(char)+1);
  269                 strcpy(fields,tmpfields);
  270         OUTPUT:
  271                 RETVAL
  272                 fields
  273 
  274 AV *
  275 _VSlone(file_id);
  276         int file_id;
  277     CODE:
  278         AV  *ref_vdata_list;
  279         int *ref_array;
  280         SV  *ref_vdata;
  281         int32 nlone;
  282         ref_vdata_list=newAV();
  283         ref_array=(int *)malloc(MAX_FIELD_SIZE*sizeof(int));
  284         nlone = VSlone(file_id, ref_array, MAX_FIELD_SIZE);
  285         int32 i;
  286         for(i=0;i<nlone;i++){
  287             ref_vdata=newSViv((IV)ref_array[i]);
  288             av_push(ref_vdata_list, ref_vdata);
  289         }
  290         RETVAL=ref_vdata_list;
  291     OUTPUT:
  292         RETVAL
  293 
  294         
  295 int
  296 _VSinquire(vdata_id, n_records, interlace, fields, vdata_size, vdata_name);
  297         int vdata_id
  298         int *n_records
  299         int *interlace
  300         char *fields
  301         int *vdata_size
  302         char *vdata_name
  303 CODE:
  304         char *tmpfields;
  305         int len;        
  306         vdata_name=(char *)malloc(VGNAMELENMAX*sizeof(char));
  307         tmpfields=(char *)malloc(10000*sizeof(char));
  308         RETVAL=VSinquire(vdata_id, n_records, interlace, tmpfields, vdata_size, vdata_name)+1;
  309         len=strlen(tmpfields);
  310         fields=(char *)malloc(len*sizeof(char)+1);
  311         strcpy(fields,tmpfields);
  312 OUTPUT:
  313         RETVAL
  314         n_records
  315         interlace
  316         fields
  317         vdata_size        
  318         vdata_name
  319 
  320 ENDOFXS
  321 
  322 pp_addpm(<<'EOPM');
  323 
  324 use PDL::Primitive;
  325 use PDL::Basic;
  326 use strict;
  327 
  328 use PDL::IO::HDF;
  329 
  330 my $TMAP = {
  331     PDL::byte->[0]   => 1, 
  332     PDL::short->[0]  => 2,
  333     PDL::ushort->[0] => 2,
  334     PDL::long->[0]   => 4,
  335     PDL::float->[0]  => 4, 
  336     PDL::double->[0] => 8 
  337 };
  338 
  339 sub _pkg_name 
  340     { return "PDL::IO::HDF::VS::" . shift() . "()"; }
  341 
  342 =head2 new
  343 
  344 =for ref
  345 
  346     Open or create a new HDF object with VS and V interface.
  347 
  348 =for usage
  349 
  350     Arguments:
  351         1 : The name of the HDF file.
  352             If you want to write to it, prepend the name with the '+' character : "+name.hdf"
  353             If you want to create it, prepend the name with the '-' character : "-name.hdf"
  354             Otherwise the file will be opened in read only mode.
  355         
  356     Returns the hdf object (die on error)
  357 
  358 =for example
  359 
  360     my $hdf = PDL::IO::HDF::VS->new("file.hdf");
  361 
  362 =cut
  363 
  364 sub new
  365 {
  366     # general
  367     my $type = shift;
  368     my $filename = shift;
  369 
  370     my $self = {};
  371     
  372     if (substr($filename, 0, 1) eq '+') 
  373     {   # open for writing
  374         $filename = substr ($filename, 1);      # chop off +
  375         $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_WRITE + PDL::IO::HDF->DFACC_READ;
  376     }
  377     if (substr($filename, 0, 1) eq '-') 
  378     {   # Creating
  379         $filename = substr ($filename, 1);      # chop off -
  380         $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_CREATE;
  381     }
  382     
  383     unless( defined($self->{ACCESS_MODE}) ) 
  384     { 
  385         $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_READ; 
  386     } 
  387 
  388     $self->{FILE_NAME} = $filename;
  389 
  390     $self->{HID} = PDL::IO::HDF::VS::_Hopen( $self->{FILE_NAME}, $self->{ACCESS_MODE}, 20 );
  391     if ($self->{HID}) 
  392     {
  393         PDL::IO::HDF::VS::_Vstart( $self->{HID} );
  394 
  395         my $SDID = PDL::IO::HDF::VS::_SDstart( $self->{FILE_NAME}, $self->{ACCESS_MODE} );
  396 
  397         #### search for vgroup
  398         my $vgroup = {};
  399 
  400         my $vg_ref = -1;
  401         while( ($vg_ref = PDL::IO::HDF::VS::_Vgetid( $self->{HID}, $vg_ref )) != PDL::IO::HDF->FAIL)
  402         {
  403             my $vg_id = PDL::IO::HDF::VS::_Vattach( $self->{HID}, $vg_ref, 'r' );
  404                  
  405             my $n_entries = 0;
  406             
  407             my $vg_name = " "x(PDL::IO::HDF->VNAMELENMAX+1);
  408             my $res = PDL::IO::HDF::VS::_Vinquire( $vg_id, $n_entries, $vg_name );
  409 
  410             my $vg_class = "";
  411             PDL::IO::HDF::VS::_Vgetclass( $vg_id, $vg_class );
  412 
  413             $vgroup->{$vg_name}->{ref} = $vg_ref;
  414             $vgroup->{$vg_name}->{class} = $vg_class;
  415 
  416             my $n_pairs = PDL::IO::HDF::VS::_Vntagrefs( $vg_id );
  417 
  418             for ( 0 .. $n_pairs-1 )
  419             {
  420                 my ($tag, $ref);
  421                 $res = PDL::IO::HDF::VS::_Vgettagref( $vg_id, $_, $tag = 0, $ref = 0 );
  422                 if($tag == 1965)
  423                 {   # Vgroup
  424                     my $id = PDL::IO::HDF::VS::_Vattach( $self->{HID}, $ref, 'r' );
  425                     my $name = " "x(PDL::IO::HDF->VNAMELENMAX+1);
  426                     my $res = PDL::IO::HDF::VS::_Vgetname( $id, $name );
  427                     PDL::IO::HDF::VS::_Vdetach( $id );
  428                     $vgroup->{$vg_name}->{children}->{$name} = $ref;
  429                     $vgroup->{$name}->{parents}->{$vg_name} = $vg_ref;
  430                 }
  431                 elsif($tag == 1962)
  432                 {   # Vdata
  433                     my $id = PDL::IO::HDF::VS::_VSattach( $self->{HID}, $ref, 'r' );
  434                     my $name = " "x(PDL::IO::HDF->VNAMELENMAX+1);
  435                     my $res = PDL::IO::HDF::VS::_VSgetname( $id, $name );
  436                     my $class = "";
  437                     PDL::IO::HDF::VS::_VSgetclass( $id, $class );
  438                     PDL::IO::HDF::VS::_VSdetach( $id );
  439                     $vgroup->{$vg_name}->{attach}->{$name}->{type} = 'VData';
  440                     $vgroup->{$vg_name}->{attach}->{$name}->{ref} = $ref;
  441                     $vgroup->{$vg_name}->{attach}->{$name}->{class} = $class 
  442                         if( $class ne '' );
  443                 }
  444                 if( ($SDID != PDL::IO::HDF->FAIL) && ($tag == 720))                #tag for SDS tag/ref  (see 702)
  445                 {
  446                     my $i = _SDreftoindex( $SDID, $ref );
  447                     my $sds_ID = _SDselect( $SDID, $i );
  448 
  449                     my $name = " "x(PDL::IO::HDF->MAX_NC_NAME+1);
  450                     my $rank = 0;
  451                     my $dimsize = " "x( (4 * PDL::IO::HDF->MAX_VAR_DIMS) + 1 );
  452                     my $numtype = 0;
  453                     my $nattrs = 0;
  454                     
  455                     $res = _SDgetinfo( $sds_ID, $name, $rank, $dimsize , $numtype, $nattrs );
  456 
  457                     $vgroup->{$vg_name}->{attach}->{$name}->{type} = 'SDS_Data';
  458                     $vgroup->{$vg_name}->{attach}->{$name}->{ref} = $ref;
  459                 }
  460             } # for each pair...
  461             
  462             PDL::IO::HDF::VS::_Vdetach( $vg_id );
  463         } # while vg_ref...
  464         
  465         PDL::IO::HDF::VS::_SDend( $SDID );
  466         $self->{VGROUP} = $vgroup;
  467 
  468         #### search for vdata
  469         my $vdata_ref=-1;
  470         my $vdata_id=-1;
  471         my $vdata = {};
  472 
  473     # get lone vdata (not member of a vgroup)
  474     my $lone=PDL::IO::HDF::VS::_VSlone($self->{HID});
  475 
  476         my $MAX_REF = 0;
  477     while ( $vdata_ref = shift @$lone )
  478         {
  479             my $mode="r";
  480             if ( $self->{ACCESS_MODE} != PDL::IO::HDF->DFACC_READ ) 
  481             { 
  482                 $mode="w";
  483             }
  484             $vdata_id = PDL::IO::HDF::VS::_VSattach( $self->{HID}, $vdata_ref, $mode );
  485             my $vdata_size = 0;
  486             my $n_records = 0;
  487             my $interlace = 0;
  488             my $fields = "";
  489             my $vdata_name = "";
  490             
  491             my $status = PDL::IO::HDF::VS::_VSinquire(
  492                             $vdata_id, $n_records, $interlace, $fields, $vdata_size, $vdata_name );
  493             die "PDL::IO::HDF::VS::_VSinquire (vdata_id=$vdata_id)"
  494                 unless $status;
  495             $vdata->{$vdata_name}->{REF} = $vdata_ref;
  496             $vdata->{$vdata_name}->{NREC} = $n_records;
  497             $vdata->{$vdata_name}->{INTERLACE} = $interlace;
  498 
  499             $vdata->{$vdata_name}->{ISATTR} = PDL::IO::HDF::VS::_VSisattr( $vdata_id );
  500      
  501             my $field_index = 0;
  502             foreach my $onefield ( split( ",", $fields ) ) 
  503             {
  504                 $vdata->{$vdata_name}->{FIELDS}->{$onefield}->{TYPE} = 
  505                     PDL::IO::HDF::VS::_VFfieldtype( $vdata_id, $field_index );
  506                 $vdata->{$vdata_name}->{FIELDS}->{$onefield}->{INDEX} = $field_index;        
  507                 $field_index++;
  508             }
  509 
  510             PDL::IO::HDF::VS::_VSdetach( $vdata_id );
  511         } # while vdata_ref...
  512 
  513         $self->{VDATA} = $vdata;
  514     } # if $self->{HDID}...
  515 
  516     bless($self, $type);
  517 } # End of new()...
  518 
  519 sub Vgetchildren
  520 {
  521     my ($self, $name) = @_;
  522     return( undef )
  523         unless defined( $self->{VGROUP}->{$name}->{children} );
  524     
  525     return keys %{$self->{VGROUP}->{$name}->{children}};
  526 } # End of Vgetchildren()...
  527 # Now defunct:
  528 sub Vgetchilds
  529 {
  530     my $self = shift;
  531     return $self->Vgetchildren( @_ );
  532 } # End of Vgetchilds()...
  533 
  534 sub Vgetattach
  535 {
  536     my ($self, $name) = @_;
  537     return( undef )
  538         unless defined( $self->{VGROUP}->{$name}->{attach} );
  539 
  540     return keys %{$self->{VGROUP}->{$name}->{children}};
  541 } # End of Vgetattach()...
  542 
  543 sub Vgetparents
  544 {
  545     my ($self, $name) = @_;
  546     return( undef )
  547         unless defined( $self->{VGROUP}->{$name}->{parents} );
  548     
  549     return keys %{$self->{VGROUP}->{$name}->{parents}};
  550 } # End of Vgetparents()...     
  551 
  552 sub Vgetmains
  553 {
  554     my ($self) = @_;
  555     my @rlist;
  556     foreach( keys %{$self->{VGROUP}} )
  557     {
  558         push(@rlist, $_) 
  559             unless defined( $self->{VGROUP}->{$_}->{parents} );
  560     }
  561     return @rlist;
  562 } # End of Vgetmains()...     
  563 
  564 sub Vcreate
  565 {
  566     my($self, $name, $class, $where) = @_;
  567   
  568     my $id = PDL::IO::HDF::VS::_Vattach( $self->{HID}, -1, 'w' );
  569     return( undef )
  570         if( $id == PDL::IO::HDF->FAIL );
  571 
  572     my $res = _Vsetname($id, $name);
  573     $res = _Vsetclass($id, $class) 
  574         if defined( $class );
  575 
  576     $self->{VGROUP}->{$name}->{ref} = '???';
  577     $self->{VGROUP}->{$name}->{class} = $class 
  578         if defined( $class );
  579 
  580     if( defined( $where ) )
  581     {
  582         return( undef )
  583             unless defined( $self->{VGROUP}->{$where} );
  584 
  585         my $ref = $self->{VGROUP}->{$where}->{ref};
  586         
  587         my $Pid = PDL::IO::HDF::VS::_Vattach( $self->{HID}, $ref, 'w' );
  588         my $index = PDL::IO::HDF::VS::_Vinsert( $Pid, $id );
  589         my ($t, $r) = (0, 0);
  590         $res = PDL::IO::HDF::VS::_Vgettagref( $Pid, $index, $t, $r );
  591         PDL::IO::HDF::VS::_Vdetach( $Pid );
  592 
  593         $self->{VGROUP}->{$name}->{parents}->{$where} = $ref;
  594         $self->{VGROUP}->{$where}->{children}->{$name} = $r;
  595         $self->{VGROUP}->{$name}->{ref} = $r;
  596     }
  597     return( _Vdetach( $id ) + 1 );
  598 } # End of Vcreate()...
  599 
  600 =head2 close
  601 
  602 =for ref
  603 
  604     Close the VS interface.
  605 
  606 =for usage
  607 
  608     no arguments
  609 
  610 =for example
  611 
  612     my $result = $hdf->close();
  613 
  614 =cut
  615 
  616 sub close 
  617 {
  618     my $self = shift;
  619     _Vend( $self->{HID} );
  620     my $Hid = $self->{HID};
  621     $self = undef;
  622     return( _Hclose($Hid) + 1 );
  623 } # End of close()...
  624 
  625 sub VSisattr
  626 {
  627     my($self, $name) = @_;
  628     
  629     return undef
  630         unless defined( $self->{VDATA}->{$name} );
  631     
  632     return $self->{VDATA}->{$name}->{ISATTR};
  633 } # End of VSisattr()...     
  634 
  635 sub VSgetnames 
  636 {
  637     my $self = shift;
  638     return keys %{$self->{VDATA}};
  639 } # End of VSgetnames()...
  640 
  641 sub VSgetfieldnames
  642 {
  643     my ( $self, $name ) = @_;
  644     
  645     my $sub = _pkg_name( 'VSgetfieldnames' );
  646     
  647     die "$sub: vdata name $name doesn't exist!\n" 
  648         unless defined( $self->{VDATA}->{$name} );
  649 
  650     return keys %{$self->{VDATA}->{$name}->{FIELDS}};
  651 } # End of VSgetfieldnames()...
  652 # Now defunct:
  653 sub VSgetfieldsnames
  654 {
  655     my $self = shift;
  656     return $self->VSgetfieldnames( @_ );
  657 } # End of VSgetfieldsnames()...
  658 
  659 
  660 sub VSread 
  661 {
  662     my ( $self, $name, $field ) = @_;
  663     my $sub = _pkg_name( 'VSread' );
  664 
  665     my $data = null;
  666     my $vdata_ref = PDL::IO::HDF::VS::_VSfind( $self->{HID}, $name );
  667     
  668     die "$sub: vdata name $name doesn't exist!\n" 
  669         unless $vdata_ref;
  670         
  671     my $vdata_id = PDL::IO::HDF::VS::_VSattach( $self->{HID}, $vdata_ref, 'r' );
  672     my $vdata_size = 0;
  673     my $n_records = 0;
  674     my $interlace = 0;
  675     my $fields = "";
  676     my $vdata_name = "";
  677     my $status = PDL::IO::HDF::VS::_VSinquire(
  678                     $vdata_id, $n_records, $interlace, $fields, $vdata_size, $vdata_name );
  679     my $data_type = PDL::IO::HDF::VS::_VFfieldtype(
  680                     $vdata_id, $self->{VDATA}->{$name}->{FIELDS}->{$field}->{INDEX} );
  681 
  682     die "$sub: data_type $data_type not implemented!\n"
  683         unless defined( $PDL::IO::HDF::SDinvtypeTMAP->{$data_type} );
  684     
  685     my $order = PDL::IO::HDF::VS::_VFfieldorder(
  686                     $vdata_id, $self->{VDATA}->{$name}->{FIELDS}->{$field}->{INDEX} );
  687     
  688     if($order == 1) 
  689     {
  690         $data = ones( $PDL::IO::HDF::SDinvtypeTMAP2->{$data_type}, $n_records );
  691     } 
  692     else 
  693     {
  694         $data = ones( $PDL::IO::HDF::SDinvtypeTMAP2->{$data_type}, $n_records, $order );
  695     }
  696     $status = PDL::IO::HDF::VS::_VSsetfields( $vdata_id, $field );
  697     
  698     die "$sub: _VSsetfields\n"
  699         unless $status;
  700 
  701     $status = PDL::IO::HDF::VS::_VSread( $vdata_id, $data, $n_records, $interlace);
  702 
  703     PDL::IO::HDF::VS::_VSdetach( $vdata_id );
  704     return $data;
  705 } # End of VSread()...
  706 
  707 sub VSwrite
  708 {
  709     my($self, $name, $mode, $field, $value) = @_;
  710 
  711     return( undef )
  712         if( $$value[0]->getndims > 2); #too many dims
  713 
  714     my $VD_id;
  715     my $res;
  716     my @foo = split( /:/, $name );
  717 
  718     return( undef )
  719         if defined( $self->{VDATA}->{$foo[0]} );
  720 
  721     $VD_id = _VSattach( $self->{HID}, -1, 'w' );
  722   
  723     return( undef )
  724         if( $VD_id == PDL::IO::HDF->FAIL );
  725 
  726     $res = _VSsetname( $VD_id, $foo[0] );
  727     return( undef )
  728         if( $res == PDL::IO::HDF->FAIL );
  729   
  730     $res = _VSsetclass( $VD_id, $foo[1] ) 
  731         if defined( $foo[1] );
  732     return( undef )
  733         if( $res == PDL::IO::HDF->FAIL );
  734 
  735     my @listfield = split( /,/, $field );
  736     for( my $i = 0; $i <= $#$value; $i++ )
  737     {
  738         my $HDFtype = $PDL::IO::HDF::SDtypeTMAP->{$$value[$i]->get_datatype()};
  739         $res = _VSfdefine( $VD_id, $listfield[$i], $HDFtype, $$value[$i]->getdim(1) );
  740         return( undef )
  741             unless $res;
  742     }
  743 
  744     $res = _VSsetfields( $VD_id, $field );
  745     return( undef ) 
  746         unless $res;
  747             
  748     my @sizeofPDL;
  749     my @sdimofPDL;
  750     foreach ( @$value )
  751     {
  752         push(@sdimofPDL, $_->getdim(1));
  753         push(@sizeofPDL, $TMAP->{$_->get_datatype()});
  754     }
  755     $res = _WriteMultPDL( $VD_id, $$value[0]->getdim(0), $#$value+1, $mode, \@sizeofPDL, \@sdimofPDL, $value);
  756    
  757     return( undef )
  758         if( _VSdetach($VD_id) == PDL::IO::HDF->FAIL );
  759     return $res;
  760 } # End of VSwrite()...
  761 
  762 
  763 sub DESTROY 
  764 {
  765     my $self = shift;
  766     $self->close;
  767 } # End of DESTROY()...
  768 
  769 EOPM
  770 
  771 #
  772 # Add the tail of the docs:
  773 #
  774 pp_addpm(<<'EOD');
  775 
  776 =head1 CURRENT AUTHOR & MAINTAINER
  777 
  778 Judd Taylor, Orbital Systems, Ltd.
  779 judd dot t at orbitalsystems dot com
  780 
  781 =head1 PREVIOUS AUTHORS
  782 
  783 Olivier Archer olivier.archer@ifremer.fr
  784 contribs of Patrick Leilde patrick.leilde@ifremer.fr
  785  
  786 =head1 SEE ALSO
  787 
  788 perl(1), PDL(1), PDL::IO::HDF(1).
  789 
  790 =cut
  791 
  792 
  793 EOD
  794 
  795 pp_done();