1 /*
2  * $Id: idlsave.i,v 1.1 2005-09-18 22:06:15 dhmunro Exp $
3  * read IDL save files
4  * IDL is a trademark of Reasearch Systems Incorporated (RSI)
5  * code based on work of Craig Markwardt
6  *          http://cow.physics.wisc.edu/~craigm/idl/
7  */
8 /*
9 ;  ============== STATEMENT OF RESEARCH SYSTEMS INCORPORATED ==============
10 ;---------------------------------------------------------------------------
11 ; IDL is a product of Research Systems, Inc (RSI). Use of IDL is governed
12 ; by the IDL End User License Agreement (EULA). All IDL users are
13 ; required to read and agree to the terms of the IDL EULA at the time
14 ; that they install IDL.
15 ;
16 ; The CMSVLIB software, written by Craig Markwardt, embodies
17 ; unpublished proprietary information about the IDL Save file
18 ; format. Research Systems grants to the author of this software, and
19 ; to all IDL users, a license to use and redistribute this software in
20 ; source or binary form, subject to the following conditions:
21 ;
22 ; 1. The author, and any users of this software must be in full
23 ;    compliance with the IDL End User License Agreement (EULA).
24 ; 2. Redistributions of source code must retain the complete and
25 ;    unaltered text of this notice.
26 ; 3. Redistributions in binary form must reproduce the complete and
27 ;    unaltered text of this notice in the documentation and/or other
28 ;    materials provided with the distribution.
29 ; 4. The name of Research Systems Inc. may not be used to endorse or
30 ;    promote this software or products derived from it without specific
31 ;    prior written permission from Research Systems, Inc.
32 ; 5. Allowed use of this software is limited to reading and writing
33 ;    IDL variable related portions of IDL Save files. It may not be
34 ;    used as a basis for reverse engineering, or otherwise
35 ;    accessing any other portions of an IDL save file, including but
36 ;    not limited to, those portions that encode executable IDL programs.
37 ;    Such use is in violation of the IDL EULA, and will be prosecuted
38 ;    to the fullest extent possible by Research Systems, Inc. It is
39 ;    permissible to read such sections of an IDL save file for the
40 ;    sole purpose of transferring it without examination or interpretation
41 ;    to another save file.
42 ; 6. Research Systems disclaims any responsibility for compatibility
43 ;    with this software, and reserves the right to change the IDL save
44 ;    file format in any way, at any time, including changes that would
45 ;    render this software incomplete or inoperable.
46 ; 7. This software is not a product of Research Systems Inc. Research
47 ;    Systems Inc disclaims any responsibility for its development or
48 ;    maintenance.
49 ;
50 ; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
51 ; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
52 ; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
53 ; IN NO EVENT SHALL THE AUTHOR OR RESEARCH SYSTEMS INC BE LIABLE FOR ANY
54 ; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
55 ; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
56 ; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
57 ; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
58 ; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
59 ; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
60 ; SUCH DAMAGE.
61 ;---------------------------------------------------------------------------
62 */
63 
64 func idl_open(name, &commons, loud=)
65 /* DOCUMENT f = idl_open(filename)
66  *       or f = idl_open(filename, commons)
67  *   openb for an IDL save file
68  *   optional COMMONS is returned as an array of pointers to
69  *     arrays of strings; the first string in each array is the name
70  *     of an IDL common block; the others are the names of the
71  *     variables in that common block
72  *   all variable names have been converted to lower case
73  *   loud=1 keyword reports on timestamp and other information
74  *     about the user, host, etc., stored in the save file
75  *
76  *   floating complex data becomes an array of float with leading
77  *     dimension of 2, use f2z to recover complex
78  *   64 bit integers become an array of long with leading dimension
79  *     of 2, use l2ll to recover single long (if sizeof(long)=8)
80  *
81  * SEE ALSO: openb, f2z, l2ll
82  */
83 {
84   f = open(name, "rb");
85   sign = array(char, 4);
86   _read, f, 0, sign;
87   if (anyof(sign != ['S','R','\0','\4']))
88     error, name+" signature not that of IDL save file";
89   /* Markwardt doesn't say that save file is XDR format, but seems to be */
90   xdr_primitives, f;  /* ?? save files always big-endian, 4 byte longs ?? */
91   len = sizeof(f);
92 
93   commons = [];
94   ncommon = 0;
95   a64 = 0;
96   for (addr=4 ; addr<len ;) {
97     addr0 = addr;
98     type = _idl_record(f, a64, addr);
99     if (type == 6) break;
100     addr0 += 16+a64;
101     if (type == 10) {
102       addr0 += 1024;
103       date = _idl_string(f, addr0);
104       user = _idl_string(f, addr0);
105       host = _idl_string(f, addr0);
106       if (loud) {
107         write, format="Date: %s\n", date;
108         write, format="User: %s\n", user;
109         write, format="Host: %s\n", host;
110       }
111     } else if (type == 14) {
112       sfmt = 0;
113       _read, f, addr0, sfmt;
114       addr0 += 4;
115       arch = _idl_string(f, addr0);
116       osys = _idl_string(f, addr0);
117       ridl = _idl_string(f, addr0);
118       if (loud) {
119         write, format="Save: %ld\n", sfmt;
120         write, format="Arch: %s\n", arch;
121         write, format="OS:   %s\n", osys;
122         write, format="IDL:  %s\n", ridl;
123       }
124     } else if (type == 13) {
125       author = _idl_string(f, addr0);
126       title = _idl_string(f, addr0);
127       other = _idl_string(f, addr0);
128       if (loud) {
129         write, format="Author: %s\n", author;
130         write, format="Title: %s\n", title;
131         write, format="Other: %s\n", other;
132       }
133     } else if (type == 15) {
134       write, "WARNING: "+name+" has IDL pointers";
135     } else if (type == 17) {
136       if (loud) write, "64 bit addresses present";
137     } else if (type == 1) {
138       nvars = 0;
139       _read, f, addr0, nvars;
140       addr0 += 4;
141       if (ncommon >= numberof(commons))
142         grow, commons, array(pointer, max(numberof(commons), 4));
143       com = array(string, nvars+1);
144       for (i=1 ; i<=nvars+1 ; i++) com(i) = _idl_string(f, addr0, 1);
145       commons(++ncommon) = &com;
146       com = [];
147     } else if (type==2 || type==3) {
148       vname = _idl_string(f, addr0, 1);
149       if (_idl_type(f, addr0, vtype, vdims))
150         add_variable, f, addr0, vname, vtype, vdims;
151     }
152   }
153   if (ncommon && loud) write, format="Common blocks: %ld\n", ncommon;
154   return f;
155 }
156 
157 /* record types:
158  * 0  start_marker -- start of save file
159  * 1  common -- common block
160  * 2  variable
161  * 3  system_variable
162  * 6  end_marker -- end of save file (no more records)
163  * 10 timestamp
164  * 12 compiled -- IDL byte code
165  * 13 identification -- of author
166  * 14 version -- of IDL
167  * 15 heap_header -- index info for heap
168  * 16 heap_data -- heaps used for pointer data
169  * 17 promote64 -- begin 64 bit record addresses
170  */
171 
172 func _idl_record(f, &a64, &addr)
173 {
174   head = array(long, 3);
175   _read, f, addr, head;
176   type = head(1);
177   addr = head(2);
178   addrlo = head(3);
179   /* Markwardt doesn't say if promote64 record itself has 8 byte addr! */
180   if (!addr && addrlo) addr = addrlo;
181   else if (a64) addr = addrlo | (addr<<32);
182   if (type == 17) a64 = 4;
183   return type;
184 }
185 
186 func _idl_string(f, &addr, lc)
187 {
188   len = 0;
189   _read, f, addr, len;
190   addr += 4;
191   if (len > 0) {
192     c = array(char, len);
193     _read, f, addr, c;
194     addr += len;
195     len &= 3;
196     if (len) addr += 4-len;
197     if (lc) {
198       list = where((c>='A') & (c<='Z'));
199       if (numberof(list)) c(list) |= ('A'~'a');
200     }
201   } else if (len < 0) {
202     c = [];
203   }
204   return string(&c);
205 }
206 
207 /* data types (Sun XDR format):
208  * 1  char
209  * 2  short
210  * 3  long
211  * 4  float
212  * 5  double
213  * 6  fcomplex
214  * 7  (string)
215  * 8  (struct)
216  * 9  complex
217  * 10 (pointer)
218  * 11 (object reference)
219  * 12 ushort
220  * 13 ulong
221  * 14 llong (64 bit)
222  * 15 ullong (64 bit)
223  */
224 
225 func _idl_type(f, &addr, &vtype, &vdims)
226 {
227   vtype = 0;
228   _read, f, addr, vtype;
229   addr += 4;
230   flag = 0;
231   _read, f, addr, flag;
232   addr += 4;
233   vdims = [];
234   /* flag bit 0x10 may indicate membership in a common block */
235   if (flag & 0x24) {
236     ad = array(0, 4);
237     _read, f, addr, ad;
238     /* ad(2) = 0x02 normally, 0x04, 0x08 observed in common block vars
239      * 0x36 in system vars with broken dimension lists (IDL 6.0)
240      */
241     if (ad(1)!=8 || (ad(2)&0x20)) {
242       if (loud) write, "WARNING: unknown type, skipping "+vname;
243       return 0;
244     }
245     ndims = 0;
246     addr += 16;
247     _read, f, addr, ndims;
248     addr += 12;
249     if (ndims<1 || ndims>10) {
250       if (loud) write, "WARNING: bad dims, skipping "+vname;
251       return 0;
252     }
253     vdims = array(0, 1+ndims);
254     _read, f, addr, vdims;
255     addr += 4*(vdims(1)+1);
256     vdims(1) = ndims;
257     if (flag & 0x20) {
258       /* don't bother with structs for now */
259       if (loud) write, "WARNING: struct type, skipping "+vname;
260       return 0;
261     }
262   }
263   addr += 4;
264   if (vtype == 1) {
265     vtype = char;
266     return 1;
267   } else if (vtype==2 || vtype==12) {
268     vtype = short;
269     return 1;
270   } else if (vtype==3 || vtype==13) {
271     vtype = long;
272     return 1;
273   } else if (vtype == 4) {
274     vtype = float;
275     return 1;
276   } else if (vtype == 5) {
277     vtype = double;
278     return 1;
279   } else if (vtype == 9) {
280     vtype = complex;
281     return 1;
282   } else if (vtype == 6) {
283     /* see f2z below */
284     vtype = float;
285     if (!numberof(vdims)) {
286       vdims = [1,2];
287     } else {
288       vdims = grow([vdims(1)+1],vdims);
289       vdims(2) = 2;
290     }
291     return 1;
292   } else if (vtype==14 || vtype==15) {
293     /* see l2ll below */
294     vtype = long;
295     if (!numberof(vdims)) {
296       vdims = [1,2];
297     } else {
298       vdims = grow([vdims(1)+1],vdims);
299       vdims(2) = 2;
300     }
301     return 1;
302   }
303   return 0;
304 }
305 
f2z(x)306 func f2z(x)
307 /* DOCUMENT z = f2z(x)
308  *   convert 2-by-dims float or double X to complex.
309  */
310 {
311   z = x(1,..)+0.0i;
312   z.im = x(2,..);
313   return z;
314 }
315 
l2ll(x)316 func l2ll(x)
317 /* DOCUMENT z = l2ll(x)
318  *   convert 2-by-dims 32 bit integer X to 64 bit integer
319  *   (only works if sizeof(long)=8)
320  */
321 {
322   return long(x(2,..)) | (long(x(1,..))<<32);
323 }
324