/*
* idlsave.i - $Id$
* read IDL save files
* IDL is a trademark of Reasearch Systems Incorporated (RSI)
* code based on work of Craig Markwardt
* http://cow.physics.wisc.edu/~craigm/idl/
*/
/*
; ============== STATEMENT OF RESEARCH SYSTEMS INCORPORATED ==============
;---------------------------------------------------------------------------
; IDL is a product of Research Systems, Inc (RSI). Use of IDL is governed
; by the IDL End User License Agreement (EULA). All IDL users are
; required to read and agree to the terms of the IDL EULA at the time
; that they install IDL.
;
; The CMSVLIB software, written by Craig Markwardt, embodies
; unpublished proprietary information about the IDL Save file
; format. Research Systems grants to the author of this software, and
; to all IDL users, a license to use and redistribute this software in
; source or binary form, subject to the following conditions:
;
; 1. The author, and any users of this software must be in full
; compliance with the IDL End User License Agreement (EULA).
; 2. Redistributions of source code must retain the complete and
; unaltered text of this notice.
; 3. Redistributions in binary form must reproduce the complete and
; unaltered text of this notice in the documentation and/or other
; materials provided with the distribution.
; 4. The name of Research Systems Inc. may not be used to endorse or
; promote this software or products derived from it without specific
; prior written permission from Research Systems, Inc.
; 5. Allowed use of this software is limited to reading and writing
; IDL variable related portions of IDL Save files. It may not be
; used as a basis for reverse engineering, or otherwise
; accessing any other portions of an IDL save file, including but
; not limited to, those portions that encode executable IDL programs.
; Such use is in violation of the IDL EULA, and will be prosecuted
; to the fullest extent possible by Research Systems, Inc. It is
; permissible to read such sections of an IDL save file for the
; sole purpose of transferring it without examination or interpretation
; to another save file.
; 6. Research Systems disclaims any responsibility for compatibility
; with this software, and reserves the right to change the IDL save
; file format in any way, at any time, including changes that would
; render this software incomplete or inoperable.
; 7. This software is not a product of Research Systems Inc. Research
; Systems Inc disclaims any responsibility for its development or
; maintenance.
;
; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
; IN NO EVENT SHALL THE AUTHOR OR RESEARCH SYSTEMS INC BE LIABLE FOR ANY
; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
; SUCH DAMAGE.
;---------------------------------------------------------------------------
*/
func idl_open (name, &commons, loud=)
/* DOCUMENT f = idl_open(filename)
* or f = idl_open(filename, commons)
* openb for an IDL save file
* optional COMMONS is returned as an array of pointers to
* arrays of strings; the first string in each array is the name
* of an IDL common block; the others are the names of the
* variables in that common block
* all variable names have been converted to lower case
* loud=1 keyword reports on timestamp and other information
* about the user, host, etc., stored in the save file
*
* floating complex data becomes an array of float with leading
* dimension of 2, use f2z to recover complex
* 64 bit integers become an array of long with leading dimension
* of 2, use l2ll to recover single long (if sizeof(long)=8)
*
* SEE ALSO: openb, f2z, l2ll
*/
{
f = open(name, "rb");
sign = array(char, 4);
_read, f, 0, sign;
if (anyof(sign != ['S','R','\0','\4']))
error, name+" signature not that of IDL save file";
/* Markwardt doesn't say that save file is XDR format, but seems to be */
xdr_primitives, f; /* ?? save files always big-endian, 4 byte longs ?? */
len = sizeof(f);
commons = [];
ncommon = 0;
a64 = 0;
for (addr=4 ; addr<len ;) {
addr0 = addr;
type = _idl_record(f, a64, addr);
if (type == 6) break;
addr0 += 16+a64;
if (type == 10) {
addr0 += 1024;
date = _idl_string(f, addr0);
user = _idl_string(f, addr0);
host = _idl_string(f, addr0);
if (loud) {
write, format="Date: %s\n", date;
write, format="User: %s\n", user;
write, format="Host: %s\n", host;
}
} else if (type == 14) {
sfmt = 0;
_read, f, addr0, sfmt;
addr0 += 4;
arch = _idl_string(f, addr0);
osys = _idl_string(f, addr0);
ridl = _idl_string(f, addr0);
if (loud) {
write, format="Save: %ld\n", sfmt;
write, format="Arch: %s\n", arch;
write, format="OS: %s\n", osys;
write, format="IDL: %s\n", ridl;
}
} else if (type == 13) {
author = _idl_string(f, addr0);
title = _idl_string(f, addr0);
other = _idl_string(f, addr0);
if (loud) {
write, format="Author: %s\n", author;
write, format="Title: %s\n", title;
write, format="Other: %s\n", other;
}
} else if (type == 15) {
write, "WARNING: "+name+" has IDL pointers";
} else if (type == 17) {
if (loud) write, "64 bit addresses present";
} else if (type == 1) {
nvars = 0;
_read, f, addr0, nvars;
addr0 += 4;
if (ncommon >= numberof(commons))
grow, commons, array(pointer, max(numberof(commons), 4));
com = array(string, nvars+1);
for (i=1 ; i<=nvars+1 ; i++) com(i) = _idl_string(f, addr0, 1);
commons(++ncommon) = &com;
com = [];
} else if (type==2 || type==3) {
vname = _idl_string(f, addr0, 1);
if (_idl_type(f, addr0, vtype, vdims))
add_variable, f, addr0, vname, vtype, vdims;
}
}
if (ncommon && loud) write, format="Common blocks: %ld\n", ncommon;
return f;
}
/* record types:
* 0 start_marker -- start of save file
* 1 common -- common block
* 2 variable
* 3 system_variable
* 6 end_marker -- end of save file (no more records)
* 10 timestamp
* 12 compiled -- IDL byte code
* 13 identification -- of author
* 14 version -- of IDL
* 15 heap_header -- index info for heap
* 16 heap_data -- heaps used for pointer data
* 17 promote64 -- begin 64 bit record addresses
*/
func _idl_record(f, &a64, &addr)
{
head = array(long, 3);
_read, f, addr, head;
type = head(1);
addr = head(2);
addrlo = head(3);
/* Markwardt doesn't say if promote64 record itself has 8 byte addr! */
if (!addr && addrlo) addr = addrlo;
else if (a64) addr = addrlo | (addr<<32);
if (type == 17) a64 = 4;
return type;
}
func _idl_string(f, &addr, lc)
{
len = 0;
_read, f, addr, len;
addr += 4;
if (len > 0) {
c = array(char, len);
_read, f, addr, c;
addr += len;
len &= 3;
if (len) addr += 4-len;
if (lc) {
list = where((c>='A') & (c<='Z'));
if (numberof(list)) c(list) |= ('A'~'a');
}
} else if (len < 0) {
c = [];
}
return string(&c);
}
/* data types (Sun XDR format):
* 1 char
* 2 short
* 3 long
* 4 float
* 5 double
* 6 fcomplex
* 7 (string)
* 8 (struct)
* 9 complex
* 10 (pointer)
* 11 (object reference)
* 12 ushort
* 13 ulong
* 14 llong (64 bit)
* 15 ullong (64 bit)
*/
func _idl_type(f, &addr, &vtype, &vdims)
{
vtype = 0;
_read, f, addr, vtype;
addr += 4;
flag = 0;
_read, f, addr, flag;
addr += 4;
vdims = [];
/* flag bit 0x10 may indicate membership in a common block */
if (flag & 0x24) {
ad = array(0, 4);
_read, f, addr, ad;
/* ad(2) = 0x02 normally, 0x04, 0x08 observed in common block vars
* 0x36 in system vars with broken dimension lists (IDL 6.0)
*/
if (ad(1)!=8 || (ad(2)&0x20)) {
if (loud) write, "WARNING: unknown type, skipping "+vname;
return 0;
}
ndims = 0;
addr += 16;
_read, f, addr, ndims;
addr += 12;
if (ndims<1 || ndims>10) {
if (loud) write, "WARNING: bad dims, skipping "+vname;
return 0;
}
vdims = array(0, 1+ndims);
_read, f, addr, vdims;
addr += 4*(vdims(1)+1);
vdims(1) = ndims;
if (flag & 0x20) {
/* don't bother with structs for now */
if (loud) write, "WARNING: struct type, skipping "+vname;
return 0;
}
}
addr += 4;
if (vtype == 1) {
vtype = char;
return 1;
} else if (vtype==2 || vtype==12) {
vtype = short;
return 1;
} else if (vtype==3 || vtype==13) {
vtype = long;
return 1;
} else if (vtype == 4) {
vtype = float;
return 1;
} else if (vtype == 5) {
vtype = double;
return 1;
} else if (vtype == 9) {
vtype = complex;
return 1;
} else if (vtype == 6) {
/* see f2z below */
vtype = float;
if (!numberof(vdims)) {
vdims = [1,2];
} else {
vdims = grow([vdims(1)+1],vdims);
vdims(2) = 2;
}
return 1;
} else if (vtype==14 || vtype==15) {
/* see l2ll below */
vtype = long;
if (!numberof(vdims)) {
vdims = [1,2];
} else {
vdims = grow([vdims(1)+1],vdims);
vdims(2) = 2;
}
return 1;
}
return 0;
}
func f2z (x)
/* DOCUMENT z = f2z(x)
* convert 2-by-dims float or double X to complex.
*/
{
z = x(1,..)+0.0i;
z.im = x(2,..);
return z;
}
func l2ll (x)
/* DOCUMENT z = l2ll(x)
* convert 2-by-dims 32 bit integer X to 64 bit integer
* (only works if sizeof(long)=8)
*/
{
return long(x(2,..)) | (long(x(1,..))<<32);
}
