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