1pp_addpm({At => Top}, <<'EOD');
2
3=head1 NAME
4
5PDL::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
16This librairy provide functions to manipulate
17HDF4 files with VS and V interface (reading, writing, ...)
18
19For more information on HDF4, see http://www.hdfgroup.org/products/hdf4/
20
21=head1 FUNCTIONS
22
23=cut
24
25EOD
26
27
28pp_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
51EOH
52
53#define AVRef AV
54#pp_bless ("PDL::IO::HDF::VS");
55
56use FindBin;
57use lib "$FindBin::Bin/..";
58use buildfunc;
59
60
61#-------------------------------------------------------------------------
62# Create low level interface from HDF VS and V header file.
63#-------------------------------------------------------------------------
64
65create_low_level (<<'EODEF');
66#
67# HDF (H) Interface
68#
69int Hishdf(const char *filename);
70int Hopen(const char *filename, int access, int n_dds);
71int Hclose(int file_id)+1;
72#
73# VGROUP/VDATA Interface
74#
75int Vstart(int hdfid);
76int Vend(int hdfid);
77int Vgetid(int hdfid, int vgroup_ref);
78int Vattach(int hdfid, int vgroup_ref, const char *access);
79int Vdetach(int vgroup_id);
80int Vntagrefs(int vgroup_id);
81
82int Vgettagref(int vgroup_id, int index, int *tag, int *ref);
83int Vinquire(int vgroup_id, int *n_entries, char *vgroup_name);
84
85int Vsetname(int vgroup_id, const char *vgroup_name);
86int Vsetclass(int vgroup_id, const char *vgroup_class);
87int Visvg(int vgroup_id, int obj_ref);
88int Visvs(int vgroup_id, int obj_ref);
89int Vaddtagref(int vgroup_id, int tag, int ref);
90int Vinsert(int vgroup_id, int v_id);
91
92int VSsetname(int vdata_id, const char *vdata_name);
93int VSsetclass(int vdata_id, const char *vdata_class);
94int VSgetid(int hdfid, int vdata_ref);
95int VSattach(int hdfid, int vdata_ref, const char *access);
96int VSdetach(int vdata_id);
97int VSelts(int vdata_id);
98int VSsizeof(int vdata_id, const char *fields);
99int VSfind(int hdfid, const char *vdata_name);
100int VFfieldtype(int vdata_id, int field_index);
101int VFnfields(int vdata_ref);
102int VFfieldorder(int vdata_ref, int field_index);
103
104int VSfdefine(int vata_id, const char *fieldname, int data_type, int order)+1;
105int VSsetfields(int vata_id, const char *fieldname_list)+1;
106int VSwrite(int vdata_id, const PDLvoid *databuf, int n_records, int interlace_mode);
107int 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
110int VSfnattrs(int vdata_id, int field_index);
111int VSgetattr(int vdata_id, int field_index, int attr_index, PDLlong *values);
112int VSisattr(int vdata_id);
113
114int SDstart(const char *filename, int access_mode);
115int SDreftoindex(int sd_id, int sds_ref);
116int SDselect(int sd_id, int index);
117int SDgetinfo(int sds_id, char *sds_name, int *rank, int *dimsizes, int *number_type, int *nattrs);
118int SDendaccess(int sds_id);
119int SDend(int sd_id);
120
121EODEF
122
123pp_addxs('',<<'ENDOFXS');
124
125int
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
218void
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
228void
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
238void
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
248void
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
258int
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
274AV *
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
295int
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
303CODE:
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);
312OUTPUT:
313        RETVAL
314        n_records
315        interlace
316        fields
317        vdata_size
318        vdata_name
319
320ENDOFXS
321
322pp_addpm(<<'EOPM');
323
324use PDL::Primitive;
325use PDL::Basic;
326use strict;
327
328use PDL::IO::HDF;
329
330my $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
339sub _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
364sub 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
519sub 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:
528sub Vgetchilds
529{
530    my $self = shift;
531    return $self->Vgetchildren( @_ );
532} # End of Vgetchilds()...
533
534sub 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
543sub 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
552sub 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
564sub 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
616sub 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
625sub 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
635sub VSgetnames
636{
637    my $self = shift;
638    return keys %{$self->{VDATA}};
639} # End of VSgetnames()...
640
641sub 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:
653sub VSgetfieldsnames
654{
655    my $self = shift;
656    return $self->VSgetfieldnames( @_ );
657} # End of VSgetfieldsnames()...
658
659
660sub 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
707sub 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
763sub DESTROY
764{
765    my $self = shift;
766    $self->close;
767} # End of DESTROY()...
768
769EOPM
770
771#
772# Add the tail of the docs:
773#
774pp_addpm(<<'EOD');
775
776=head1 CURRENT AUTHOR & MAINTAINER
777
778Judd Taylor, Orbital Systems, Ltd.
779judd dot t at orbitalsystems dot com
780
781=head1 PREVIOUS AUTHORS
782
783Olivier Archer olivier.archer@ifremer.fr
784contribs of Patrick Leilde patrick.leilde@ifremer.fr
785
786=head1 SEE ALSO
787
788perl(1), PDL(1), PDL::IO::HDF(1).
789
790=cut
791
792
793EOD
794
795pp_done();
796