PDL-IO-IDL-2.098/0000755000175000017500000000000014736677230013033 5ustar osboxesosboxesPDL-IO-IDL-2.098/META.json0000644000175000017500000000250014736677230014451 0ustar osboxesosboxes{ "abstract" : "unknown", "author" : [ "PerlDL Developers " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "PDL-IO-IDL", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0", "PDL" : "2.094" } }, "runtime" : { "requires" : { "PDL" : "2.094" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/PDLPorters/PDL-IO-IDL/issues" }, "homepage" : "http://pdl.perl.org/", "repository" : { "type" : "git", "url" : "git://github.com/PDLPorters/PDL-IO-IDL.git", "web" : "https://github.com/PDLPorters/PDL-IO-IDL" }, "x_IRC" : "irc://irc.perl.org/#pdl" }, "version" : "2.098", "x_serialization_backend" : "JSON::PP version 4.04" } PDL-IO-IDL-2.098/t/0000755000175000017500000000000014736677230013276 5ustar osboxesosboxesPDL-IO-IDL-2.098/t/test.sav0000755000175000017500000001747014723735650015001 0ustar osboxesosboxesSR DThu Feb 3 23:38:54 2022monstrvald| x86_64linux7.0.6R ***************************************************************** NOTICE: IDL Save/Restore files embody unpublished proprietary information about the IDL program. Reverse engineering of this file is therefore forbidden under the terms of the IDL End User License Agreement (IDL EULA). All IDL users are required to read and agree to the terms of the IDL EULA at the time that they install IDL. Software that reads or writes files in the IDL Save/Restore format must have a license from ITT Visual Information Solutions explicitly granting the right to do so. In this case, the license will be included with the software for your inspection. Please report software that does not have such a license to ITT Visual Information Solutions (info@ittvis.com). *****************************************************************  ATMO_GRID04@@o<   (0@hx8  x8TEFFLOGGMONHVTURBLONHMASSRADIUSWLSTDMODTYPOPFLAGABUNDRHOXTAUTEMPXNEXNARHOHEIGHTNDEP(cc88888888888888E@@??BcKX@SPH?kƨ=w/ *\piQXQ\)ff QpG޸R\) zH \{\\) \)  =G\))!#33.R&{1$Q' = 0(z/.\%p7\))p08Q.H<(.ff8z1@/\)?2\C\).H<,*\&ff0z.\2=q 6=q?H?y?Y@?>?G??k`?+?Щ`?|`?"?}W ?K `?t?bV`?lp?T`??i?!@`r`@B `@`@ F@*b@(`@?@2t@@"gE`@&@*ٺ@0D@@5j@@<@C@M C@U@`@i@rû@{@,@ @@2@@ @4@@@7@ @wz`@b@@ @4L>ŵ4·q>犐h>6x^>4?s=*}?nH)?mb#?3q@l??"` ?)uVMk?-hPoA?1;h}N?4GH?7`cݴ?;@73c??]{}?B d?E\?I` ?MV?QnÕ8(?TzUےq?X犸8?\xn}R?`y?dlu%r?h خ?m د]?qU?v3JM?|~v"?2?8x5??L?eL?˛w.?3,?S?L7zs8?3v?(]?]:@I5@ T٣@'o)@z@@oJ-ȯ@!oue@%zg ;@)豲5@2YF@9%@BfKm@JjW @SjE =@@3@@ @@@3@@@@D@@3@@뙠@G@@3@@k3@@@<@3@@@3@@ 3@@@ f`@@(@@`@3@@_3@@@#@3@@3@@3@@ @3@@5@@w3@@%@3@@f`@@+@\3@@@3@@.f`@P`@@@f`@u@8@z@7@@@@@}@,`@4l@F`@[L@XA A A!TA A$_A)A0W4A4ZA:>AAL AFAMgAT"AZ Ab0AhApAv\W@A}AtAA'AVA&`A<@AA4A7%A[A;"A+A {AB BӀB!B-q B7PBAhBH} BP+BT `B](BrBX`B?`BBjB<7 BEQ@BNT@BT3`B[Bb.`BhBp,BuOB|@BvB="Bb`@BƀBBwB7cBamBB1B9BQ BBABHB}BB2B[B>B`BĆ B2BD`B]B۱BB솬B B@C{̀CQ`CCC0 C$m C(ĴC+e@C.eC/eC0 ɠC0n?C0,C1t@C1`C1zC0 C0@=a`=ij4=q`=xk=fр==֗=`=7=jL =x=`=A`=)=|= B= }`==aD=܏=M= 5=)=vr =Й=ҧo ==se=J`=ݢ`=o=7=Ѐ==5= > > `>ڑ>>%D>->4D>:U>?`>A>C+ >D:@>D>D8@>EA>F4>F >F; >E>E$P Bl BlC̀BkNBk.BjBj+?Bi Bi& Bh^BhBgBg>K`BfmBf0Bf_| Bf3 Be3BerS@BedBd.@BdrmBd̀Bc`BcX)BbBbQ Bb@BaT Ba@B`~}`B_B^YB\0BY߳@BWL BS˥BP[BHQB@1B0@0 ڠ?ةG/1 M@PրR2bSgkTm4UaV^X2 [N]:^ ^8ATMO_GRID_INTRO _0 XXThis a grid of cool, hydrostatic, spherical LTE MARCS model atmospheres for giant stars.iiThe main reference is: Gustafsson B., Edvardsson B., Eriksson K., Joergensen U.G., Nordlund AA., Plez B. ]]2008, Astronomy & Astrophysics 486, 951. More information can be found at marcs.astro.uu.se. ffThis sub-grid covers Teff between 2500K and 8000K in steps of 100K extending to 8000K with 250 K step.jjSurface gravity (logg) is between -0.5 and 3.5 in steps of 0.5. Microtubulence is 2 km/s. Scaled standard eesolar metallicity models for stars of 1 Solar mass are included. Metallicities are between -5 and +1 ''relative to the Sun in variable steps. iiThe reference to solar abundance mixture is that of Grevesse, Asplund & Sauval (2007). We keep spherical KKgrid separate from the plane-parallel models to avoid interpolation issues.ATMO_GRID_MAXDEP8ATMO_GRID_NATMO (ATMO_GRID_VERS@33PDL-IO-IDL-2.098/t/basic.t0000644000175000017500000000024314723735650014540 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::IO::IDL; # $PDL::IO::IDL::test=1; my $mod = ridl("t/test.sav"); isnt $mod, undef, 'basic read'; done_testing; PDL-IO-IDL-2.098/META.yml0000644000175000017500000000136714736677230014313 0ustar osboxesosboxes--- abstract: unknown author: - 'PerlDL Developers ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' PDL: '2.094' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: PDL-IO-IDL no_index: directory: - t - inc requires: PDL: '2.094' resources: IRC: irc://irc.perl.org/#pdl bugtracker: https://github.com/PDLPorters/PDL-IO-IDL/issues homepage: http://pdl.perl.org/ repository: git://github.com/PDLPorters/PDL-IO-IDL.git version: '2.098' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' PDL-IO-IDL-2.098/Changes0000644000175000017500000000021614736675755014337 0ustar osboxesosboxes2.098 2025-01-06 - add licence information 2.097 2024-12-09 - install pdldoc, add repo metadata 2.096 2024-12-04 - split out from PDL 2.095 PDL-IO-IDL-2.098/IDL.pm0000644000175000017500000005327514736675105014014 0ustar osboxesosboxes=head1 NAME PDL::IO::IDL -- I/O of IDL Save Files =head1 DESCRIPTION PDL::IO::IDL allows you to read and write IDL(tm) data files. Currently, only reading is implemented. Scalars, arrays, and structures are all supported. Heap pointers, compiled code, and objects are not supported. Of those three, only heap pointers are likely to be supported in the future. This code was not developed by RSI, makers of IDL. =head1 NOTES These things seem to work: =over 3 =item BYTE, SHORT, LONG, FLOAT, and DOUBLE numeric types and arrays All of these types seem to work fine. The corresponding variable is stored as a PDL in the hash element with the same name as the original variable in the file. Arrays are byteswapped as needed and are read in so that the dim list has the same indexing order within PDL as it did within IDL. =item STRINGs and arrays of STRINGs String types are stored as Perl list refs, in the hash element with the same name as the original variable in the file. =item Structures Structures are stored as hash refs. The elements of the hash may be accessed as values within the hash. =item Common blocks Variables that are notated as being in a common block are read as normal. Common-block names are collected in the special hash value '+common', which contains a hash each keyword of which is the name of a common block and each value of which is an array of variable names. =back These things are known to be not working and may one day be fixed: =over 3 =item COMPLEX numbers These could be implemented as 2-arrays or as PDL::Complex values, but aren't yet. =item PTR types These could be implemented as perl refs but currently aren't. =item writing Maybe one day -- but why bother writing a broken file format? NetCDF is better. =back These things are known to be not working and will probably never be fixed =over 3 =item Compiled code Decompiling IDL code is a violation of the IDL end-user license. To implement this, someone who does not hold an IDL license would have to reverse-engineer a set of .SAV files sent to that person by someone else with an IDL license. =item Objects IDL objects contain compiled code. =back =head1 FUNCTIONS =cut package PDL::IO::IDL; use strict; use warnings; use Exporter (); package PDL::IO::IDL; our @ISA = qw( Exporter ); our @EXPORT_OK = qw( ridl ); our @EXPORT = @EXPORT_OK; our @EXPORT_TAGS = ( Func=>[@EXPORT_OK] ); our $VERSION = "2.098"; $VERSION = eval $VERSION; use PDL; use PDL::Exporter; use Carp; use PDL::Types; =head2 ridl =for usage $x = ridl("foo.sav"); =for ref Read an IDL save file from a file. Upon successful completion, $x is a hash ref containing all of the variables that are present in the save file, indexed by original variable name. IDL identifiers are case insensitive; they're all converted to upper-case in the hash that gets returned. This may be adjustable at a future date. Furthermore, because IDL identifiers can't contain special characters, some fields that start with '+' are used to store metadata about the file itself. Numeric arrays are stored as PDLs, structures are stored as hashes, and string and structure arrays are stored as perl lists. Named structure types don't exist in perl in the same way that they do in IDL, so named structures are described in the 'structs' field of the global metadata. Anonymous structures are treated as simple hashes. Named structures are also simple hashes, but they also contain a field '+name' that refers to the name of the structure type. =cut sub ridl { my( $name ) = shift; STDERR->autoflush(1); open(IDLSAV,"<$name") || barf("ridl: Can't open `$name' for reading\n"); my $hash = read_preamble(); read_records($hash); my @snames = sort keys %{$PDL::IO::IDL::struct_table}; @snames = grep(!m/^\+/,@snames); if(@snames) { $hash->{'+structs'}={}; local $_; for(@snames) { $hash->{'+structs'}->{$_} = $PDL::IO::IDL::struct_table->{$_}->{'names'}; } } return $hash; } ############################################################ ## ## Data structure definitions... ## ## This is a list, each element of which contains a description and ## subroutine to read that particular record type. ## our $types = [ ['START_MARKER',undef] # 0 (start of SAVE file) ,['COMMON_BLOCK',\&r_com] # 1 (COMMON block definition) ,['VARIABLE',\&r_var] # 2 (Variable data) ,['SYSTEM_VARIABLE',undef] # 3 (System variable data) ,undef # 4 (??) ,undef # 5 (??) ,['END_MARKER',\&r_end] # 6 (End of SAVE file) ,undef # 7 (??) ,undef # 8 (??) ,undef # 9 (??) ,['TIMESTAMP',\&r_ts] # 10 (Timestamp of the save file) ,undef # 11 (??) ,['COMPILED',undef] # 12 (Compiled procedure or func) ,['IDENTIFICATION',undef] # 13 (Author identification) ,['VERSION',\&r_v] # 14 (IDL Version information) ,['HEAP_HEADER',undef] # 15 (Heap index information) ,['HEAP_DATA',undef] # 16 (Heap data) ,['PROMOTE64',\&r_p64] # 17 (Starts 64-bit file offsets) ]; ############################################################ ## ## Vtypes -- Representations of IDL scalar variable types. ## The first element is the name, the second element is either a ## perl string (that should be fed to unpack) or a code ref to a ## sub that decodes the type. ## our $vtypes = [ undef # 0 ,["Byte", \&r_byte_pdl, [] ] # 1 ,["Short", \&r_n_cast, [long,short] ] # 2 ,["Long", \&r_n_pdl, [long] ] # 3 ,["Float", \&r_n_pdl, [float] ] # 4 ,["Double", \&r_n_pdl, [double] ] # 5 ,["Complex", undef ] # 6 ,["String", \&r_strvar, [] ] # 7 ,["Structure", sub {}, [] ] # 8 ,["ComplexDbl",undef ] # 9 ,["HeapPtr", undef ] # 10 ,["Object", undef ] # 11 ,["UShort", \&r_n_cast, [long,ushort] ] # 12 ,["ULong", \&r_n_pdl, [long] ] # 13 ,["LongLong", undef ] # 14 ,["ULongLong", undef ] # 15 ]; ### # Cheesy way to check if 64-bit is OK our $quad_ok = eval { my @a = unpack "q","00000001"; $a[0]; }; ### Initialized in read_preamble. our $little_endian; our $swab; our $p64; ############################## # # read_preamble # # Reads the preamble of a file and returns the preamble as a hash # ref. In case of failure, it barfs. Also initializes the structure table. # sub read_preamble { my $buf; my $out; sysread(IDLSAV,$buf,4) || barf ("PDL::IO::IDL: Couldn't read preamble\n"); my @sig = unpack("a2S",$buf); barf("PDL::IO::IDL: This isn't an IDL save file (wrong magic)\n") if($sig[0] ne 'SR'); if($sig[1] == 1024 || $sig[1] == 4) { $little_endian = ($sig[1] == 1024); } else { barf "Unrecognized IDL save file type\n"; } $swab = $little_endian; $p64 = 0; $PDL::IO::IDL::struct_table = {}; return {"+meta"=>{}}; } ############################## # # read_records # # Reads all the records of the file. Splits out into several other # types of record reader... # # sub read_records { my $hash = shift; my ($buf, $tbuf); my $retval; my %nexts; my $tag_count = 0; do { ### Read header of the record sysread(IDLSAV, $tbuf, 4) || barf("PDL::IO::IDL: unexpected EOF\n"); my $type = unpack "N",$tbuf; ### Record the next seek location ### (and discard 8 more bytes) my $next; if($p64) { print "Reading 64-bit location..." if($PDL::debug); sysread(IDLSAV,$buf,8 + 8); my @next = unpack "NN",$buf; $next = $next[1] + 2**32 * $next[0]; } else { print "Reading 32-bit location..." if($PDL::debug); sysread(IDLSAV,$buf,4 + 8); $next = unpack "N",$buf; } print "$next\n" if($PDL::debug); ### ### Infinite-loop detector ### barf("Repeat index finder was activated! This is a bug or a problem with your file.\n") if($nexts{$next}) ; $nexts{$next} = 1; ### ### Call the appropriate handling routine ### $retval = 1; if(defined $types->[$type]) { if(defined ($types->[$type]->[1])) { print "Found record of type $types->[$type]->[0]...\n" if($PDL::debug || $PDL::IO::IDL::test); $retval = &{$types->[$type]->[1]}($hash); print "OK.\n" if($PDL::debug); } else { print STDERR "Ignoring record of type ".$types->[$type]->[0]." - not implemented.\n"; } } else { print STDERR "\nIgnoring record of unknown type $type - not implemented.\n"; } print "Seeking $next ($tag_count tags read so far...)\n" if($PDL::debug || $PDL::IO::IDL::test); $tag_count++; sysseek(IDLSAV, $next, 0); $FOO::hash = $hash; } while($retval); } ############################## # r_com # # Jumptable entry for the COMMONBLOCK keyword -- this loads # the variable names that belong in the COMMON block into a # metavariable. sub r_com { my $hash = shift; my $buf; sysread(IDLSAV,$buf,4); my $nvars = unpack "N",$buf; my $name = r_string(); $hash->{"+common"}->{$name} = []; for my $i(1..$nvars) { push(@{$hash->{"+common"}->{$name}},r_string()); } return 1; } ############################## # r_end # # Jumptable entry for the END TABLE keyword -- just return 0. sub r_end { 0; } ############################## # r_ts # # TIMESTAMP record handler # sub r_ts { my $hash = shift; my $buf; ### Read and discard a LONARR(258) -- why? I don't know. sysread(IDLSAV,$buf,1024); $hash->{"+meta"}->{t_date} = r_string(); $hash->{"+meta"}->{t_user} = r_string(); $hash->{"+meta"}->{t_host} = r_string(); return 1; } ############################## # r_version # # VERSION record handler # sub r_v { my $hash = shift; my $buf; my $version; sysread(IDLSAV,$buf,4); $version = $hash->{"+meta"}->{v_fmt} = unpack "N",$buf; # barf("Unknown IDL save file version ".$version) print STDERR "Warning: IDL file is v$version (neither 5 nor 6); winging it. Check results!\n" if($version != 5 && $version != 6); $hash->{"+meta"}->{v_arch} = r_string(); $hash->{"+meta"}->{v_os} = r_string(); $hash->{"+meta"}->{v_release} = r_string(); return 1; } ############################## # r_p64 sub r_p64 { my $hash = shift; $p64 = 1; } ############################## # r_var # # VARIABLE reader - parse a single variable out of a VARIABLE record. # sub r_var { my $hash = shift; ### Read in the variable name my $name = r_string(); ### Read in and parse the type my $buf; sysread(IDLSAV,$buf,8); my ($type,$flags) = unpack "NN",$buf; unless(defined $vtypes->[$type]) { barf("PDL::IO::IDL: Unknown variable type $type"); } unless(defined $vtypes->[$type]->[1]) { print STDERR "Ignoring variable $name: unsupported type ".$vtypes->[$type]->[0]."\n"; return 1; } print "Variable $name found (flags is $flags)...\n" if($PDL::debug); if((($flags & 4) == 0) and (($flags & 32) == 0)) { print "it's a scalar\n" if($PDL::debug); sysread(IDLSAV,$buf,4); my($seven) = unpack "N",$buf; if($seven != 7) { print STDERR "Warning: expected data-start key (7) but got $seven, for variable $name\n"; } ## Scalar case $hash->{$name} = &{$vtypes->[$type]->[1]} ($flags, [], @{$vtypes->[$type]->[2]}) } else { ## Array case my($arrdesc) = r_arraydesc(); if(($flags & 32) == 0) { ## Simple array case sysread(IDLSAV,$buf,4); my($indicator) = unpack "N",$buf; print STDERR "Warning: Reading data from an array but got code $indicator (expected 7)\n" if($indicator != 7); print "simple array...type=$type\n" if($PDL::debug); my @args= ($flags,[ @{$arrdesc->{dims}}[0..$arrdesc->{ndims}-1]], @{$vtypes->[$type]->[2]}); my $pdl = &{$vtypes->[$type]->[1]}(@args); $hash->{$name} = $pdl; } else { ## Structure case print "structure...\n" if($PDL::debug); my($sname) = r_structdesc(); my @structs; print "Reading $arrdesc->{nelem} structures....\n" if($PDL::debug || $PDL::IO::IDL::test); my $i; {my $buf; sysread(IDLSAV,$buf,4);} for ($i=0;$i<$arrdesc->{nelem};$i++) { if($PDL::IO::IDL::test && !($i%100)){ print "$i of $arrdesc->{nelem}...\n"; } push(@structs,r_struct($sname)); } # Make a multi-dimensional list that contains the structs $hash->{$name} = multi_dimify($arrdesc,\@structs,0); } } return 1; } ############################## # multi_dimify # # Take a linear list of items and an array descriptor, and # hand back a multi-dimensional perl list with the correct dimension # according to the descriptor. (This isn't necessary for PDL types, # only for structures and strings). # sub multi_dimify { my($arrdesc,$structs,$n) = @_; return shift @{$structs} if($arrdesc->{ndims} <= $n or $arrdesc->{ndims} == 0 or $arrdesc->{ndims}-$n == 1 && $arrdesc->{dims}->[$n]==1); if($arrdesc->{ndims} - $n == 1){ my @ret = splice @{$structs},0,$arrdesc->{dims}->[$n]; return \@ret; } my $out = []; my $i; for ($i=0;$i<$arrdesc->{dims}->[$n];$i++) { push(@{$out},multi_dimify($arrdesc,$structs,$n+1)); } return $out; } ###################################################################### ###################################################################### # # r_arraydesc - read an array descriptor from the file # our $r_arraydesc_table = ['a','b','nbytes','nelem','ndims','c','d','nmax']; sub r_arraydesc { my $out = {}; my $buf; sysread(IDLSAV,$buf,4*8); my(@vals) = unpack("N"x8,$buf); print STDERR "r_arraydesc_table: vals[0]=".$vals[0]." (should be 8)\n" if($vals[0] != 8); for my $i(0..7) { $out->{$r_arraydesc_table->[$i]} = $vals[$i]; } my $nmax = $vals[7]; my $nelem = $vals[3]; sysread(IDLSAV,$buf,$nmax*4); $out->{dims} = [unpack("N"x$nmax,$buf)]; my $dims = pdl(@{$out->{dims}}); $out->{pdldims} = $dims; print STDERR "PDL::IO::IDL: Inconsistent array dimensions in variable (nelem=$nelem, dims=".join("x",@{$out->{dims}}).")" if($nelem != $dims->prod); $out; } ############################## # # r_structdesc reads a structure description and stores it in the struct_table. # You get back the name of the structure. # sub r_structdesc { my $buf; print "Reading a structure description...\n" if($PDL::IO::IDL::test); sysread(IDLSAV,$buf,4); # Discard initial long (value=9) from descriptor my($name) = r_string(); # Have to store structures in the structure table. $name =~ s/\s//g; $name = "+anon".scalar(keys %{$PDL::IO::IDL::struct_table}) if($name eq ''); sysread(IDLSAV,$buf,4*3); my($predef,$ntags,$nbytes) = unpack("N"x3,$buf); print "predef=$predef,ntags=$ntags,nbytes=$nbytes\n" if($PDL::debug); if(!($predef & 1)) { my $i; print "not predefined. ntags=$ntags..\n" if($PDL::debug || $PDL::IO::IDL::test); my $st = $PDL::IO::IDL::struct_table->{$name} = { "ntags" => $ntags ,"nbytes"=> $nbytes ,"names" => [] ,"arrays" => [] ,"structs" => [] }; ### Read tag descriptors. sysread(IDLSAV,$buf,3*4*$ntags); $st->{descrip} = [(unpack "N"x(3*$ntags), $buf)]; print "ntags is $ntags\n" if($PDL::debug || $PDL::IO::IDL::test); ### Read tag names. for $i(0..$ntags-1) { push(@{$st->{names}},r_string()); } ### Search for nested arrays & structures my ($nstructs,$narrays) = (0,0); for $i(0..$ntags-1) { my $x = $st->{descrip}->[$i*3+2]; $nstructs++ if($x & 32); $narrays++ if($x & 38); } print "narrays=$narrays\n" if($PDL::debug || $PDL::IO::IDL::test); for $i(0..($narrays-1)) { push( @{$st->{arrays}}, r_arraydesc() ); } print "nstructs=$nstructs\n" if($PDL::debug || $PDL::IO::IDL::test); for $i(0..($nstructs-1)) { push( @{$st->{structs}}, r_structdesc() ); } } print "finished with structure desc...\n" if($PDL::IO::IDL::test); return $name; } ############################## # # r_struct # # Given the name of a structure type, read in exactly one of them. # If I were smarter, this would be the same code as the variable # reader, but I'm not so it's only similar. # our $r_struct_recursion = 0; sub r_struct { my($sname) = shift; print +("_ "x$r_struct_recursion) . "Reading a structure...\n" if($PDL::IO::IDL::test); my $zz=$r_struct_recursion; local($r_struct_recursion) = $zz++; # Get the structure descriptor from the table. my($sd) = $PDL::IO::IDL::struct_table->{$sname}; barf "Unknown structure type $sname" unless defined($sd); # Initialize the structure itself and the array and structure indices. my($struct) = {}; $struct->{'+name'} = $sname unless($sname =~ m/^\+/); my($array_no, $struct_no); # Loop over tags and snarf each one my($i); for($i=0;$i<$sd->{ntags};$i++) { my($name) = $sd->{names}->[$i]; my($type) = $sd->{descrip}->[$i*3+1]; my($flags) = $sd->{descrip}->[$i*3+2]; print "reading tag #$i ($sd->{names}->[$i])\n" if($PDL::debug); barf("PDL::IO::IDL: Unknown variable type $type in structure") unless defined($vtypes->[$type]); unless(defined($vtypes->[$type]->[1])) { print "Skipping tag $name in structure - unsupported type ".$vtypes->[$type]->[0]."\n"; $array_no++ if($flags & 38); $struct_no++ if($flags & 32); } else { if( (($flags & 4)==0) and (($flags & 32)==0) ) { ## Scalar tag case $struct->{$name} = &{$vtypes->[$type]->[1]} ($flags, [], @{$vtypes->[$type]->[2]}); } else { ### Array and/or structure case ### my($arrdesc) = $sd->{arrays}->[$array_no++]; # sysread(IDLSAV,my $buf,4); # skip indicator if(($flags & 32) == 0) { ### Tag is a simple array ### my @args = ($flags,[ @{$arrdesc->{dims}}[0..$arrdesc->{ndims}-1]], @{$vtypes->[$type]->[2]}); my $pdl = &{$vtypes->[$type]->[1]}(@args); print " pdl is $pdl\n" if($PDL::debug); $struct->{$name} = $pdl; } else { ### Tag is a structure ### my $tsname = $sd->{structs}->[$struct_no++]; my @structs = (); for $i(1..$arrdesc->{nelem}) { push(@structs,r_struct($tsname)); } $struct->{$name} = multi_dimify($arrdesc,\@structs,0); } } } } # end of ntags loop return $struct; } ############################## # # r_string # # Reads a string value, leaving the file pointer correctly aligned # on a 32-bit boundary (if it started that way). Returns the string as # a perl scalar. # sub r_string{ my ($buf,$foo); sysread(IDLSAV, $buf, 4); # Read the length... my ($len) = unpack "N",$buf; # Pad the length out to the next 32-bit boundary my $plen = $len - ($len % -4) ; sysread(IDLSAV,$buf,$plen); return unpack "A$len",$buf; } ############################## # # r_strvar # # Reads a string variable (different than r_string because # of the extra length duplication in the IDL file...) # sub r_strvar { my $buf; my $flags = shift; sysread(IDLSAV,$buf,4); return r_string(); } ############################## # # r_byte_pdl # # Reads a byte PDL (stored as a strvar) # sub r_byte_pdl { my($flags,$dims) = @_; sysread(IDLSAV,my $buf,4) if($#$dims > 1); my $x = r_string(); my $pdl = PDL->new; $pdl->set_datatype(byte->enum); $pdl->setdims($dims); ${ $pdl->get_dataref() } = $x; $pdl->upd_data; $pdl; } ############################## # # r_n_pdl # # Reads normal integer-type numerical values as a pdl. # You feed in the dimlist and type, you get back the # final pdl. The read is padded to the nearest word boundary. # sub r_n_pdl { my($flags,$dims,$type) = @_; $type = PDL::Type->new($type); my $nelem = pdl($dims)->prod; my $hunksize = PDL::Core::howbig($type->enum) * $nelem; my $pdl = PDL->new_from_specification($type,@$dims); my $dref = $pdl->get_dataref(); my $len = sysread(IDLSAV, $$dref, $hunksize - ($hunksize % -4) ); $pdl->upd_data; print "bytes were ",join(",",unpack "C"x($hunksize-($hunksize%-4)),$$dref),"\n" if($PDL::debug); $type->bswap->($pdl) if $swab; $pdl; } sub r_n_cast { my($flags,$dims,$type1,$type2) = @_; (r_n_pdl($flags,$dims,$type1))->convert($type2); } =head1 AUTHOR, LICENSE, NO WARRANTY THIS CODE IS PROVIDED WITH NO WARRANTY and may be distributed and/or modified under the same terms as PDL itself. This code is based on the analysis of the IDL save file format published by Craig Markwardt in 2002. IDL is a trademark of Research Systems Incorporated (RSI). The PDL development team, and authors of this code, are not affiliated with RSI. =cut 1; PDL-IO-IDL-2.098/README0000755000175000017500000000347614723735650013725 0ustar osboxesosboxesIDL has updated their status to allow reading of IDL SAV data files from other languages. This implementation is based on a 3rd party spec by Craig Markwardt based on the IDL 4.x and 5.x save files. It cannot read save files created by IDL 8.x. +------------------------------------------------------------------+ From Joe Hourcle, who worked to get permission to distribute this code: In January of 2011, our group had a meeting with our NASA account rep, Amanda O'Connor. I brought up that they had announced at the IDL User Meeting at either the 2009 or 2010 Fall AGU Meeting that there was now a python library to read IDL save files, and I asked what was the process to be allowed to read them from Perl. This was the response that I received. ... -Joe Begin forwarded message: > From: "Thomas Harris" > Date: February 3, 2011 12:29:18 PM EST > To: , ... > Cc: "Amanda O'Connor" > Subject: FW: ITT-VIS meeting Follow-up > > Hi all: > My name is Thomas Harris and I'm working with Amanda this year on NASA. > Amanda and I checked in to your questions regarding IDL SAV files with > our Product Management. Here is their response: > > "...We are perfectly fine with people wanting to read IDL save files > with Data in them, in whatever language they want - IDL, Matlab, Perl, > Python. > > Finally, we are going to remove the Copyright restriction from data Save > files (probably in IDL 8.1), but keep it in for code Save files. That > way there should be no confusion." > > Let me know if you have any additional questions. > Best regards, > > Thomas Harris > Technical Account Manager - Federal Sales > ITT Visual Information Solutions > > tharris@ittvis.com > direct: 303.402.4666 > tel: 303.786.9900 > mobile: 720.256.1098 > fax: 303.786.9909 > www.ittvis.com PDL-IO-IDL-2.098/MANIFEST0000644000175000017500000000037514736677230014171 0ustar osboxesosboxesChanges IDL.pm Makefile.PL MANIFEST This list of files README t/basic.t t/test.sav META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) PDL-IO-IDL-2.098/Makefile.PL0000644000175000017500000000202514736671344015004 0ustar osboxesosboxesuse ExtUtils::MakeMaker; use strict; use warnings; use PDL::Core::Dev; my $package_name = "PDL::IO::IDL"; (my $repo = $package_name) =~ s#::#-#g; $repo = "PDLPorters/$repo"; WriteMakefile( NAME => $package_name, VERSION_FROM => 'IDL.pm', AUTHOR => 'PerlDL Developers ', LICENSE=> "perl", CONFIGURE_REQUIRES => { 'ExtUtils::MakeMaker' => 0, 'PDL' => '2.094', }, PREREQ_PM => { 'PDL' => '2.094', }, META_MERGE => { "meta-spec" => { version => 2 }, resources => { homepage => 'http://pdl.perl.org/', bugtracker => {web=>"https://github.com/$repo/issues"}, repository => { url => "git://github.com/$repo.git", type => 'git', web => "https://github.com/$repo", }, x_IRC => 'irc://irc.perl.org/#pdl', }, }, ); sub MY::postamble { my $oneliner = PDL::Core::Dev::_oneliner(qq{exit if \$ENV{DESTDIR}; use PDL::Doc; eval { PDL::Doc::add_module(shift); }}); qq|\ninstall :: pure_install\n\t$oneliner \$(NAME)\n|; }